{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE UndecidableInstances #-}

module Hydra.API.ServerOutput where

import Control.Lens ((.~))
import Data.Aeson (Value (..), defaultOptions, encode, genericParseJSON, genericToJSON, omitNothingFields, withObject, (.:))
import Data.Aeson.KeyMap qualified as KeyMap
import Data.Aeson.Lens (atKey, key)
import Data.ByteString.Lazy qualified as LBS
import Hydra.API.ClientInput (ClientInput (..))
import Hydra.Chain (PostChainTx, PostTxError)
import Hydra.Chain.ChainState (IsChainState)
import Hydra.HeadLogic.State (HeadState)
import Hydra.Ledger (ValidationError)
import Hydra.Network (Host, NodeId)
import Hydra.Prelude hiding (seq)
import Hydra.Tx (
  HeadId,
  Party,
  Snapshot,
  SnapshotNumber,
  TxIdType,
  UTxOType,
 )
import Hydra.Tx qualified as Tx
import Hydra.Tx.ContestationPeriod (ContestationPeriod)
import Hydra.Tx.Crypto (MultiSignature)
import Hydra.Tx.IsTx (ArbitraryIsTx)
import Hydra.Tx.OnChainId (OnChainId)

-- | The type of messages sent to clients by the 'Hydra.API.Server'.
data TimedServerOutput tx = TimedServerOutput
  { forall tx. TimedServerOutput tx -> ServerOutput tx
output :: ServerOutput tx
  , forall tx. TimedServerOutput tx -> Natural
seq :: Natural
  , forall tx. TimedServerOutput tx -> UTCTime
time :: UTCTime
  }
  deriving stock (TimedServerOutput tx -> TimedServerOutput tx -> Bool
(TimedServerOutput tx -> TimedServerOutput tx -> Bool)
-> (TimedServerOutput tx -> TimedServerOutput tx -> Bool)
-> Eq (TimedServerOutput tx)
forall tx.
IsChainState tx =>
TimedServerOutput tx -> TimedServerOutput tx -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall tx.
IsChainState tx =>
TimedServerOutput tx -> TimedServerOutput tx -> Bool
== :: TimedServerOutput tx -> TimedServerOutput tx -> Bool
$c/= :: forall tx.
IsChainState tx =>
TimedServerOutput tx -> TimedServerOutput tx -> Bool
/= :: TimedServerOutput tx -> TimedServerOutput tx -> Bool
Eq, Int -> TimedServerOutput tx -> ShowS
[TimedServerOutput tx] -> ShowS
TimedServerOutput tx -> String
(Int -> TimedServerOutput tx -> ShowS)
-> (TimedServerOutput tx -> String)
-> ([TimedServerOutput tx] -> ShowS)
-> Show (TimedServerOutput tx)
forall tx. IsChainState tx => Int -> TimedServerOutput tx -> ShowS
forall tx. IsChainState tx => [TimedServerOutput tx] -> ShowS
forall tx. IsChainState tx => TimedServerOutput tx -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall tx. IsChainState tx => Int -> TimedServerOutput tx -> ShowS
showsPrec :: Int -> TimedServerOutput tx -> ShowS
$cshow :: forall tx. IsChainState tx => TimedServerOutput tx -> String
show :: TimedServerOutput tx -> String
$cshowList :: forall tx. IsChainState tx => [TimedServerOutput tx] -> ShowS
showList :: [TimedServerOutput tx] -> ShowS
Show, (forall x. TimedServerOutput tx -> Rep (TimedServerOutput tx) x)
-> (forall x. Rep (TimedServerOutput tx) x -> TimedServerOutput tx)
-> Generic (TimedServerOutput tx)
forall x. Rep (TimedServerOutput tx) x -> TimedServerOutput tx
forall x. TimedServerOutput tx -> Rep (TimedServerOutput tx) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall tx x. Rep (TimedServerOutput tx) x -> TimedServerOutput tx
forall tx x. TimedServerOutput tx -> Rep (TimedServerOutput tx) x
$cfrom :: forall tx x. TimedServerOutput tx -> Rep (TimedServerOutput tx) x
from :: forall x. TimedServerOutput tx -> Rep (TimedServerOutput tx) x
$cto :: forall tx x. Rep (TimedServerOutput tx) x -> TimedServerOutput tx
to :: forall x. Rep (TimedServerOutput tx) x -> TimedServerOutput tx
Generic)

instance Arbitrary (ServerOutput tx) => Arbitrary (TimedServerOutput tx) where
  arbitrary :: Gen (TimedServerOutput tx)
arbitrary = Gen (TimedServerOutput tx)
forall a.
(Generic a, GA UnsizedOpts (Rep a),
 UniformWeight (Weights_ (Rep a))) =>
Gen a
genericArbitrary

-- | Generate a random timed server output given a normal server output.
genTimedServerOutput :: ServerOutput tx -> Gen (TimedServerOutput tx)
genTimedServerOutput :: forall tx. ServerOutput tx -> Gen (TimedServerOutput tx)
genTimedServerOutput ServerOutput tx
o =
  ServerOutput tx -> Natural -> UTCTime -> TimedServerOutput tx
forall tx.
ServerOutput tx -> Natural -> UTCTime -> TimedServerOutput tx
TimedServerOutput ServerOutput tx
o (Natural -> UTCTime -> TimedServerOutput tx)
-> Gen Natural -> Gen (UTCTime -> TimedServerOutput tx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Natural
forall a. Arbitrary a => Gen a
arbitrary Gen (UTCTime -> TimedServerOutput tx)
-> Gen UTCTime -> Gen (TimedServerOutput tx)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen UTCTime
forall a. Arbitrary a => Gen a
arbitrary

instance IsChainState tx => ToJSON (TimedServerOutput tx) where
  toJSON :: TimedServerOutput tx -> Value
toJSON TimedServerOutput{ServerOutput tx
$sel:output:TimedServerOutput :: forall tx. TimedServerOutput tx -> ServerOutput tx
output :: ServerOutput tx
output, Natural
$sel:seq:TimedServerOutput :: forall tx. TimedServerOutput tx -> Natural
seq :: Natural
seq, UTCTime
$sel:time:TimedServerOutput :: forall tx. TimedServerOutput tx -> UTCTime
time :: UTCTime
time} =
    case ServerOutput tx -> Value
forall a. ToJSON a => a -> Value
toJSON ServerOutput tx
output of
      Object Object
o ->
        Object -> Value
Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ Object
o Object -> Object -> Object
forall a. Semigroup a => a -> a -> a
<> [(Key, Value)] -> Object
forall v. [(Key, v)] -> KeyMap v
KeyMap.fromList [(Key
"seq", Natural -> Value
forall a. ToJSON a => a -> Value
toJSON Natural
seq), (Key
"timestamp", UTCTime -> Value
forall a. ToJSON a => a -> Value
toJSON UTCTime
time)]
      Value
_NotAnObject -> Text -> Value
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"expected ServerOutput to serialize to an Object"

instance IsChainState tx => FromJSON (TimedServerOutput tx) where
  parseJSON :: Value -> Parser (TimedServerOutput tx)
parseJSON Value
v = ((Object -> Parser (TimedServerOutput tx))
 -> Value -> Parser (TimedServerOutput tx))
-> Value
-> (Object -> Parser (TimedServerOutput tx))
-> Parser (TimedServerOutput tx)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (String
-> (Object -> Parser (TimedServerOutput tx))
-> Value
-> Parser (TimedServerOutput tx)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"TimedServerOutput") Value
v ((Object -> Parser (TimedServerOutput tx))
 -> Parser (TimedServerOutput tx))
-> (Object -> Parser (TimedServerOutput tx))
-> Parser (TimedServerOutput tx)
forall a b. (a -> b) -> a -> b
$ \Object
o ->
    ServerOutput tx -> Natural -> UTCTime -> TimedServerOutput tx
forall tx.
ServerOutput tx -> Natural -> UTCTime -> TimedServerOutput tx
TimedServerOutput (ServerOutput tx -> Natural -> UTCTime -> TimedServerOutput tx)
-> Parser (ServerOutput tx)
-> Parser (Natural -> UTCTime -> TimedServerOutput tx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser (ServerOutput tx)
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v Parser (Natural -> UTCTime -> TimedServerOutput tx)
-> Parser Natural -> Parser (UTCTime -> TimedServerOutput tx)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser Natural
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"seq" Parser (UTCTime -> TimedServerOutput tx)
-> Parser UTCTime -> Parser (TimedServerOutput tx)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser UTCTime
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"timestamp"

data DecommitInvalidReason tx
  = DecommitTxInvalid {forall tx. DecommitInvalidReason tx -> UTxOType tx
localUTxO :: UTxOType tx, forall tx. DecommitInvalidReason tx -> ValidationError
validationError :: ValidationError}
  | DecommitAlreadyInFlight {forall tx. DecommitInvalidReason tx -> TxIdType tx
otherDecommitTxId :: TxIdType tx}
  deriving stock ((forall x.
 DecommitInvalidReason tx -> Rep (DecommitInvalidReason tx) x)
-> (forall x.
    Rep (DecommitInvalidReason tx) x -> DecommitInvalidReason tx)
-> Generic (DecommitInvalidReason tx)
forall x.
Rep (DecommitInvalidReason tx) x -> DecommitInvalidReason tx
forall x.
DecommitInvalidReason tx -> Rep (DecommitInvalidReason tx) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall tx x.
Rep (DecommitInvalidReason tx) x -> DecommitInvalidReason tx
forall tx x.
DecommitInvalidReason tx -> Rep (DecommitInvalidReason tx) x
$cfrom :: forall tx x.
DecommitInvalidReason tx -> Rep (DecommitInvalidReason tx) x
from :: forall x.
DecommitInvalidReason tx -> Rep (DecommitInvalidReason tx) x
$cto :: forall tx x.
Rep (DecommitInvalidReason tx) x -> DecommitInvalidReason tx
to :: forall x.
Rep (DecommitInvalidReason tx) x -> DecommitInvalidReason tx
Generic)

deriving stock instance (Eq (TxIdType tx), Eq (UTxOType tx)) => Eq (DecommitInvalidReason tx)
deriving stock instance (Show (TxIdType tx), Show (UTxOType tx)) => Show (DecommitInvalidReason tx)

instance (ToJSON (TxIdType tx), ToJSON (UTxOType tx)) => ToJSON (DecommitInvalidReason tx) where
  toJSON :: DecommitInvalidReason tx -> Value
toJSON = Options -> DecommitInvalidReason tx -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
genericToJSON Options
defaultOptions

instance (FromJSON (TxIdType tx), FromJSON (UTxOType tx)) => FromJSON (DecommitInvalidReason tx) where
  parseJSON :: Value -> Parser (DecommitInvalidReason tx)
parseJSON = Options -> Value -> Parser (DecommitInvalidReason tx)
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON Options
defaultOptions

instance ArbitraryIsTx tx => Arbitrary (DecommitInvalidReason tx) where
  arbitrary :: Gen (DecommitInvalidReason tx)
arbitrary = Gen (DecommitInvalidReason tx)
forall a.
(Generic a, GA UnsizedOpts (Rep a),
 UniformWeight (Weights_ (Rep a))) =>
Gen a
genericArbitrary

-- | Individual server output messages as produced by the 'Hydra.HeadLogic' in
-- the 'ClientEffect'.
data ServerOutput tx
  = PeerConnected {forall tx. ServerOutput tx -> NodeId
peer :: NodeId}
  | PeerDisconnected {peer :: NodeId}
  | PeerHandshakeFailure
      { forall tx. ServerOutput tx -> Host
remoteHost :: Host
      , forall tx. ServerOutput tx -> Natural
ourVersion :: Natural
      , forall tx. ServerOutput tx -> [Natural]
theirVersions :: [Natural]
      }
  | HeadIsInitializing {forall tx. ServerOutput tx -> HeadId
headId :: HeadId, forall tx. ServerOutput tx -> [Party]
parties :: [Party]}
  | Committed {headId :: HeadId, forall tx. ServerOutput tx -> Party
party :: Party, forall tx. ServerOutput tx -> UTxOType tx
utxo :: UTxOType tx}
  | HeadIsOpen {headId :: HeadId, utxo :: UTxOType tx}
  | HeadIsClosed
      { headId :: HeadId
      , forall tx. ServerOutput tx -> SnapshotNumber
snapshotNumber :: SnapshotNumber
      , forall tx. ServerOutput tx -> UTCTime
contestationDeadline :: UTCTime
      -- ^ Nominal deadline until which contest can be submitted and after
      -- which fanout is possible. NOTE: Use this only for informational
      -- purpose and wait for 'ReadyToFanout' instead before sending 'Fanout'
      -- as the ledger of our cardano-node might not have progressed
      -- sufficiently in time yet and we do not re-submit transactions (yet).
      }
  | HeadIsContested {headId :: HeadId, snapshotNumber :: SnapshotNumber, contestationDeadline :: UTCTime}
  | ReadyToFanout {headId :: HeadId}
  | HeadIsAborted {headId :: HeadId, utxo :: UTxOType tx}
  | HeadIsFinalized {headId :: HeadId, utxo :: UTxOType tx}
  | CommandFailed {forall tx. ServerOutput tx -> ClientInput tx
clientInput :: ClientInput tx, forall tx. ServerOutput tx -> HeadState tx
state :: HeadState tx}
  | -- | Given transaction has been seen as valid in the Head. It is expected to
    -- eventually be part of a 'SnapshotConfirmed'.
    TxValid {headId :: HeadId, forall tx. ServerOutput tx -> tx
transaction :: tx}
  | -- | Given transaction was not not applicable to the given UTxO in time and
    -- has been dropped.
    TxInvalid {headId :: HeadId, utxo :: UTxOType tx, transaction :: tx, forall tx. ServerOutput tx -> ValidationError
validationError :: ValidationError}
  | -- | Given snapshot was confirmed and included transactions can be
    -- considered final.
    SnapshotConfirmed
      { headId :: HeadId
      , forall tx. ServerOutput tx -> Snapshot tx
snapshot :: Snapshot tx
      , forall tx. ServerOutput tx -> MultiSignature (Snapshot tx)
signatures :: MultiSignature (Snapshot tx)
      }
  | GetUTxOResponse {headId :: HeadId, utxo :: UTxOType tx}
  | InvalidInput {forall tx. ServerOutput tx -> String
reason :: String, forall tx. ServerOutput tx -> Text
input :: Text}
  | -- | A friendly welcome message which tells a client something about the
    -- node. Currently used for knowing what signing key the server uses (it
    -- only knows one), 'HeadStatus' and optionally (if 'HeadIsOpen' or
    -- 'SnapshotConfirmed' message is emitted) UTxO's present in the Hydra Head.
    Greetings
      { forall tx. ServerOutput tx -> Party
me :: Party
      , forall tx. ServerOutput tx -> HeadStatus
headStatus :: HeadStatus
      , forall tx. ServerOutput tx -> Maybe HeadId
hydraHeadId :: Maybe HeadId
      , forall tx. ServerOutput tx -> Maybe (UTxOType tx)
snapshotUtxo :: Maybe (UTxOType tx)
      , forall tx. ServerOutput tx -> String
hydraNodeVersion :: String
      }
  | PostTxOnChainFailed {forall tx. ServerOutput tx -> PostChainTx tx
postChainTx :: PostChainTx tx, forall tx. ServerOutput tx -> PostTxError tx
postTxError :: PostTxError tx}
  | IgnoredHeadInitializing
      { headId :: HeadId
      , forall tx. ServerOutput tx -> ContestationPeriod
contestationPeriod :: ContestationPeriod
      , parties :: [Party]
      , forall tx. ServerOutput tx -> [OnChainId]
participants :: [OnChainId]
      }
  | DecommitRequested {headId :: HeadId, forall tx. ServerOutput tx -> tx
decommitTx :: tx, forall tx. ServerOutput tx -> UTxOType tx
utxoToDecommit :: UTxOType tx}
  | DecommitInvalid {headId :: HeadId, decommitTx :: tx, forall tx. ServerOutput tx -> DecommitInvalidReason tx
decommitInvalidReason :: DecommitInvalidReason tx}
  | DecommitApproved {headId :: HeadId, forall tx. ServerOutput tx -> TxIdType tx
decommitTxId :: TxIdType tx, utxoToDecommit :: UTxOType tx}
  | DecommitFinalized {headId :: HeadId, decommitTxId :: TxIdType tx}
  deriving stock ((forall x. ServerOutput tx -> Rep (ServerOutput tx) x)
-> (forall x. Rep (ServerOutput tx) x -> ServerOutput tx)
-> Generic (ServerOutput tx)
forall x. Rep (ServerOutput tx) x -> ServerOutput tx
forall x. ServerOutput tx -> Rep (ServerOutput tx) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall tx x. Rep (ServerOutput tx) x -> ServerOutput tx
forall tx x. ServerOutput tx -> Rep (ServerOutput tx) x
$cfrom :: forall tx x. ServerOutput tx -> Rep (ServerOutput tx) x
from :: forall x. ServerOutput tx -> Rep (ServerOutput tx) x
$cto :: forall tx x. Rep (ServerOutput tx) x -> ServerOutput tx
to :: forall x. Rep (ServerOutput tx) x -> ServerOutput tx
Generic)

deriving stock instance IsChainState tx => Eq (ServerOutput tx)
deriving stock instance IsChainState tx => Show (ServerOutput tx)

instance IsChainState tx => ToJSON (ServerOutput tx) where
  toJSON :: ServerOutput tx -> Value
toJSON =
    Options -> ServerOutput tx -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
genericToJSON
      Options
defaultOptions
        { omitNothingFields = True
        }

instance IsChainState tx => FromJSON (ServerOutput tx) where
  parseJSON :: Value -> Parser (ServerOutput tx)
parseJSON =
    Options -> Value -> Parser (ServerOutput tx)
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON
      Options
defaultOptions
        { omitNothingFields = True
        }

instance (ArbitraryIsTx tx, IsChainState tx) => Arbitrary (ServerOutput tx) where
  arbitrary :: Gen (ServerOutput tx)
arbitrary = Gen (ServerOutput tx)
forall a.
(Generic a, GA UnsizedOpts (Rep a),
 UniformWeight (Weights_ (Rep a))) =>
Gen a
genericArbitrary

  -- NOTE: Somehow, can't use 'genericShrink' here as GHC is complaining about
  -- Overlapping instances with 'UTxOType tx' even though for a fixed `tx`, there
  -- should be only one 'UTxOType tx'
  shrink :: ServerOutput tx -> [ServerOutput tx]
shrink = \case
    PeerConnected NodeId
p -> NodeId -> ServerOutput tx
forall tx. NodeId -> ServerOutput tx
PeerConnected (NodeId -> ServerOutput tx) -> [NodeId] -> [ServerOutput tx]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NodeId -> [NodeId]
forall a. Arbitrary a => a -> [a]
shrink NodeId
p
    PeerDisconnected NodeId
p -> NodeId -> ServerOutput tx
forall tx. NodeId -> ServerOutput tx
PeerDisconnected (NodeId -> ServerOutput tx) -> [NodeId] -> [ServerOutput tx]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NodeId -> [NodeId]
forall a. Arbitrary a => a -> [a]
shrink NodeId
p
    PeerHandshakeFailure Host
rh Natural
ov [Natural]
tv -> Host -> Natural -> [Natural] -> ServerOutput tx
forall tx. Host -> Natural -> [Natural] -> ServerOutput tx
PeerHandshakeFailure (Host -> Natural -> [Natural] -> ServerOutput tx)
-> [Host] -> [Natural -> [Natural] -> ServerOutput tx]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Host -> [Host]
forall a. Arbitrary a => a -> [a]
shrink Host
rh [Natural -> [Natural] -> ServerOutput tx]
-> [Natural] -> [[Natural] -> ServerOutput tx]
forall a b. [a -> b] -> [a] -> [b]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Natural -> [Natural]
forall a. Arbitrary a => a -> [a]
shrink Natural
ov [[Natural] -> ServerOutput tx] -> [[Natural]] -> [ServerOutput tx]
forall a b. [a -> b] -> [a] -> [b]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Natural] -> [[Natural]]
forall a. Arbitrary a => a -> [a]
shrink [Natural]
tv
    HeadIsInitializing HeadId
headId [Party]
xs -> HeadId -> [Party] -> ServerOutput tx
forall tx. HeadId -> [Party] -> ServerOutput tx
HeadIsInitializing (HeadId -> [Party] -> ServerOutput tx)
-> [HeadId] -> [[Party] -> ServerOutput tx]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HeadId -> [HeadId]
forall a. Arbitrary a => a -> [a]
shrink HeadId
headId [[Party] -> ServerOutput tx] -> [[Party]] -> [ServerOutput tx]
forall a b. [a -> b] -> [a] -> [b]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Party] -> [[Party]]
forall a. Arbitrary a => a -> [a]
shrink [Party]
xs
    Committed HeadId
headId Party
p UTxOType tx
u -> HeadId -> Party -> UTxOType tx -> ServerOutput tx
forall tx. HeadId -> Party -> UTxOType tx -> ServerOutput tx
Committed (HeadId -> Party -> UTxOType tx -> ServerOutput tx)
-> [HeadId] -> [Party -> UTxOType tx -> ServerOutput tx]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HeadId -> [HeadId]
forall a. Arbitrary a => a -> [a]
shrink HeadId
headId [Party -> UTxOType tx -> ServerOutput tx]
-> [Party] -> [UTxOType tx -> ServerOutput tx]
forall a b. [a -> b] -> [a] -> [b]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Party -> [Party]
forall a. Arbitrary a => a -> [a]
shrink Party
p [UTxOType tx -> ServerOutput tx]
-> [UTxOType tx] -> [ServerOutput tx]
forall a b. [a -> b] -> [a] -> [b]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> UTxOType tx -> [UTxOType tx]
forall a. Arbitrary a => a -> [a]
shrink UTxOType tx
u
    HeadIsOpen HeadId
headId UTxOType tx
u -> HeadId -> UTxOType tx -> ServerOutput tx
forall tx. HeadId -> UTxOType tx -> ServerOutput tx
HeadIsOpen (HeadId -> UTxOType tx -> ServerOutput tx)
-> [HeadId] -> [UTxOType tx -> ServerOutput tx]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HeadId -> [HeadId]
forall a. Arbitrary a => a -> [a]
shrink HeadId
headId [UTxOType tx -> ServerOutput tx]
-> [UTxOType tx] -> [ServerOutput tx]
forall a b. [a -> b] -> [a] -> [b]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> UTxOType tx -> [UTxOType tx]
forall a. Arbitrary a => a -> [a]
shrink UTxOType tx
u
    HeadIsClosed HeadId
headId SnapshotNumber
s UTCTime
t -> HeadId -> SnapshotNumber -> UTCTime -> ServerOutput tx
forall tx. HeadId -> SnapshotNumber -> UTCTime -> ServerOutput tx
HeadIsClosed (HeadId -> SnapshotNumber -> UTCTime -> ServerOutput tx)
-> [HeadId] -> [SnapshotNumber -> UTCTime -> ServerOutput tx]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HeadId -> [HeadId]
forall a. Arbitrary a => a -> [a]
shrink HeadId
headId [SnapshotNumber -> UTCTime -> ServerOutput tx]
-> [SnapshotNumber] -> [UTCTime -> ServerOutput tx]
forall a b. [a -> b] -> [a] -> [b]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SnapshotNumber -> [SnapshotNumber]
forall a. Arbitrary a => a -> [a]
shrink SnapshotNumber
s [UTCTime -> ServerOutput tx] -> [UTCTime] -> [ServerOutput tx]
forall a b. [a -> b] -> [a] -> [b]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> UTCTime -> [UTCTime]
forall a. Arbitrary a => a -> [a]
shrink UTCTime
t
    HeadIsContested HeadId
headId SnapshotNumber
sn UTCTime
dl -> HeadId -> SnapshotNumber -> UTCTime -> ServerOutput tx
forall tx. HeadId -> SnapshotNumber -> UTCTime -> ServerOutput tx
HeadIsContested (HeadId -> SnapshotNumber -> UTCTime -> ServerOutput tx)
-> [HeadId] -> [SnapshotNumber -> UTCTime -> ServerOutput tx]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HeadId -> [HeadId]
forall a. Arbitrary a => a -> [a]
shrink HeadId
headId [SnapshotNumber -> UTCTime -> ServerOutput tx]
-> [SnapshotNumber] -> [UTCTime -> ServerOutput tx]
forall a b. [a -> b] -> [a] -> [b]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SnapshotNumber -> [SnapshotNumber]
forall a. Arbitrary a => a -> [a]
shrink SnapshotNumber
sn [UTCTime -> ServerOutput tx] -> [UTCTime] -> [ServerOutput tx]
forall a b. [a -> b] -> [a] -> [b]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> UTCTime -> [UTCTime]
forall a. Arbitrary a => a -> [a]
shrink UTCTime
dl
    ReadyToFanout HeadId
headId -> HeadId -> ServerOutput tx
forall tx. HeadId -> ServerOutput tx
ReadyToFanout (HeadId -> ServerOutput tx) -> [HeadId] -> [ServerOutput tx]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HeadId -> [HeadId]
forall a. Arbitrary a => a -> [a]
shrink HeadId
headId
    HeadIsFinalized HeadId
headId UTxOType tx
u -> HeadId -> UTxOType tx -> ServerOutput tx
forall tx. HeadId -> UTxOType tx -> ServerOutput tx
HeadIsFinalized (HeadId -> UTxOType tx -> ServerOutput tx)
-> [HeadId] -> [UTxOType tx -> ServerOutput tx]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HeadId -> [HeadId]
forall a. Arbitrary a => a -> [a]
shrink HeadId
headId [UTxOType tx -> ServerOutput tx]
-> [UTxOType tx] -> [ServerOutput tx]
forall a b. [a -> b] -> [a] -> [b]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> UTxOType tx -> [UTxOType tx]
forall a. Arbitrary a => a -> [a]
shrink UTxOType tx
u
    HeadIsAborted HeadId
headId UTxOType tx
u -> HeadId -> UTxOType tx -> ServerOutput tx
forall tx. HeadId -> UTxOType tx -> ServerOutput tx
HeadIsAborted (HeadId -> UTxOType tx -> ServerOutput tx)
-> [HeadId] -> [UTxOType tx -> ServerOutput tx]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HeadId -> [HeadId]
forall a. Arbitrary a => a -> [a]
shrink HeadId
headId [UTxOType tx -> ServerOutput tx]
-> [UTxOType tx] -> [ServerOutput tx]
forall a b. [a -> b] -> [a] -> [b]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> UTxOType tx -> [UTxOType tx]
forall a. Arbitrary a => a -> [a]
shrink UTxOType tx
u
    CommandFailed ClientInput tx
i HeadState tx
s -> ClientInput tx -> HeadState tx -> ServerOutput tx
forall tx. ClientInput tx -> HeadState tx -> ServerOutput tx
CommandFailed (ClientInput tx -> HeadState tx -> ServerOutput tx)
-> [ClientInput tx] -> [HeadState tx -> ServerOutput tx]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ClientInput tx -> [ClientInput tx]
forall a. Arbitrary a => a -> [a]
shrink ClientInput tx
i [HeadState tx -> ServerOutput tx]
-> [HeadState tx] -> [ServerOutput tx]
forall a b. [a -> b] -> [a] -> [b]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> HeadState tx -> [HeadState tx]
forall a. Arbitrary a => a -> [a]
shrink HeadState tx
s
    TxValid HeadId
headId tx
tx -> HeadId -> tx -> ServerOutput tx
forall tx. HeadId -> tx -> ServerOutput tx
TxValid (HeadId -> tx -> ServerOutput tx)
-> [HeadId] -> [tx -> ServerOutput tx]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HeadId -> [HeadId]
forall a. Arbitrary a => a -> [a]
shrink HeadId
headId [tx -> ServerOutput tx] -> [tx] -> [ServerOutput tx]
forall a b. [a -> b] -> [a] -> [b]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> tx -> [tx]
forall a. Arbitrary a => a -> [a]
shrink tx
tx
    TxInvalid HeadId
headId UTxOType tx
u tx
tx ValidationError
err -> HeadId -> UTxOType tx -> tx -> ValidationError -> ServerOutput tx
forall tx.
HeadId -> UTxOType tx -> tx -> ValidationError -> ServerOutput tx
TxInvalid (HeadId -> UTxOType tx -> tx -> ValidationError -> ServerOutput tx)
-> [HeadId]
-> [UTxOType tx -> tx -> ValidationError -> ServerOutput tx]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HeadId -> [HeadId]
forall a. Arbitrary a => a -> [a]
shrink HeadId
headId [UTxOType tx -> tx -> ValidationError -> ServerOutput tx]
-> [UTxOType tx] -> [tx -> ValidationError -> ServerOutput tx]
forall a b. [a -> b] -> [a] -> [b]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> UTxOType tx -> [UTxOType tx]
forall a. Arbitrary a => a -> [a]
shrink UTxOType tx
u [tx -> ValidationError -> ServerOutput tx]
-> [tx] -> [ValidationError -> ServerOutput tx]
forall a b. [a -> b] -> [a] -> [b]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> tx -> [tx]
forall a. Arbitrary a => a -> [a]
shrink tx
tx [ValidationError -> ServerOutput tx]
-> [ValidationError] -> [ServerOutput tx]
forall a b. [a -> b] -> [a] -> [b]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ValidationError -> [ValidationError]
forall a. Arbitrary a => a -> [a]
shrink ValidationError
err
    SnapshotConfirmed HeadId
headId Snapshot tx
s MultiSignature (Snapshot tx)
ms -> HeadId
-> Snapshot tx -> MultiSignature (Snapshot tx) -> ServerOutput tx
forall tx.
HeadId
-> Snapshot tx -> MultiSignature (Snapshot tx) -> ServerOutput tx
SnapshotConfirmed (HeadId
 -> Snapshot tx -> MultiSignature (Snapshot tx) -> ServerOutput tx)
-> [HeadId]
-> [Snapshot tx -> MultiSignature (Snapshot tx) -> ServerOutput tx]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HeadId -> [HeadId]
forall a. Arbitrary a => a -> [a]
shrink HeadId
headId [Snapshot tx -> MultiSignature (Snapshot tx) -> ServerOutput tx]
-> [Snapshot tx]
-> [MultiSignature (Snapshot tx) -> ServerOutput tx]
forall a b. [a -> b] -> [a] -> [b]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Snapshot tx -> [Snapshot tx]
forall a. Arbitrary a => a -> [a]
shrink Snapshot tx
s [MultiSignature (Snapshot tx) -> ServerOutput tx]
-> [MultiSignature (Snapshot tx)] -> [ServerOutput tx]
forall a b. [a -> b] -> [a] -> [b]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> MultiSignature (Snapshot tx) -> [MultiSignature (Snapshot tx)]
forall a. Arbitrary a => a -> [a]
shrink MultiSignature (Snapshot tx)
ms
    GetUTxOResponse HeadId
headId UTxOType tx
u -> HeadId -> UTxOType tx -> ServerOutput tx
forall tx. HeadId -> UTxOType tx -> ServerOutput tx
GetUTxOResponse (HeadId -> UTxOType tx -> ServerOutput tx)
-> [HeadId] -> [UTxOType tx -> ServerOutput tx]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HeadId -> [HeadId]
forall a. Arbitrary a => a -> [a]
shrink HeadId
headId [UTxOType tx -> ServerOutput tx]
-> [UTxOType tx] -> [ServerOutput tx]
forall a b. [a -> b] -> [a] -> [b]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> UTxOType tx -> [UTxOType tx]
forall a. Arbitrary a => a -> [a]
shrink UTxOType tx
u
    InvalidInput String
r Text
i -> String -> Text -> ServerOutput tx
forall tx. String -> Text -> ServerOutput tx
InvalidInput (String -> Text -> ServerOutput tx)
-> [String] -> [Text -> ServerOutput tx]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [String]
forall a. Arbitrary a => a -> [a]
shrink String
r [Text -> ServerOutput tx] -> [Text] -> [ServerOutput tx]
forall a b. [a -> b] -> [a] -> [b]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Text -> [Text]
forall a. Arbitrary a => a -> [a]
shrink Text
i
    Greetings Party
me HeadStatus
headStatus Maybe HeadId
hydraHeadId Maybe (UTxOType tx)
snapshotUtxo String
hydraNodeVersion ->
      Party
-> HeadStatus
-> Maybe HeadId
-> Maybe (UTxOType tx)
-> String
-> ServerOutput tx
forall tx.
Party
-> HeadStatus
-> Maybe HeadId
-> Maybe (UTxOType tx)
-> String
-> ServerOutput tx
Greetings
        (Party
 -> HeadStatus
 -> Maybe HeadId
 -> Maybe (UTxOType tx)
 -> String
 -> ServerOutput tx)
-> [Party]
-> [HeadStatus
    -> Maybe HeadId
    -> Maybe (UTxOType tx)
    -> String
    -> ServerOutput tx]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Party -> [Party]
forall a. Arbitrary a => a -> [a]
shrink Party
me
        [HeadStatus
 -> Maybe HeadId
 -> Maybe (UTxOType tx)
 -> String
 -> ServerOutput tx]
-> [HeadStatus]
-> [Maybe HeadId
    -> Maybe (UTxOType tx) -> String -> ServerOutput tx]
forall a b. [a -> b] -> [a] -> [b]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> HeadStatus -> [HeadStatus]
forall a. Arbitrary a => a -> [a]
shrink HeadStatus
headStatus
        [Maybe HeadId -> Maybe (UTxOType tx) -> String -> ServerOutput tx]
-> [Maybe HeadId]
-> [Maybe (UTxOType tx) -> String -> ServerOutput tx]
forall a b. [a -> b] -> [a] -> [b]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe HeadId -> [Maybe HeadId]
forall a. Arbitrary a => a -> [a]
shrink Maybe HeadId
hydraHeadId
        [Maybe (UTxOType tx) -> String -> ServerOutput tx]
-> [Maybe (UTxOType tx)] -> [String -> ServerOutput tx]
forall a b. [a -> b] -> [a] -> [b]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe (UTxOType tx) -> [Maybe (UTxOType tx)]
forall a. Arbitrary a => a -> [a]
shrink Maybe (UTxOType tx)
snapshotUtxo
        [String -> ServerOutput tx] -> [String] -> [ServerOutput tx]
forall a b. [a -> b] -> [a] -> [b]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> [String]
forall a. Arbitrary a => a -> [a]
shrink String
hydraNodeVersion
    PostTxOnChainFailed PostChainTx tx
p PostTxError tx
e -> PostChainTx tx -> PostTxError tx -> ServerOutput tx
forall tx. PostChainTx tx -> PostTxError tx -> ServerOutput tx
PostTxOnChainFailed (PostChainTx tx -> PostTxError tx -> ServerOutput tx)
-> [PostChainTx tx] -> [PostTxError tx -> ServerOutput tx]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PostChainTx tx -> [PostChainTx tx]
forall a. Arbitrary a => a -> [a]
shrink PostChainTx tx
p [PostTxError tx -> ServerOutput tx]
-> [PostTxError tx] -> [ServerOutput tx]
forall a b. [a -> b] -> [a] -> [b]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> PostTxError tx -> [PostTxError tx]
forall a. Arbitrary a => a -> [a]
shrink PostTxError tx
e
    IgnoredHeadInitializing{} -> []
    DecommitRequested HeadId
headId tx
txid UTxOType tx
u -> HeadId -> tx -> UTxOType tx -> ServerOutput tx
forall tx. HeadId -> tx -> UTxOType tx -> ServerOutput tx
DecommitRequested HeadId
headId tx
txid (UTxOType tx -> ServerOutput tx)
-> [UTxOType tx] -> [ServerOutput tx]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UTxOType tx -> [UTxOType tx]
forall a. Arbitrary a => a -> [a]
shrink UTxOType tx
u
    DecommitInvalid{} -> []
    DecommitApproved HeadId
headId TxIdType tx
txid UTxOType tx
u -> HeadId -> TxIdType tx -> UTxOType tx -> ServerOutput tx
forall tx. HeadId -> TxIdType tx -> UTxOType tx -> ServerOutput tx
DecommitApproved HeadId
headId TxIdType tx
txid (UTxOType tx -> ServerOutput tx)
-> [UTxOType tx] -> [ServerOutput tx]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UTxOType tx -> [UTxOType tx]
forall a. Arbitrary a => a -> [a]
shrink UTxOType tx
u
    DecommitFinalized{} -> []

-- | Whether or not to include full UTxO in server outputs.
data WithUTxO = WithUTxO | WithoutUTxO
  deriving stock (WithUTxO -> WithUTxO -> Bool
(WithUTxO -> WithUTxO -> Bool)
-> (WithUTxO -> WithUTxO -> Bool) -> Eq WithUTxO
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: WithUTxO -> WithUTxO -> Bool
== :: WithUTxO -> WithUTxO -> Bool
$c/= :: WithUTxO -> WithUTxO -> Bool
/= :: WithUTxO -> WithUTxO -> Bool
Eq, Int -> WithUTxO -> ShowS
[WithUTxO] -> ShowS
WithUTxO -> String
(Int -> WithUTxO -> ShowS)
-> (WithUTxO -> String) -> ([WithUTxO] -> ShowS) -> Show WithUTxO
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> WithUTxO -> ShowS
showsPrec :: Int -> WithUTxO -> ShowS
$cshow :: WithUTxO -> String
show :: WithUTxO -> String
$cshowList :: [WithUTxO] -> ShowS
showList :: [WithUTxO] -> ShowS
Show)

newtype ServerOutputConfig = ServerOutputConfig
  { ServerOutputConfig -> WithUTxO
utxoInSnapshot :: WithUTxO
  }
  deriving stock (ServerOutputConfig -> ServerOutputConfig -> Bool
(ServerOutputConfig -> ServerOutputConfig -> Bool)
-> (ServerOutputConfig -> ServerOutputConfig -> Bool)
-> Eq ServerOutputConfig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ServerOutputConfig -> ServerOutputConfig -> Bool
== :: ServerOutputConfig -> ServerOutputConfig -> Bool
$c/= :: ServerOutputConfig -> ServerOutputConfig -> Bool
/= :: ServerOutputConfig -> ServerOutputConfig -> Bool
Eq, Int -> ServerOutputConfig -> ShowS
[ServerOutputConfig] -> ShowS
ServerOutputConfig -> String
(Int -> ServerOutputConfig -> ShowS)
-> (ServerOutputConfig -> String)
-> ([ServerOutputConfig] -> ShowS)
-> Show ServerOutputConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ServerOutputConfig -> ShowS
showsPrec :: Int -> ServerOutputConfig -> ShowS
$cshow :: ServerOutputConfig -> String
show :: ServerOutputConfig -> String
$cshowList :: [ServerOutputConfig] -> ShowS
showList :: [ServerOutputConfig] -> ShowS
Show)

-- | Replaces the json encoded tx field with it's cbor representation.
--
-- NOTE: we deliberately pattern match on all 'ServerOutput' constructors in
-- 'handleTxOutput' so that we don't forget to update this function if they
-- change.
prepareServerOutput ::
  IsChainState tx =>
  -- | Decide on tx representation
  ServerOutputConfig ->
  -- | Server output
  TimedServerOutput tx ->
  -- | Final output
  LBS.ByteString
prepareServerOutput :: forall tx.
IsChainState tx =>
ServerOutputConfig -> TimedServerOutput tx -> ByteString
prepareServerOutput ServerOutputConfig{WithUTxO
$sel:utxoInSnapshot:ServerOutputConfig :: ServerOutputConfig -> WithUTxO
utxoInSnapshot :: WithUTxO
utxoInSnapshot} TimedServerOutput tx
response =
  case TimedServerOutput tx -> ServerOutput tx
forall tx. TimedServerOutput tx -> ServerOutput tx
output TimedServerOutput tx
response of
    PeerConnected{} -> ByteString
encodedResponse
    PeerDisconnected{} -> ByteString
encodedResponse
    PeerHandshakeFailure{} -> ByteString
encodedResponse
    HeadIsInitializing{} -> ByteString
encodedResponse
    Committed{} -> ByteString
encodedResponse
    HeadIsOpen{} -> ByteString
encodedResponse
    HeadIsClosed{} -> ByteString
encodedResponse
    HeadIsContested{} -> ByteString
encodedResponse
    ReadyToFanout{} -> ByteString
encodedResponse
    HeadIsAborted{} -> ByteString
encodedResponse
    HeadIsFinalized{} -> ByteString
encodedResponse
    CommandFailed{} -> ByteString
encodedResponse
    TxValid{$sel:transaction:PeerConnected :: forall tx. ServerOutput tx -> tx
Hydra.API.ServerOutput.transaction = tx
tx} ->
      (Key -> Traversal' ByteString Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"transaction" ((Value -> Identity Value) -> ByteString -> Identity ByteString)
-> Value -> ByteString -> ByteString
forall s t a b. ASetter s t a b -> b -> s -> t
.~ tx -> Value
forall a. ToJSON a => a -> Value
toJSON tx
tx) ByteString
encodedResponse
    TxInvalid{$sel:transaction:PeerConnected :: forall tx. ServerOutput tx -> tx
Hydra.API.ServerOutput.transaction = tx
tx} ->
      (Key -> Traversal' ByteString Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"transaction" ((Value -> Identity Value) -> ByteString -> Identity ByteString)
-> Value -> ByteString -> ByteString
forall s t a b. ASetter s t a b -> b -> s -> t
.~ tx -> Value
forall a. ToJSON a => a -> Value
toJSON tx
tx) ByteString
encodedResponse
    SnapshotConfirmed{} ->
      (ByteString -> ByteString) -> ByteString -> ByteString
handleUtxoInclusion (Key -> Traversal' ByteString Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"snapshot" ((Value -> Identity Value) -> ByteString -> Identity ByteString)
-> ((Maybe Value -> Identity (Maybe Value))
    -> Value -> Identity Value)
-> (Maybe Value -> Identity (Maybe Value))
-> ByteString
-> Identity ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Traversal' Value (Maybe Value)
forall t. AsValue t => Key -> Traversal' t (Maybe Value)
atKey Key
"utxo" ((Maybe Value -> Identity (Maybe Value))
 -> ByteString -> Identity ByteString)
-> Maybe Value -> ByteString -> ByteString
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Maybe Value
forall a. Maybe a
Nothing) ByteString
encodedResponse
    GetUTxOResponse{} -> ByteString
encodedResponse
    InvalidInput{} -> ByteString
encodedResponse
    Greetings{} -> ByteString
encodedResponse
    PostTxOnChainFailed{} -> ByteString
encodedResponse
    IgnoredHeadInitializing{} -> ByteString
encodedResponse
    DecommitRequested{} -> ByteString
encodedResponse
    DecommitApproved{} -> ByteString
encodedResponse
    DecommitFinalized{} -> ByteString
encodedResponse
    DecommitInvalid{} -> ByteString
encodedResponse
 where
  handleUtxoInclusion :: (ByteString -> ByteString) -> ByteString -> ByteString
handleUtxoInclusion ByteString -> ByteString
f ByteString
bs =
    case WithUTxO
utxoInSnapshot of
      WithUTxO
WithUTxO -> ByteString
bs
      WithUTxO
WithoutUTxO -> ByteString
bs ByteString -> (ByteString -> ByteString) -> ByteString
forall a b. a -> (a -> b) -> b
& ByteString -> ByteString
f

  encodedResponse :: ByteString
encodedResponse = TimedServerOutput tx -> ByteString
forall a. ToJSON a => a -> ByteString
encode TimedServerOutput tx
response

-- | All possible Hydra states displayed in the API server outputs.
data HeadStatus
  = Idle
  | Initializing
  | Open
  | Closed
  | FanoutPossible
  | Final
  deriving stock (HeadStatus -> HeadStatus -> Bool
(HeadStatus -> HeadStatus -> Bool)
-> (HeadStatus -> HeadStatus -> Bool) -> Eq HeadStatus
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: HeadStatus -> HeadStatus -> Bool
== :: HeadStatus -> HeadStatus -> Bool
$c/= :: HeadStatus -> HeadStatus -> Bool
/= :: HeadStatus -> HeadStatus -> Bool
Eq, Int -> HeadStatus -> ShowS
[HeadStatus] -> ShowS
HeadStatus -> String
(Int -> HeadStatus -> ShowS)
-> (HeadStatus -> String)
-> ([HeadStatus] -> ShowS)
-> Show HeadStatus
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HeadStatus -> ShowS
showsPrec :: Int -> HeadStatus -> ShowS
$cshow :: HeadStatus -> String
show :: HeadStatus -> String
$cshowList :: [HeadStatus] -> ShowS
showList :: [HeadStatus] -> ShowS
Show, (forall x. HeadStatus -> Rep HeadStatus x)
-> (forall x. Rep HeadStatus x -> HeadStatus) -> Generic HeadStatus
forall x. Rep HeadStatus x -> HeadStatus
forall x. HeadStatus -> Rep HeadStatus x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. HeadStatus -> Rep HeadStatus x
from :: forall x. HeadStatus -> Rep HeadStatus x
$cto :: forall x. Rep HeadStatus x -> HeadStatus
to :: forall x. Rep HeadStatus x -> HeadStatus
Generic)
  deriving anyclass ([HeadStatus] -> Value
[HeadStatus] -> Encoding
HeadStatus -> Bool
HeadStatus -> Value
HeadStatus -> Encoding
(HeadStatus -> Value)
-> (HeadStatus -> Encoding)
-> ([HeadStatus] -> Value)
-> ([HeadStatus] -> Encoding)
-> (HeadStatus -> Bool)
-> ToJSON HeadStatus
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: HeadStatus -> Value
toJSON :: HeadStatus -> Value
$ctoEncoding :: HeadStatus -> Encoding
toEncoding :: HeadStatus -> Encoding
$ctoJSONList :: [HeadStatus] -> Value
toJSONList :: [HeadStatus] -> Value
$ctoEncodingList :: [HeadStatus] -> Encoding
toEncodingList :: [HeadStatus] -> Encoding
$comitField :: HeadStatus -> Bool
omitField :: HeadStatus -> Bool
ToJSON, Maybe HeadStatus
Value -> Parser [HeadStatus]
Value -> Parser HeadStatus
(Value -> Parser HeadStatus)
-> (Value -> Parser [HeadStatus])
-> Maybe HeadStatus
-> FromJSON HeadStatus
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser HeadStatus
parseJSON :: Value -> Parser HeadStatus
$cparseJSONList :: Value -> Parser [HeadStatus]
parseJSONList :: Value -> Parser [HeadStatus]
$comittedField :: Maybe HeadStatus
omittedField :: Maybe HeadStatus
FromJSON)

instance Arbitrary HeadStatus where
  arbitrary :: Gen HeadStatus
arbitrary = Gen HeadStatus
forall a.
(Generic a, GA UnsizedOpts (Rep a),
 UniformWeight (Weights_ (Rep a))) =>
Gen a
genericArbitrary

-- | Projection to obtain the 'HeadId' needed to draft a commit transaction.
-- NOTE: We only want to project 'HeadId' when the Head is in the 'Initializing'
-- state since this is when Head parties need to commit some funds.
projectInitializingHeadId :: Maybe HeadId -> ServerOutput tx -> Maybe HeadId
projectInitializingHeadId :: forall tx. Maybe HeadId -> ServerOutput tx -> Maybe HeadId
projectInitializingHeadId Maybe HeadId
mHeadId = \case
  HeadIsInitializing{HeadId
$sel:headId:PeerConnected :: forall tx. ServerOutput tx -> HeadId
headId :: HeadId
headId} -> HeadId -> Maybe HeadId
forall a. a -> Maybe a
Just HeadId
headId
  HeadIsOpen{} -> Maybe HeadId
forall a. Maybe a
Nothing
  HeadIsAborted{} -> Maybe HeadId
forall a. Maybe a
Nothing
  ServerOutput tx
_other -> Maybe HeadId
mHeadId

-- | Projection function related to 'headStatus' field in 'Greetings' message.
projectHeadStatus :: HeadStatus -> ServerOutput tx -> HeadStatus
projectHeadStatus :: forall tx. HeadStatus -> ServerOutput tx -> HeadStatus
projectHeadStatus HeadStatus
headStatus = \case
  HeadIsInitializing{} -> HeadStatus
Initializing
  HeadIsOpen{} -> HeadStatus
Open
  HeadIsClosed{} -> HeadStatus
Closed
  ReadyToFanout{} -> HeadStatus
FanoutPossible
  HeadIsFinalized{} -> HeadStatus
Final
  ServerOutput tx
_other -> HeadStatus
headStatus

-- | Projection of latest confirmed snapshot UTxO.
projectSnapshotUtxo :: Maybe (UTxOType tx) -> ServerOutput tx -> Maybe (UTxOType tx)
projectSnapshotUtxo :: forall tx.
Maybe (UTxOType tx) -> ServerOutput tx -> Maybe (UTxOType tx)
projectSnapshotUtxo Maybe (UTxOType tx)
snapshotUtxo = \case
  SnapshotConfirmed HeadId
_ Snapshot tx
snapshot MultiSignature (Snapshot tx)
_ -> UTxOType tx -> Maybe (UTxOType tx)
forall a. a -> Maybe a
Just (UTxOType tx -> Maybe (UTxOType tx))
-> UTxOType tx -> Maybe (UTxOType tx)
forall a b. (a -> b) -> a -> b
$ Snapshot tx -> UTxOType tx
forall tx. Snapshot tx -> UTxOType tx
Tx.utxo Snapshot tx
snapshot
  HeadIsOpen HeadId
_ UTxOType tx
utxos -> UTxOType tx -> Maybe (UTxOType tx)
forall a. a -> Maybe a
Just UTxOType tx
utxos
  ServerOutput tx
_other -> Maybe (UTxOType tx)
snapshotUtxo