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

module Hydra.API.ServerOutput (
  module Hydra.API.ServerOutput,
  ApiEncoding (..),
) where

import Cardano.Binary (Decoder)
import Control.Lens ((.~))
import Data.Aeson (Value (..), defaultOptions, encode, genericParseJSON, genericToJSON, omitNothingFields, tagSingleConstructors, 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.API.WireFormat (ApiEncoding (..))
import Hydra.Chain (PostChainTx, PostTxError)
import Hydra.Chain.ChainState (ChainSlot, IsChainState)
import Hydra.HeadLogic.Error (SideLoadRequirementFailure)
import Hydra.HeadLogic.State (ClosedState (..), FanoutMode (..), HeadState, OpenState (..), PartialFanoutState (..), SeenSnapshot (..))
import Hydra.HeadLogic.State qualified as HeadState
import Hydra.Ledger (ValidationError)
import Hydra.Network (Host, ProtocolVersion)
import Hydra.Node.Environment (Environment (..))
import Hydra.Node.State (NodeState, SyncedStatus)
import Hydra.Prelude hiding (seq)
import Hydra.Tx (HeadId, Party, Snapshot, SnapshotNumber, getSnapshot)
import Hydra.Tx qualified as Tx
import Hydra.Tx.ContestationPeriod (ContestationPeriod)
import Hydra.Tx.Crypto (MultiSignature)
import Hydra.Tx.IsTx (IsTx (..))
import Hydra.Tx.OnChainId (OnChainId)
import Hydra.Tx.Snapshot (Snapshot (..))
import Hydra.Tx.Snapshot qualified as HeadState

-- | The type of messages sent to clients by the 'Hydra.API.Server'.
--
-- NOTE: The field order is the CBOR wire format (see 'ToCBOR' below), so
-- reordering fields is a breaking format change.
data TimedServerOutput tx = TimedServerOutput
  { forall tx. TimedServerOutput tx -> Natural
seq :: Natural
  , forall tx. TimedServerOutput tx -> UTCTime
time :: UTCTime
  , forall tx. TimedServerOutput tx -> ServerOutput tx
output :: ServerOutput tx
  }
  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 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 ->
    Natural -> UTCTime -> ServerOutput tx -> TimedServerOutput tx
forall tx.
Natural -> UTCTime -> ServerOutput tx -> TimedServerOutput tx
TimedServerOutput (Natural -> UTCTime -> ServerOutput tx -> TimedServerOutput tx)
-> Parser Natural
-> Parser (UTCTime -> ServerOutput tx -> TimedServerOutput tx)
forall (f :: * -> *) a b. Functor 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 -> ServerOutput tx -> TimedServerOutput tx)
-> Parser UTCTime
-> Parser (ServerOutput tx -> 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" Parser (ServerOutput tx -> TimedServerOutput tx)
-> Parser (ServerOutput tx) -> 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
<*> Value -> Parser (ServerOutput tx)
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v

-- NOTE: Unlike the JSON instance, which merges 'seq' and 'timestamp' into the
-- inner 'ServerOutput' object, the CBOR encoding is a plain tagged envelope.
-- The tag makes any server-sent message start with a unique text token, so
-- clients can dispatch on it (see 'ApiMessage').
instance IsChainState tx => ToCBOR (TimedServerOutput tx) where
  toCBOR :: TimedServerOutput tx -> Encoding
toCBOR = TimedServerOutput tx -> Encoding
forall a. (Generic a, GToCBOR (Rep a)) => a -> Encoding
genericToCBOR

instance IsChainState tx => FromCBOR (TimedServerOutput tx) where
  fromCBOR :: forall s. Decoder s (TimedServerOutput tx)
fromCBOR = Decoder s (TimedServerOutput tx)
forall a s. (Generic a, GFromCBOR (Rep a)) => Decoder s a
genericFromCBOR

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}
  | -- | A deposit (commit) is in flight: the decommit cannot be recorded until it
    -- finalises or is recovered. Clients may need to recover the deposit before
    -- another decommit is possible ('currentDepositTxId' clears on 'CommitFinalized'
    -- and 'DepositRecovered').
    DepositInFlight {forall tx. DecommitInvalidReason tx -> TxIdType tx
depositTxId :: TxIdType tx, forall tx. DecommitInvalidReason tx -> UTxOType tx
commitUTxO :: UTxOType 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 IsTx tx => ToCBOR (DecommitInvalidReason tx) where
  toCBOR :: DecommitInvalidReason tx -> Encoding
toCBOR = DecommitInvalidReason tx -> Encoding
forall a. (Generic a, GToCBOR (Rep a)) => a -> Encoding
genericToCBOR

instance IsTx tx => FromCBOR (DecommitInvalidReason tx) where
  fromCBOR :: forall s. Decoder s (DecommitInvalidReason tx)
fromCBOR = Decoder s (DecommitInvalidReason tx)
forall a s. (Generic a, GFromCBOR (Rep a)) => Decoder s a
genericFromCBOR

-- | Individual messages as produced by the 'Hydra.HeadLogic' in
-- the 'ClientEffect'.
data ClientMessage tx
  = CommandFailed {forall tx. ClientMessage tx -> ClientInput tx
clientInput :: ClientInput tx, forall tx. ClientMessage tx -> HeadState tx
state :: HeadState tx}
  | PostTxOnChainFailed {forall tx. ClientMessage tx -> PostChainTx tx
postChainTx :: PostChainTx tx, forall tx. ClientMessage tx -> PostTxError tx
postTxError :: PostTxError tx}
  | RejectedInputBecauseUnsynced {clientInput :: ClientInput tx, forall tx. ClientMessage tx -> NominalDiffTime
drift :: NominalDiffTime}
  | SideLoadSnapshotRejected {clientInput :: ClientInput tx, forall tx. ClientMessage tx -> SideLoadRequirementFailure tx
requirementFailure :: SideLoadRequirementFailure tx}
  deriving stock (ClientMessage tx -> ClientMessage tx -> Bool
(ClientMessage tx -> ClientMessage tx -> Bool)
-> (ClientMessage tx -> ClientMessage tx -> Bool)
-> Eq (ClientMessage tx)
forall tx.
IsChainState tx =>
ClientMessage tx -> ClientMessage tx -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall tx.
IsChainState tx =>
ClientMessage tx -> ClientMessage tx -> Bool
== :: ClientMessage tx -> ClientMessage tx -> Bool
$c/= :: forall tx.
IsChainState tx =>
ClientMessage tx -> ClientMessage tx -> Bool
/= :: ClientMessage tx -> ClientMessage tx -> Bool
Eq, Int -> ClientMessage tx -> ShowS
[ClientMessage tx] -> ShowS
ClientMessage tx -> String
(Int -> ClientMessage tx -> ShowS)
-> (ClientMessage tx -> String)
-> ([ClientMessage tx] -> ShowS)
-> Show (ClientMessage tx)
forall tx. IsChainState tx => Int -> ClientMessage tx -> ShowS
forall tx. IsChainState tx => [ClientMessage tx] -> ShowS
forall tx. IsChainState tx => ClientMessage tx -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall tx. IsChainState tx => Int -> ClientMessage tx -> ShowS
showsPrec :: Int -> ClientMessage tx -> ShowS
$cshow :: forall tx. IsChainState tx => ClientMessage tx -> String
show :: ClientMessage tx -> String
$cshowList :: forall tx. IsChainState tx => [ClientMessage tx] -> ShowS
showList :: [ClientMessage tx] -> ShowS
Show, (forall x. ClientMessage tx -> Rep (ClientMessage tx) x)
-> (forall x. Rep (ClientMessage tx) x -> ClientMessage tx)
-> Generic (ClientMessage tx)
forall x. Rep (ClientMessage tx) x -> ClientMessage tx
forall x. ClientMessage tx -> Rep (ClientMessage tx) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall tx x. Rep (ClientMessage tx) x -> ClientMessage tx
forall tx x. ClientMessage tx -> Rep (ClientMessage tx) x
$cfrom :: forall tx x. ClientMessage tx -> Rep (ClientMessage tx) x
from :: forall x. ClientMessage tx -> Rep (ClientMessage tx) x
$cto :: forall tx x. Rep (ClientMessage tx) x -> ClientMessage tx
to :: forall x. Rep (ClientMessage tx) x -> ClientMessage tx
Generic)

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

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

instance IsChainState tx => ToCBOR (ClientMessage tx) where
  toCBOR :: ClientMessage tx -> Encoding
toCBOR = ClientMessage tx -> Encoding
forall a. (Generic a, GToCBOR (Rep a)) => a -> Encoding
genericToCBOR

instance IsChainState tx => FromCBOR (ClientMessage tx) where
  fromCBOR :: forall s. Decoder s (ClientMessage tx)
fromCBOR = Decoder s Text
forall s. Decoder s Text
forall a s. FromCBOR a => Decoder s a
fromCBOR Decoder s Text
-> (Text -> Decoder s (ClientMessage tx))
-> Decoder s (ClientMessage tx)
forall a b. Decoder s a -> (a -> Decoder s b) -> Decoder s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Decoder s (ClientMessage tx)
forall tx s.
IsChainState tx =>
Text -> Decoder s (ClientMessage tx)
decodeClientMessageBody

-- | Decode a 'ClientMessage' given its already-decoded constructor tag (used
-- for tag-based dispatch in 'ApiMessage').
decodeClientMessageBody :: IsChainState tx => Text -> Decoder s (ClientMessage tx)
decodeClientMessageBody :: forall tx s.
IsChainState tx =>
Text -> Decoder s (ClientMessage tx)
decodeClientMessageBody = \case
  Text
"CommandFailed" -> ClientInput tx -> HeadState tx -> ClientMessage tx
forall tx. ClientInput tx -> HeadState tx -> ClientMessage tx
CommandFailed (ClientInput tx -> HeadState tx -> ClientMessage tx)
-> Decoder s (ClientInput tx)
-> Decoder s (HeadState tx -> ClientMessage tx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s (ClientInput tx)
forall s. Decoder s (ClientInput tx)
forall a s. FromCBOR a => Decoder s a
fromCBOR Decoder s (HeadState tx -> ClientMessage tx)
-> Decoder s (HeadState tx) -> Decoder s (ClientMessage tx)
forall a b. Decoder s (a -> b) -> Decoder s a -> Decoder s b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Decoder s (HeadState tx)
forall s. Decoder s (HeadState tx)
forall a s. FromCBOR a => Decoder s a
fromCBOR
  Text
"PostTxOnChainFailed" -> PostChainTx tx -> PostTxError tx -> ClientMessage tx
forall tx. PostChainTx tx -> PostTxError tx -> ClientMessage tx
PostTxOnChainFailed (PostChainTx tx -> PostTxError tx -> ClientMessage tx)
-> Decoder s (PostChainTx tx)
-> Decoder s (PostTxError tx -> ClientMessage tx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s (PostChainTx tx)
forall s. Decoder s (PostChainTx tx)
forall a s. FromCBOR a => Decoder s a
fromCBOR Decoder s (PostTxError tx -> ClientMessage tx)
-> Decoder s (PostTxError tx) -> Decoder s (ClientMessage tx)
forall a b. Decoder s (a -> b) -> Decoder s a -> Decoder s b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Decoder s (PostTxError tx)
forall s. Decoder s (PostTxError tx)
forall a s. FromCBOR a => Decoder s a
fromCBOR
  Text
"RejectedInputBecauseUnsynced" -> ClientInput tx -> NominalDiffTime -> ClientMessage tx
forall tx. ClientInput tx -> NominalDiffTime -> ClientMessage tx
RejectedInputBecauseUnsynced (ClientInput tx -> NominalDiffTime -> ClientMessage tx)
-> Decoder s (ClientInput tx)
-> Decoder s (NominalDiffTime -> ClientMessage tx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s (ClientInput tx)
forall s. Decoder s (ClientInput tx)
forall a s. FromCBOR a => Decoder s a
fromCBOR Decoder s (NominalDiffTime -> ClientMessage tx)
-> Decoder s NominalDiffTime -> Decoder s (ClientMessage tx)
forall a b. Decoder s (a -> b) -> Decoder s a -> Decoder s b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Decoder s NominalDiffTime
forall s. Decoder s NominalDiffTime
forall a s. FromCBOR a => Decoder s a
fromCBOR
  Text
"SideLoadSnapshotRejected" -> ClientInput tx -> SideLoadRequirementFailure tx -> ClientMessage tx
forall tx.
ClientInput tx -> SideLoadRequirementFailure tx -> ClientMessage tx
SideLoadSnapshotRejected (ClientInput tx
 -> SideLoadRequirementFailure tx -> ClientMessage tx)
-> Decoder s (ClientInput tx)
-> Decoder s (SideLoadRequirementFailure tx -> ClientMessage tx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s (ClientInput tx)
forall s. Decoder s (ClientInput tx)
forall a s. FromCBOR a => Decoder s a
fromCBOR Decoder s (SideLoadRequirementFailure tx -> ClientMessage tx)
-> Decoder s (SideLoadRequirementFailure tx)
-> Decoder s (ClientMessage tx)
forall a b. Decoder s (a -> b) -> Decoder s a -> Decoder s b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Decoder s (SideLoadRequirementFailure tx)
forall s. Decoder s (SideLoadRequirementFailure tx)
forall a s. FromCBOR a => Decoder s a
fromCBOR
  Text
tag -> String -> Decoder s (ClientMessage tx)
forall a. String -> Decoder s a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Decoder s (ClientMessage tx))
-> String -> Decoder s (ClientMessage tx)
forall a b. (a -> b) -> a -> b
$ Text -> String
forall b a. (Show a, IsString b) => a -> b
show Text
tag String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" is not a proper CBOR-encoded ClientMessage"

-- | 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.
data Greetings tx = Greetings
  { forall tx. Greetings tx -> Party
me :: Party
  , forall tx. Greetings tx -> HeadStatus
headStatus :: HeadStatus
  , forall tx. Greetings tx -> Maybe HeadId
hydraHeadId :: Maybe HeadId
  , forall tx. Greetings tx -> Maybe (UTxOType tx)
snapshotUtxo :: Maybe (UTxOType tx)
  , forall tx. Greetings tx -> String
hydraNodeVersion :: String
  , forall tx. Greetings tx -> Environment
env :: Environment
  , forall tx. Greetings tx -> NetworkInfo
networkInfo :: NetworkInfo
  , forall tx. Greetings tx -> SyncedStatus
chainSyncedStatus :: SyncedStatus
  , forall tx. Greetings tx -> ChainSlot
currentSlot :: ChainSlot
  }
  deriving stock ((forall x. Greetings tx -> Rep (Greetings tx) x)
-> (forall x. Rep (Greetings tx) x -> Greetings tx)
-> Generic (Greetings tx)
forall x. Rep (Greetings tx) x -> Greetings tx
forall x. Greetings tx -> Rep (Greetings tx) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall tx x. Rep (Greetings tx) x -> Greetings tx
forall tx x. Greetings tx -> Rep (Greetings tx) x
$cfrom :: forall tx x. Greetings tx -> Rep (Greetings tx) x
from :: forall x. Greetings tx -> Rep (Greetings tx) x
$cto :: forall tx x. Rep (Greetings tx) x -> Greetings tx
to :: forall x. Rep (Greetings tx) x -> Greetings tx
Generic)

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

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

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

instance IsChainState tx => ToCBOR (Greetings tx) where
  toCBOR :: Greetings tx -> Encoding
toCBOR Greetings{Party
$sel:me:Greetings :: forall tx. Greetings tx -> Party
me :: Party
me, HeadStatus
$sel:headStatus:Greetings :: forall tx. Greetings tx -> HeadStatus
headStatus :: HeadStatus
headStatus, Maybe HeadId
$sel:hydraHeadId:Greetings :: forall tx. Greetings tx -> Maybe HeadId
hydraHeadId :: Maybe HeadId
hydraHeadId, Maybe (UTxOType tx)
$sel:snapshotUtxo:Greetings :: forall tx. Greetings tx -> Maybe (UTxOType tx)
snapshotUtxo :: Maybe (UTxOType tx)
snapshotUtxo, String
$sel:hydraNodeVersion:Greetings :: forall tx. Greetings tx -> String
hydraNodeVersion :: String
hydraNodeVersion, Environment
$sel:env:Greetings :: forall tx. Greetings tx -> Environment
env :: Environment
env, NetworkInfo
$sel:networkInfo:Greetings :: forall tx. Greetings tx -> NetworkInfo
networkInfo :: NetworkInfo
networkInfo, SyncedStatus
$sel:chainSyncedStatus:Greetings :: forall tx. Greetings tx -> SyncedStatus
chainSyncedStatus :: SyncedStatus
chainSyncedStatus, ChainSlot
$sel:currentSlot:Greetings :: forall tx. Greetings tx -> ChainSlot
currentSlot :: ChainSlot
currentSlot} =
    Text -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (Text
"Greetings" :: Text)
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Party -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR Party
me
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> HeadStatus -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR HeadStatus
headStatus
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Maybe HeadId -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR Maybe HeadId
hydraHeadId
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Maybe (UTxOType tx) -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR Maybe (UTxOType tx)
snapshotUtxo
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Text -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (String -> Text
forall a. ToText a => a -> Text
toText String
hydraNodeVersion)
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Environment -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR Environment
env
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> NetworkInfo -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR NetworkInfo
networkInfo
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> SyncedStatus -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR SyncedStatus
chainSyncedStatus
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> ChainSlot -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR ChainSlot
currentSlot

instance IsChainState tx => FromCBOR (Greetings tx) where
  fromCBOR :: forall s. Decoder s (Greetings tx)
fromCBOR =
    Decoder s Text
forall s. Decoder s Text
forall a s. FromCBOR a => Decoder s a
fromCBOR Decoder s Text
-> (Text -> Decoder s (Greetings tx)) -> Decoder s (Greetings tx)
forall a b. Decoder s a -> (a -> Decoder s b) -> Decoder s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      (Text
"Greetings" :: Text) -> Decoder s (Greetings tx)
forall tx s. IsChainState tx => Decoder s (Greetings tx)
decodeGreetingsBody
      Text
tag -> String -> Decoder s (Greetings tx)
forall a. String -> Decoder s a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Decoder s (Greetings tx))
-> String -> Decoder s (Greetings tx)
forall a b. (a -> b) -> a -> b
$ Text -> String
forall b a. (Show a, IsString b) => a -> b
show Text
tag String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" is not a proper CBOR-encoded Greetings"

-- | Decode a 'Greetings' after its @Greetings@ tag has already been consumed
-- (used for tag-based dispatch in 'ApiMessage').
decodeGreetingsBody :: IsChainState tx => Decoder s (Greetings tx)
decodeGreetingsBody :: forall tx s. IsChainState tx => Decoder s (Greetings tx)
decodeGreetingsBody = do
  Party
me <- Decoder s Party
forall s. Decoder s Party
forall a s. FromCBOR a => Decoder s a
fromCBOR
  HeadStatus
headStatus <- Decoder s HeadStatus
forall s. Decoder s HeadStatus
forall a s. FromCBOR a => Decoder s a
fromCBOR
  Maybe HeadId
hydraHeadId <- Decoder s (Maybe HeadId)
forall s. Decoder s (Maybe HeadId)
forall a s. FromCBOR a => Decoder s a
fromCBOR
  Maybe (UTxOType tx)
snapshotUtxo <- Decoder s (Maybe (UTxOType tx))
forall s. Decoder s (Maybe (UTxOType tx))
forall a s. FromCBOR a => Decoder s a
fromCBOR
  String
hydraNodeVersion <- Text -> String
forall a. ToString a => a -> String
toString (Text -> String) -> Decoder s Text -> Decoder s String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a s. FromCBOR a => Decoder s a
fromCBOR @Text
  Environment
env <- Decoder s Environment
forall s. Decoder s Environment
forall a s. FromCBOR a => Decoder s a
fromCBOR
  NetworkInfo
networkInfo <- Decoder s NetworkInfo
forall s. Decoder s NetworkInfo
forall a s. FromCBOR a => Decoder s a
fromCBOR
  SyncedStatus
chainSyncedStatus <- Decoder s SyncedStatus
forall s. Decoder s SyncedStatus
forall a s. FromCBOR a => Decoder s a
fromCBOR
  ChainSlot
currentSlot <- Decoder s ChainSlot
forall s. Decoder s ChainSlot
forall a s. FromCBOR a => Decoder s a
fromCBOR
  Greetings tx -> Decoder s (Greetings tx)
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Greetings{Party
$sel:me:Greetings :: Party
me :: Party
me, HeadStatus
$sel:headStatus:Greetings :: HeadStatus
headStatus :: HeadStatus
headStatus, Maybe HeadId
$sel:hydraHeadId:Greetings :: Maybe HeadId
hydraHeadId :: Maybe HeadId
hydraHeadId, Maybe (UTxOType tx)
$sel:snapshotUtxo:Greetings :: Maybe (UTxOType tx)
snapshotUtxo :: Maybe (UTxOType tx)
snapshotUtxo, String
$sel:hydraNodeVersion:Greetings :: String
hydraNodeVersion :: String
hydraNodeVersion, Environment
$sel:env:Greetings :: Environment
env :: Environment
env, NetworkInfo
$sel:networkInfo:Greetings :: NetworkInfo
networkInfo :: NetworkInfo
networkInfo, SyncedStatus
$sel:chainSyncedStatus:Greetings :: SyncedStatus
chainSyncedStatus :: SyncedStatus
chainSyncedStatus, ChainSlot
$sel:currentSlot:Greetings :: ChainSlot
currentSlot :: ChainSlot
currentSlot}

data InvalidInput = InvalidInput
  { InvalidInput -> String
reason :: String
  , InvalidInput -> Text
input :: Text
  }
  deriving stock (InvalidInput -> InvalidInput -> Bool
(InvalidInput -> InvalidInput -> Bool)
-> (InvalidInput -> InvalidInput -> Bool) -> Eq InvalidInput
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: InvalidInput -> InvalidInput -> Bool
== :: InvalidInput -> InvalidInput -> Bool
$c/= :: InvalidInput -> InvalidInput -> Bool
/= :: InvalidInput -> InvalidInput -> Bool
Eq, Int -> InvalidInput -> ShowS
[InvalidInput] -> ShowS
InvalidInput -> String
(Int -> InvalidInput -> ShowS)
-> (InvalidInput -> String)
-> ([InvalidInput] -> ShowS)
-> Show InvalidInput
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> InvalidInput -> ShowS
showsPrec :: Int -> InvalidInput -> ShowS
$cshow :: InvalidInput -> String
show :: InvalidInput -> String
$cshowList :: [InvalidInput] -> ShowS
showList :: [InvalidInput] -> ShowS
Show, (forall x. InvalidInput -> Rep InvalidInput x)
-> (forall x. Rep InvalidInput x -> InvalidInput)
-> Generic InvalidInput
forall x. Rep InvalidInput x -> InvalidInput
forall x. InvalidInput -> Rep InvalidInput x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. InvalidInput -> Rep InvalidInput x
from :: forall x. InvalidInput -> Rep InvalidInput x
$cto :: forall x. Rep InvalidInput x -> InvalidInput
to :: forall x. Rep InvalidInput x -> InvalidInput
Generic)

deriving anyclass instance ToJSON InvalidInput
deriving anyclass instance FromJSON InvalidInput

instance ToCBOR InvalidInput where
  toCBOR :: InvalidInput -> Encoding
toCBOR InvalidInput{String
$sel:reason:InvalidInput :: InvalidInput -> String
reason :: String
reason, Text
$sel:input:InvalidInput :: InvalidInput -> Text
input :: Text
input} =
    Text -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (Text
"InvalidInput" :: Text) Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Text -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (String -> Text
forall a. ToText a => a -> Text
toText String
reason) Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Text -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR Text
input

instance FromCBOR InvalidInput where
  fromCBOR :: forall s. Decoder s InvalidInput
fromCBOR =
    Decoder s Text
forall s. Decoder s Text
forall a s. FromCBOR a => Decoder s a
fromCBOR Decoder s Text
-> (Text -> Decoder s InvalidInput) -> Decoder s InvalidInput
forall a b. Decoder s a -> (a -> Decoder s b) -> Decoder s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      (Text
"InvalidInput" :: Text) -> Decoder s InvalidInput
forall s. Decoder s InvalidInput
decodeInvalidInputBody
      Text
tag -> String -> Decoder s InvalidInput
forall a. String -> Decoder s a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Decoder s InvalidInput)
-> String -> Decoder s InvalidInput
forall a b. (a -> b) -> a -> b
$ Text -> String
forall b a. (Show a, IsString b) => a -> b
show Text
tag String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" is not a proper CBOR-encoded InvalidInput"

-- | Decode an 'InvalidInput' after its @InvalidInput@ tag has already been
-- consumed (used for tag-based dispatch in 'ApiMessage').
decodeInvalidInputBody :: Decoder s InvalidInput
decodeInvalidInputBody :: forall s. Decoder s InvalidInput
decodeInvalidInputBody = do
  String
reason <- Text -> String
forall a. ToString a => a -> String
toString (Text -> String) -> Decoder s Text -> Decoder s String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a s. FromCBOR a => Decoder s a
fromCBOR @Text
  Text
input <- Decoder s Text
forall s. Decoder s Text
forall a s. FromCBOR a => Decoder s a
fromCBOR
  InvalidInput -> Decoder s InvalidInput
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure InvalidInput{String
$sel:reason:InvalidInput :: String
reason :: String
reason, Text
$sel:input:InvalidInput :: Text
input :: Text
input}

-- | Union of all messages the hydra-node sends to clients. Only used for
-- decoding on the client side; the server encodes and sends the individual
-- types directly (their encodings are the same as the union's).
--
-- In CBOR, every server-sent message starts with a text tag that is unique
-- across the whole API surface, so a single tag read suffices to dispatch.
data ApiMessage tx
  = ApiTimedServerOutput (TimedServerOutput tx)
  | ApiClientMessage (ClientMessage tx)
  | ApiGreetings (Greetings tx)
  | ApiInvalidInput InvalidInput
  deriving stock ((forall x. ApiMessage tx -> Rep (ApiMessage tx) x)
-> (forall x. Rep (ApiMessage tx) x -> ApiMessage tx)
-> Generic (ApiMessage tx)
forall x. Rep (ApiMessage tx) x -> ApiMessage tx
forall x. ApiMessage tx -> Rep (ApiMessage tx) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall tx x. Rep (ApiMessage tx) x -> ApiMessage tx
forall tx x. ApiMessage tx -> Rep (ApiMessage tx) x
$cfrom :: forall tx x. ApiMessage tx -> Rep (ApiMessage tx) x
from :: forall x. ApiMessage tx -> Rep (ApiMessage tx) x
$cto :: forall tx x. Rep (ApiMessage tx) x -> ApiMessage tx
to :: forall x. Rep (ApiMessage tx) x -> ApiMessage tx
Generic)

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

instance IsChainState tx => ToJSON (ApiMessage tx) where
  toJSON :: ApiMessage tx -> Value
toJSON = \case
    ApiTimedServerOutput TimedServerOutput tx
o -> TimedServerOutput tx -> Value
forall a. ToJSON a => a -> Value
toJSON TimedServerOutput tx
o
    ApiClientMessage ClientMessage tx
m -> ClientMessage tx -> Value
forall a. ToJSON a => a -> Value
toJSON ClientMessage tx
m
    ApiGreetings Greetings tx
g -> Greetings tx -> Value
forall a. ToJSON a => a -> Value
toJSON Greetings tx
g
    ApiInvalidInput InvalidInput
i -> InvalidInput -> Value
forall a. ToJSON a => a -> Value
toJSON InvalidInput
i

instance IsChainState tx => FromJSON (ApiMessage tx) where
  parseJSON :: Value -> Parser (ApiMessage tx)
parseJSON Value
v =
    (TimedServerOutput tx -> ApiMessage tx
forall tx. TimedServerOutput tx -> ApiMessage tx
ApiTimedServerOutput (TimedServerOutput tx -> ApiMessage tx)
-> Parser (TimedServerOutput tx) -> Parser (ApiMessage tx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser (TimedServerOutput tx)
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v)
      Parser (ApiMessage tx)
-> Parser (ApiMessage tx) -> Parser (ApiMessage tx)
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (ClientMessage tx -> ApiMessage tx
forall tx. ClientMessage tx -> ApiMessage tx
ApiClientMessage (ClientMessage tx -> ApiMessage tx)
-> Parser (ClientMessage tx) -> Parser (ApiMessage tx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser (ClientMessage tx)
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v)
      Parser (ApiMessage tx)
-> Parser (ApiMessage tx) -> Parser (ApiMessage tx)
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Greetings tx -> ApiMessage tx
forall tx. Greetings tx -> ApiMessage tx
ApiGreetings (Greetings tx -> ApiMessage tx)
-> Parser (Greetings tx) -> Parser (ApiMessage tx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser (Greetings tx)
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v)
      Parser (ApiMessage tx)
-> Parser (ApiMessage tx) -> Parser (ApiMessage tx)
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (InvalidInput -> ApiMessage tx
forall tx. InvalidInput -> ApiMessage tx
ApiInvalidInput (InvalidInput -> ApiMessage tx)
-> Parser InvalidInput -> Parser (ApiMessage tx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser InvalidInput
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v)

instance IsChainState tx => ToCBOR (ApiMessage tx) where
  toCBOR :: ApiMessage tx -> Encoding
toCBOR = \case
    ApiTimedServerOutput TimedServerOutput tx
o -> TimedServerOutput tx -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR TimedServerOutput tx
o
    ApiClientMessage ClientMessage tx
m -> ClientMessage tx -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR ClientMessage tx
m
    ApiGreetings Greetings tx
g -> Greetings tx -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR Greetings tx
g
    ApiInvalidInput InvalidInput
i -> InvalidInput -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR InvalidInput
i

instance IsChainState tx => FromCBOR (ApiMessage tx) where
  fromCBOR :: forall s. Decoder s (ApiMessage tx)
fromCBOR =
    Decoder s Text
forall s. Decoder s Text
forall a s. FromCBOR a => Decoder s a
fromCBOR Decoder s Text
-> (Text -> Decoder s (ApiMessage tx)) -> Decoder s (ApiMessage tx)
forall a b. Decoder s a -> (a -> Decoder s b) -> Decoder s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      (Text
"TimedServerOutput" :: Text) ->
        -- Tag already consumed; decode the fields in declaration order as
        -- 'genericFromCBOR' would.
        TimedServerOutput tx -> ApiMessage tx
forall tx. TimedServerOutput tx -> ApiMessage tx
ApiTimedServerOutput (TimedServerOutput tx -> ApiMessage tx)
-> Decoder s (TimedServerOutput tx) -> Decoder s (ApiMessage tx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Natural -> UTCTime -> ServerOutput tx -> TimedServerOutput tx
forall tx.
Natural -> UTCTime -> ServerOutput tx -> TimedServerOutput tx
TimedServerOutput (Natural -> UTCTime -> ServerOutput tx -> TimedServerOutput tx)
-> Decoder s Natural
-> Decoder s (UTCTime -> ServerOutput tx -> TimedServerOutput tx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Natural
forall s. Decoder s Natural
forall a s. FromCBOR a => Decoder s a
fromCBOR Decoder s (UTCTime -> ServerOutput tx -> TimedServerOutput tx)
-> Decoder s UTCTime
-> Decoder s (ServerOutput tx -> TimedServerOutput tx)
forall a b. Decoder s (a -> b) -> Decoder s a -> Decoder s b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Decoder s UTCTime
forall s. Decoder s UTCTime
forall a s. FromCBOR a => Decoder s a
fromCBOR Decoder s (ServerOutput tx -> TimedServerOutput tx)
-> Decoder s (ServerOutput tx) -> Decoder s (TimedServerOutput tx)
forall a b. Decoder s (a -> b) -> Decoder s a -> Decoder s b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Decoder s (ServerOutput tx)
forall s. Decoder s (ServerOutput tx)
forall a s. FromCBOR a => Decoder s a
fromCBOR)
      Text
"Greetings" -> Greetings tx -> ApiMessage tx
forall tx. Greetings tx -> ApiMessage tx
ApiGreetings (Greetings tx -> ApiMessage tx)
-> Decoder s (Greetings tx) -> Decoder s (ApiMessage tx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s (Greetings tx)
forall tx s. IsChainState tx => Decoder s (Greetings tx)
decodeGreetingsBody
      Text
"InvalidInput" -> InvalidInput -> ApiMessage tx
forall tx. InvalidInput -> ApiMessage tx
ApiInvalidInput (InvalidInput -> ApiMessage tx)
-> Decoder s InvalidInput -> Decoder s (ApiMessage tx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s InvalidInput
forall s. Decoder s InvalidInput
decodeInvalidInputBody
      Text
tag -> ClientMessage tx -> ApiMessage tx
forall tx. ClientMessage tx -> ApiMessage tx
ApiClientMessage (ClientMessage tx -> ApiMessage tx)
-> Decoder s (ClientMessage tx) -> Decoder s (ApiMessage tx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Decoder s (ClientMessage tx)
forall tx s.
IsChainState tx =>
Text -> Decoder s (ClientMessage tx)
decodeClientMessageBody Text
tag

data ServerOutput tx
  = NetworkConnected
  | NetworkDisconnected
  | NetworkVersionMismatch
      { forall tx. ServerOutput tx -> ProtocolVersion
ourVersion :: ProtocolVersion
      , forall tx. ServerOutput tx -> Maybe ProtocolVersion
theirVersion :: Maybe ProtocolVersion
      }
  | NetworkClusterIDMismatch
      { forall tx. ServerOutput tx -> Text
clusterPeers :: Text
      , forall tx. ServerOutput tx -> Text
misconfiguredPeers :: Text
      }
  | PeerConnected {forall tx. ServerOutput tx -> Host
peer :: Host}
  | PeerDisconnected {peer :: Host}
  | HeadIsOpen {forall tx. ServerOutput tx -> HeadId
headId :: HeadId, forall tx. ServerOutput tx -> [Party]
parties :: [Party]}
  | 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}
  | -- | A selective partial fanout step has been observed on chain. Reports the
    -- UTxO distributed in this step and what remains to be fanned out, so the
    -- client can choose the next 'PartialFanout' selection (or fan out the rest).
    -- 'fanoutMode' tells the client whether the node will keep draining on its
    -- own or is waiting for the next selection, so it can render the right
    -- affordance instead of inferring it.
    HeadPartiallyFannedOut {headId :: HeadId, forall tx. ServerOutput tx -> UTxOType tx
distributedUTxO :: UTxOType tx, forall tx. ServerOutput tx -> UTxOType tx
remainingUTxO :: UTxOType tx, forall tx. ServerOutput tx -> FanoutProgressMode
fanoutMode :: FanoutProgressMode}
  | HeadIsFinalized {headId :: HeadId, forall tx. ServerOutput tx -> UTxOType tx
finalizedUTxO :: UTxOType 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 -> TxIdType tx
transactionId :: TxIdType tx}
  | -- | Given transaction was not not applicable to the given UTxO in time and
    -- has been dropped.
    TxInvalid {headId :: HeadId, forall tx. ServerOutput tx -> UTxOType tx
utxo :: UTxOType tx, forall tx. ServerOutput tx -> 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)
      }
  | 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, distributedUTxO :: UTxOType tx}
  | -- TODO: Rename to DepositRecorded following the state events naming. But only
    -- do this when changing the endpoint also to /deposits
    CommitRecorded
      { headId :: HeadId
      , forall tx. ServerOutput tx -> UTxOType tx
utxoToCommit :: UTxOType tx
      , -- XXX: Inconsinstent field name
        forall tx. ServerOutput tx -> TxIdType tx
pendingDeposit :: TxIdType tx
      , forall tx. ServerOutput tx -> UTCTime
deadline :: UTCTime
      }
  | DepositActivated {headId :: HeadId, forall tx. ServerOutput tx -> TxIdType tx
depositTxId :: TxIdType tx, deadline :: UTCTime, forall tx. ServerOutput tx -> UTCTime
chainTime :: UTCTime}
  | DepositExpired {headId :: HeadId, depositTxId :: TxIdType tx, deadline :: UTCTime, chainTime :: UTCTime}
  | -- TODO: Rename to DepositApproved
    CommitApproved {headId :: HeadId, utxoToCommit :: UTxOType tx}
  | -- TODO: Rename to DepositFinalized
    CommitFinalized {headId :: HeadId, depositTxId :: TxIdType tx}
  | -- TODO: Rename to DepositRecovered to be more consistent. But only do this
    -- when changing the endpoint also to /deposits
    CommitRecovered {headId :: HeadId, forall tx. ServerOutput tx -> UTxOType tx
recoveredUTxO :: UTxOType tx, forall tx. ServerOutput tx -> TxIdType tx
recoveredTxId :: TxIdType tx}
  | -- | Snapshot was side-loaded, and the included transactions can be considered final.
    -- The local state has been reset, meaning pending transactions were pruned.
    -- Any signing round has been discarded, and the snapshot leader has changed accordingly.
    SnapshotSideLoaded {headId :: HeadId, snapshotNumber :: SnapshotNumber}
  | EventLogRotated {forall tx. ServerOutput tx -> NodeState tx
checkpoint :: NodeState tx}
  | NodeUnsynced {forall tx. ServerOutput tx -> ChainSlot
chainSlot :: ChainSlot, chainTime :: UTCTime, forall tx. ServerOutput tx -> NominalDiffTime
drift :: NominalDiffTime}
  | NodeSynced {chainSlot :: ChainSlot, chainTime :: UTCTime, drift :: NominalDiffTime}
  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)
deriving anyclass instance IsChainState tx => FromJSON (ServerOutput tx)
deriving anyclass instance IsChainState tx => ToJSON (ServerOutput tx)

instance IsChainState tx => ToCBOR (ServerOutput tx) where
  toCBOR :: ServerOutput tx -> Encoding
toCBOR = ServerOutput tx -> Encoding
forall a. (Generic a, GToCBOR (Rep a)) => a -> Encoding
genericToCBOR

instance IsChainState tx => FromCBOR (ServerOutput tx) where
  fromCBOR :: forall s. Decoder s (ServerOutput tx)
fromCBOR = Decoder s (ServerOutput tx)
forall a s. (Generic a, GFromCBOR (Rep a)) => Decoder s a
genericFromCBOR

-- | 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)

-- | Whether or not to filter transaction server outputs by given address.
data WithAddressedTx = WithAddressedTx Text | WithoutAddressedTx
  deriving stock (WithAddressedTx -> WithAddressedTx -> Bool
(WithAddressedTx -> WithAddressedTx -> Bool)
-> (WithAddressedTx -> WithAddressedTx -> Bool)
-> Eq WithAddressedTx
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: WithAddressedTx -> WithAddressedTx -> Bool
== :: WithAddressedTx -> WithAddressedTx -> Bool
$c/= :: WithAddressedTx -> WithAddressedTx -> Bool
/= :: WithAddressedTx -> WithAddressedTx -> Bool
Eq, Int -> WithAddressedTx -> ShowS
[WithAddressedTx] -> ShowS
WithAddressedTx -> String
(Int -> WithAddressedTx -> ShowS)
-> (WithAddressedTx -> String)
-> ([WithAddressedTx] -> ShowS)
-> Show WithAddressedTx
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> WithAddressedTx -> ShowS
showsPrec :: Int -> WithAddressedTx -> ShowS
$cshow :: WithAddressedTx -> String
show :: WithAddressedTx -> String
$cshowList :: [WithAddressedTx] -> ShowS
showList :: [WithAddressedTx] -> ShowS
Show)

data ServerOutputConfig = ServerOutputConfig
  { ServerOutputConfig -> WithUTxO
utxoInSnapshot :: WithUTxO
  , ServerOutputConfig -> WithAddressedTx
addressInTx :: WithAddressedTx
  , ServerOutputConfig -> ApiEncoding
encoding :: ApiEncoding
  }
  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
config TimedServerOutput tx
response =
  case TimedServerOutput tx -> ServerOutput tx
forall tx. TimedServerOutput tx -> ServerOutput tx
output TimedServerOutput tx
response of
    HeadIsOpen{} -> ByteString
encodedResponse
    HeadIsClosed{} -> ByteString
encodedResponse
    HeadIsContested{} -> ByteString
encodedResponse
    ReadyToFanout{} -> ByteString
encodedResponse
    HeadPartiallyFannedOut{} -> ByteString
encodedResponse
    HeadIsFinalized{} -> ByteString
encodedResponse
    TxValid{} -> ByteString
encodedResponse
    TxInvalid{} -> ByteString
encodedResponse
    SnapshotConfirmed{} ->
      case ServerOutputConfig -> WithUTxO
utxoInSnapshot ServerOutputConfig
config of
        WithUTxO
WithUTxO -> ByteString
encodedResponse
        WithUTxO
WithoutUTxO ->
          -- Filter before serializing: 'handleUtxoInclusionTyped' empties the
          -- utxo so its (potentially huge) 'Value' tree is never built, and
          -- 'removeSnapshotUTxO' drops the residual empty key on the 'Value'
          -- to keep the wire format identical (utxo key absent). This avoids
          -- the old encode -> re-parse -> re-encode byte surgery.
          Value -> ByteString
forall a. ToJSON a => a -> ByteString
encode (Value -> ByteString)
-> (TimedServerOutput tx -> Value)
-> TimedServerOutput tx
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Value
removeSnapshotUTxO (Value -> Value)
-> (TimedServerOutput tx -> Value) -> TimedServerOutput tx -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TimedServerOutput tx -> Value
forall a. ToJSON a => a -> Value
toJSON (TimedServerOutput tx -> ByteString)
-> TimedServerOutput tx -> ByteString
forall a b. (a -> b) -> a -> b
$ ServerOutputConfig -> TimedServerOutput tx -> TimedServerOutput tx
forall tx.
IsTx tx =>
ServerOutputConfig -> TimedServerOutput tx -> TimedServerOutput tx
handleUtxoInclusionTyped ServerOutputConfig
config TimedServerOutput tx
response
    IgnoredHeadInitializing{} -> ByteString
encodedResponse
    DecommitRequested{} -> ByteString
encodedResponse
    DecommitApproved{} -> ByteString
encodedResponse
    DecommitFinalized{} -> ByteString
encodedResponse
    DecommitInvalid{} -> ByteString
encodedResponse
    CommitRecorded{} -> ByteString
encodedResponse
    DepositActivated{} -> ByteString
encodedResponse
    DepositExpired{} -> ByteString
encodedResponse
    CommitApproved{} -> ByteString
encodedResponse
    CommitFinalized{} -> ByteString
encodedResponse
    CommitRecovered{} -> ByteString
encodedResponse
    ServerOutput tx
NetworkConnected -> ByteString
encodedResponse
    ServerOutput tx
NetworkDisconnected -> ByteString
encodedResponse
    NetworkVersionMismatch{} -> ByteString
encodedResponse
    NetworkClusterIDMismatch{} -> ByteString
encodedResponse
    PeerConnected{} -> ByteString
encodedResponse
    PeerDisconnected{} -> ByteString
encodedResponse
    SnapshotSideLoaded{} -> ByteString
encodedResponse
    EventLogRotated{} -> ByteString
encodedResponse
    NodeUnsynced{} -> ByteString
encodedResponse
    NodeSynced{} -> ByteString
encodedResponse
 where
  encodedResponse :: ByteString
encodedResponse = TimedServerOutput tx -> ByteString
forall a. ToJSON a => a -> ByteString
encode TimedServerOutput tx
response

-- | Drop the snapshot @utxo@ key from an already-converted JSON 'Value'.
-- Working on the 'Value' (rather than encoded bytes) avoids a full re-parse
-- and re-encode of the message.
removeSnapshotUTxO :: Value -> Value
removeSnapshotUTxO :: Value -> Value
removeSnapshotUTxO = Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"snapshot" ((Value -> Identity Value) -> Value -> Identity Value)
-> ((Maybe Value -> Identity (Maybe Value))
    -> Value -> Identity Value)
-> (Maybe Value -> Identity (Maybe Value))
-> Value
-> Identity Value
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))
 -> Value -> Identity Value)
-> Maybe Value -> Value -> Value
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Maybe Value
forall a. Maybe a
Nothing

-- | Typed snapshot-utxo filter: with 'WithoutUTxO', the snapshot's utxo is
-- replaced by 'mempty' before encoding. Used directly on CBOR connections
-- (which keep the empty utxo set on the wire) and on the JSON path combined
-- with 'removeSnapshotUTxO' (which then drops the residual empty key).
--
-- NOTE: These are display-only filters and not meant to round-trip back into
-- a valid 'Snapshot'.
handleUtxoInclusionTyped :: IsTx tx => ServerOutputConfig -> TimedServerOutput tx -> TimedServerOutput tx
handleUtxoInclusionTyped :: forall tx.
IsTx tx =>
ServerOutputConfig -> TimedServerOutput tx -> TimedServerOutput tx
handleUtxoInclusionTyped ServerOutputConfig
config TimedServerOutput tx
timed =
  case ServerOutputConfig -> WithUTxO
utxoInSnapshot ServerOutputConfig
config of
    WithUTxO
WithUTxO -> TimedServerOutput tx
timed
    WithUTxO
WithoutUTxO ->
      case TimedServerOutput tx -> ServerOutput tx
forall tx. TimedServerOutput tx -> ServerOutput tx
output TimedServerOutput tx
timed of
        SnapshotConfirmed{HeadId
$sel:headId:NetworkConnected :: forall tx. ServerOutput tx -> HeadId
headId :: HeadId
headId, $sel:snapshot:NetworkConnected :: forall tx. ServerOutput tx -> Snapshot tx
snapshot = Snapshot{$sel:headId:Snapshot :: forall tx. Snapshot tx -> HeadId
headId = HeadId
snapHeadId, SnapshotVersion
version :: SnapshotVersion
$sel:version:Snapshot :: forall tx. Snapshot tx -> SnapshotVersion
version, SnapshotNumber
number :: SnapshotNumber
$sel:number:Snapshot :: forall tx. Snapshot tx -> SnapshotNumber
number, [tx]
confirmed :: [tx]
$sel:confirmed:Snapshot :: forall tx. Snapshot tx -> [tx]
confirmed, Maybe (UTxOType tx)
utxoToCommit :: Maybe (UTxOType tx)
$sel:utxoToCommit:Snapshot :: forall tx. Snapshot tx -> Maybe (UTxOType tx)
utxoToCommit, Maybe (TxIdType tx)
depositTxId :: Maybe (TxIdType tx)
$sel:depositTxId:Snapshot :: forall tx. Snapshot tx -> Maybe (TxIdType tx)
depositTxId, Maybe (UTxOType tx)
utxoToDecommit :: Maybe (UTxOType tx)
$sel:utxoToDecommit:Snapshot :: forall tx. Snapshot tx -> Maybe (UTxOType tx)
utxoToDecommit, HydraAccumulator
accumulator :: HydraAccumulator
$sel:accumulator:Snapshot :: forall tx. Snapshot tx -> HydraAccumulator
accumulator}, MultiSignature (Snapshot tx)
$sel:signatures:NetworkConnected :: forall tx. ServerOutput tx -> MultiSignature (Snapshot tx)
signatures :: MultiSignature (Snapshot tx)
signatures} ->
          TimedServerOutput tx
timed
            { output =
                SnapshotConfirmed
                  { headId
                  , snapshot =
                      Snapshot
                        { headId = snapHeadId
                        , version
                        , number
                        , confirmed
                        , utxo = mempty
                        , utxoToCommit
                        , depositTxId
                        , utxoToDecommit
                        , accumulator
                        }
                  , signatures
                  }
            }
        ServerOutput tx
_ -> TimedServerOutput tx
timed

-- | All possible Hydra states displayed in the API server outputs.
data HeadStatus
  = Idle
  | Open
  | Closed
  | FanoutPossible
  | -- | A closed head whose UTxO is being distributed across multiple selective
    -- partial fanout transactions.
    FanningOut
  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 ToCBOR HeadStatus where
  toCBOR :: HeadStatus -> Encoding
toCBOR = HeadStatus -> Encoding
forall a. (Generic a, GToCBOR (Rep a)) => a -> Encoding
genericToCBOR

instance FromCBOR HeadStatus where
  fromCBOR :: forall s. Decoder s HeadStatus
fromCBOR = Decoder s HeadStatus
forall a s. (Generic a, GFromCBOR (Rep a)) => Decoder s a
genericFromCBOR

-- | Client-facing projection of the node's fanout 'FanoutMode': whether a
-- fanning-out head will continue draining on its own or is waiting for the
-- client to choose the next 'PartialFanout'. Surfacing this lets clients render
-- the correct affordance without inferring it from local actions.
data FanoutProgressMode
  = -- | The node keeps draining automatically (a full 'Fanout', or working
    -- through a user selection). The client should wait, not prompt for input.
    AutoFanningOut
  | -- | The node has drained the current selection and is waiting for the next
    -- 'PartialFanout' from the client.
    AwaitingFanoutSelection
  deriving stock (FanoutProgressMode -> FanoutProgressMode -> Bool
(FanoutProgressMode -> FanoutProgressMode -> Bool)
-> (FanoutProgressMode -> FanoutProgressMode -> Bool)
-> Eq FanoutProgressMode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FanoutProgressMode -> FanoutProgressMode -> Bool
== :: FanoutProgressMode -> FanoutProgressMode -> Bool
$c/= :: FanoutProgressMode -> FanoutProgressMode -> Bool
/= :: FanoutProgressMode -> FanoutProgressMode -> Bool
Eq, Int -> FanoutProgressMode -> ShowS
[FanoutProgressMode] -> ShowS
FanoutProgressMode -> String
(Int -> FanoutProgressMode -> ShowS)
-> (FanoutProgressMode -> String)
-> ([FanoutProgressMode] -> ShowS)
-> Show FanoutProgressMode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FanoutProgressMode -> ShowS
showsPrec :: Int -> FanoutProgressMode -> ShowS
$cshow :: FanoutProgressMode -> String
show :: FanoutProgressMode -> String
$cshowList :: [FanoutProgressMode] -> ShowS
showList :: [FanoutProgressMode] -> ShowS
Show, (forall x. FanoutProgressMode -> Rep FanoutProgressMode x)
-> (forall x. Rep FanoutProgressMode x -> FanoutProgressMode)
-> Generic FanoutProgressMode
forall x. Rep FanoutProgressMode x -> FanoutProgressMode
forall x. FanoutProgressMode -> Rep FanoutProgressMode x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. FanoutProgressMode -> Rep FanoutProgressMode x
from :: forall x. FanoutProgressMode -> Rep FanoutProgressMode x
$cto :: forall x. Rep FanoutProgressMode x -> FanoutProgressMode
to :: forall x. Rep FanoutProgressMode x -> FanoutProgressMode
Generic)
  deriving anyclass ([FanoutProgressMode] -> Value
[FanoutProgressMode] -> Encoding
FanoutProgressMode -> Bool
FanoutProgressMode -> Value
FanoutProgressMode -> Encoding
(FanoutProgressMode -> Value)
-> (FanoutProgressMode -> Encoding)
-> ([FanoutProgressMode] -> Value)
-> ([FanoutProgressMode] -> Encoding)
-> (FanoutProgressMode -> Bool)
-> ToJSON FanoutProgressMode
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: FanoutProgressMode -> Value
toJSON :: FanoutProgressMode -> Value
$ctoEncoding :: FanoutProgressMode -> Encoding
toEncoding :: FanoutProgressMode -> Encoding
$ctoJSONList :: [FanoutProgressMode] -> Value
toJSONList :: [FanoutProgressMode] -> Value
$ctoEncodingList :: [FanoutProgressMode] -> Encoding
toEncodingList :: [FanoutProgressMode] -> Encoding
$comitField :: FanoutProgressMode -> Bool
omitField :: FanoutProgressMode -> Bool
ToJSON, Maybe FanoutProgressMode
Value -> Parser [FanoutProgressMode]
Value -> Parser FanoutProgressMode
(Value -> Parser FanoutProgressMode)
-> (Value -> Parser [FanoutProgressMode])
-> Maybe FanoutProgressMode
-> FromJSON FanoutProgressMode
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser FanoutProgressMode
parseJSON :: Value -> Parser FanoutProgressMode
$cparseJSONList :: Value -> Parser [FanoutProgressMode]
parseJSONList :: Value -> Parser [FanoutProgressMode]
$comittedField :: Maybe FanoutProgressMode
omittedField :: Maybe FanoutProgressMode
FromJSON)

instance ToCBOR FanoutProgressMode where
  toCBOR :: FanoutProgressMode -> Encoding
toCBOR = FanoutProgressMode -> Encoding
forall a. (Generic a, GToCBOR (Rep a)) => a -> Encoding
genericToCBOR

instance FromCBOR FanoutProgressMode where
  fromCBOR :: forall s. Decoder s FanoutProgressMode
fromCBOR = Decoder s FanoutProgressMode
forall a s. (Generic a, GFromCBOR (Rep a)) => Decoder s a
genericFromCBOR

-- | Project the internal 'FanoutMode' to its client-facing 'FanoutProgressMode'.
-- Both auto-drain and mid-selection draining present as 'AutoFanningOut' (the
-- node advances by itself); only an exhausted selection awaits client input.
fanoutProgressMode :: FanoutMode tx -> FanoutProgressMode
fanoutProgressMode :: forall tx. FanoutMode tx -> FanoutProgressMode
fanoutProgressMode = \case
  FanoutMode tx
AutoDrain -> FanoutProgressMode
AutoFanningOut
  DistributingSelection{} -> FanoutProgressMode
AutoFanningOut
  FanoutMode tx
AwaitingSelection -> FanoutProgressMode
AwaitingFanoutSelection

-- | All information needed to distinguish behavior of the commit endpoint.
data CommitInfo
  = CannotCommit
  | IncrementalCommit HeadId

-- | L2 Hydra network status information.
data NetworkInfo = NetworkInfo
  { NetworkInfo -> Bool
networkConnected :: Bool
  , NetworkInfo -> Map Host Bool
peersInfo :: Map Host Bool
  }
  deriving stock (NetworkInfo -> NetworkInfo -> Bool
(NetworkInfo -> NetworkInfo -> Bool)
-> (NetworkInfo -> NetworkInfo -> Bool) -> Eq NetworkInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NetworkInfo -> NetworkInfo -> Bool
== :: NetworkInfo -> NetworkInfo -> Bool
$c/= :: NetworkInfo -> NetworkInfo -> Bool
/= :: NetworkInfo -> NetworkInfo -> Bool
Eq, Int -> NetworkInfo -> ShowS
[NetworkInfo] -> ShowS
NetworkInfo -> String
(Int -> NetworkInfo -> ShowS)
-> (NetworkInfo -> String)
-> ([NetworkInfo] -> ShowS)
-> Show NetworkInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NetworkInfo -> ShowS
showsPrec :: Int -> NetworkInfo -> ShowS
$cshow :: NetworkInfo -> String
show :: NetworkInfo -> String
$cshowList :: [NetworkInfo] -> ShowS
showList :: [NetworkInfo] -> ShowS
Show, (forall x. NetworkInfo -> Rep NetworkInfo x)
-> (forall x. Rep NetworkInfo x -> NetworkInfo)
-> Generic NetworkInfo
forall x. Rep NetworkInfo x -> NetworkInfo
forall x. NetworkInfo -> Rep NetworkInfo x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. NetworkInfo -> Rep NetworkInfo x
from :: forall x. NetworkInfo -> Rep NetworkInfo x
$cto :: forall x. Rep NetworkInfo x -> NetworkInfo
to :: forall x. Rep NetworkInfo x -> NetworkInfo
Generic)
  deriving anyclass ([NetworkInfo] -> Value
[NetworkInfo] -> Encoding
NetworkInfo -> Bool
NetworkInfo -> Value
NetworkInfo -> Encoding
(NetworkInfo -> Value)
-> (NetworkInfo -> Encoding)
-> ([NetworkInfo] -> Value)
-> ([NetworkInfo] -> Encoding)
-> (NetworkInfo -> Bool)
-> ToJSON NetworkInfo
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: NetworkInfo -> Value
toJSON :: NetworkInfo -> Value
$ctoEncoding :: NetworkInfo -> Encoding
toEncoding :: NetworkInfo -> Encoding
$ctoJSONList :: [NetworkInfo] -> Value
toJSONList :: [NetworkInfo] -> Value
$ctoEncodingList :: [NetworkInfo] -> Encoding
toEncodingList :: [NetworkInfo] -> Encoding
$comitField :: NetworkInfo -> Bool
omitField :: NetworkInfo -> Bool
ToJSON, Maybe NetworkInfo
Value -> Parser [NetworkInfo]
Value -> Parser NetworkInfo
(Value -> Parser NetworkInfo)
-> (Value -> Parser [NetworkInfo])
-> Maybe NetworkInfo
-> FromJSON NetworkInfo
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser NetworkInfo
parseJSON :: Value -> Parser NetworkInfo
$cparseJSONList :: Value -> Parser [NetworkInfo]
parseJSONList :: Value -> Parser [NetworkInfo]
$comittedField :: Maybe NetworkInfo
omittedField :: Maybe NetworkInfo
FromJSON)

instance ToCBOR NetworkInfo where
  toCBOR :: NetworkInfo -> Encoding
toCBOR = NetworkInfo -> Encoding
forall a. (Generic a, GToCBOR (Rep a)) => a -> Encoding
genericToCBOR

instance FromCBOR NetworkInfo where
  fromCBOR :: forall s. Decoder s NetworkInfo
fromCBOR = Decoder s NetworkInfo
forall a s. (Generic a, GFromCBOR (Rep a)) => Decoder s a
genericFromCBOR

-- | Get latest confirmed snapshot UTxO from 'HeadState'.
getSnapshotUtxo :: IsTx tx => HeadState tx -> Maybe (UTxOType tx)
getSnapshotUtxo :: forall tx. IsTx tx => HeadState tx -> Maybe (UTxOType tx)
getSnapshotUtxo = \case
  HeadState.Idle{} ->
    Maybe (UTxOType tx)
forall a. Maybe a
Nothing
  HeadState.Open OpenState{CoordinatedHeadState tx
coordinatedHeadState :: CoordinatedHeadState tx
$sel:coordinatedHeadState:OpenState :: forall tx. OpenState tx -> CoordinatedHeadState tx
coordinatedHeadState} ->
    let snapshot :: Snapshot tx
snapshot = ConfirmedSnapshot tx -> Snapshot tx
forall tx. IsTx tx => ConfirmedSnapshot tx -> Snapshot tx
getSnapshot CoordinatedHeadState tx
coordinatedHeadState.confirmedSnapshot
     in 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 UTxOType tx -> UTxOType tx -> UTxOType tx
forall a. Semigroup a => a -> a -> a
<> UTxOType tx -> Maybe (UTxOType tx) -> UTxOType tx
forall a. a -> Maybe a -> a
fromMaybe UTxOType tx
forall a. Monoid a => a
mempty (Snapshot tx -> Maybe (UTxOType tx)
forall tx. Snapshot tx -> Maybe (UTxOType tx)
Tx.utxoToCommit Snapshot tx
snapshot)
  HeadState.Closed ClosedState{ConfirmedSnapshot tx
confirmedSnapshot :: ConfirmedSnapshot tx
$sel:confirmedSnapshot:ClosedState :: forall tx. ClosedState tx -> ConfirmedSnapshot tx
confirmedSnapshot} ->
    let snapshot :: Snapshot tx
snapshot = ConfirmedSnapshot tx -> Snapshot tx
forall tx. IsTx tx => ConfirmedSnapshot tx -> Snapshot tx
getSnapshot ConfirmedSnapshot tx
confirmedSnapshot
     in 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 UTxOType tx -> UTxOType tx -> UTxOType tx
forall a. Semigroup a => a -> a -> a
<> UTxOType tx -> Maybe (UTxOType tx) -> UTxOType tx
forall a. a -> Maybe a -> a
fromMaybe UTxOType tx
forall a. Monoid a => a
mempty (Snapshot tx -> Maybe (UTxOType tx)
forall tx. Snapshot tx -> Maybe (UTxOType tx)
Tx.utxoToCommit Snapshot tx
snapshot)
  HeadState.FanoutProgress PartialFanoutState{ConfirmedSnapshot tx
confirmedSnapshot :: ConfirmedSnapshot tx
$sel:confirmedSnapshot:PartialFanoutState :: forall tx. PartialFanoutState tx -> ConfirmedSnapshot tx
confirmedSnapshot} ->
    let snapshot :: Snapshot tx
snapshot = ConfirmedSnapshot tx -> Snapshot tx
forall tx. IsTx tx => ConfirmedSnapshot tx -> Snapshot tx
getSnapshot ConfirmedSnapshot tx
confirmedSnapshot
     in 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 UTxOType tx -> UTxOType tx -> UTxOType tx
forall a. Semigroup a => a -> a -> a
<> UTxOType tx -> Maybe (UTxOType tx) -> UTxOType tx
forall a. a -> Maybe a -> a
fromMaybe UTxOType tx
forall a. Monoid a => a
mempty (Snapshot tx -> Maybe (UTxOType tx)
forall tx. Snapshot tx -> Maybe (UTxOType tx)
Tx.utxoToCommit Snapshot tx
snapshot)

-- | Get latest seen snapshot from 'HeadState'.
getSeenSnapshot :: IsTx tx => HeadState tx -> HeadState.SeenSnapshot tx
getSeenSnapshot :: forall tx. IsTx tx => HeadState tx -> SeenSnapshot tx
getSeenSnapshot = \case
  HeadState.Idle{} ->
    SeenSnapshot tx
forall tx. SeenSnapshot tx
NoSeenSnapshot
  HeadState.Open OpenState{CoordinatedHeadState tx
$sel:coordinatedHeadState:OpenState :: forall tx. OpenState tx -> CoordinatedHeadState tx
coordinatedHeadState :: CoordinatedHeadState tx
coordinatedHeadState} ->
    CoordinatedHeadState tx
coordinatedHeadState.seenSnapshot
  HeadState.Closed ClosedState{ConfirmedSnapshot tx
$sel:confirmedSnapshot:ClosedState :: forall tx. ClosedState tx -> ConfirmedSnapshot tx
confirmedSnapshot :: ConfirmedSnapshot tx
confirmedSnapshot} ->
    let Snapshot{SnapshotNumber
$sel:number:Snapshot :: forall tx. Snapshot tx -> SnapshotNumber
number :: SnapshotNumber
number} = ConfirmedSnapshot tx -> Snapshot tx
forall tx. IsTx tx => ConfirmedSnapshot tx -> Snapshot tx
getSnapshot ConfirmedSnapshot tx
confirmedSnapshot
     in SnapshotNumber -> SeenSnapshot tx
forall tx. SnapshotNumber -> SeenSnapshot tx
LastSeenSnapshot SnapshotNumber
number
  HeadState.FanoutProgress PartialFanoutState{ConfirmedSnapshot tx
$sel:confirmedSnapshot:PartialFanoutState :: forall tx. PartialFanoutState tx -> ConfirmedSnapshot tx
confirmedSnapshot :: ConfirmedSnapshot tx
confirmedSnapshot} ->
    let Snapshot{SnapshotNumber
$sel:number:Snapshot :: forall tx. Snapshot tx -> SnapshotNumber
number :: SnapshotNumber
number} = ConfirmedSnapshot tx -> Snapshot tx
forall tx. IsTx tx => ConfirmedSnapshot tx -> Snapshot tx
getSnapshot ConfirmedSnapshot tx
confirmedSnapshot
     in SnapshotNumber -> SeenSnapshot tx
forall tx. SnapshotNumber -> SeenSnapshot tx
LastSeenSnapshot SnapshotNumber
number

-- | Get latest confirmed snapshot from 'HeadState'.
getConfirmedSnapshot :: HeadState tx -> Maybe (HeadState.ConfirmedSnapshot tx)
getConfirmedSnapshot :: forall tx. HeadState tx -> Maybe (ConfirmedSnapshot tx)
getConfirmedSnapshot = \case
  HeadState.Idle{} ->
    Maybe (ConfirmedSnapshot tx)
forall a. Maybe a
Nothing
  HeadState.Open OpenState{CoordinatedHeadState tx
$sel:coordinatedHeadState:OpenState :: forall tx. OpenState tx -> CoordinatedHeadState tx
coordinatedHeadState :: CoordinatedHeadState tx
coordinatedHeadState} ->
    ConfirmedSnapshot tx -> Maybe (ConfirmedSnapshot tx)
forall a. a -> Maybe a
Just CoordinatedHeadState tx
coordinatedHeadState.confirmedSnapshot
  HeadState.Closed ClosedState{ConfirmedSnapshot tx
$sel:confirmedSnapshot:ClosedState :: forall tx. ClosedState tx -> ConfirmedSnapshot tx
confirmedSnapshot :: ConfirmedSnapshot tx
confirmedSnapshot} ->
    ConfirmedSnapshot tx -> Maybe (ConfirmedSnapshot tx)
forall a. a -> Maybe a
Just ConfirmedSnapshot tx
confirmedSnapshot
  HeadState.FanoutProgress PartialFanoutState{ConfirmedSnapshot tx
$sel:confirmedSnapshot:PartialFanoutState :: forall tx. PartialFanoutState tx -> ConfirmedSnapshot tx
confirmedSnapshot :: ConfirmedSnapshot tx
confirmedSnapshot} ->
    ConfirmedSnapshot tx -> Maybe (ConfirmedSnapshot tx)
forall a. a -> Maybe a
Just ConfirmedSnapshot tx
confirmedSnapshot