{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-ambiguous-fields #-}

module Hydra.HeadLogic.State where

import Hydra.Prelude

import Data.Aeson (object, withObject, (.:), (.=))
import Data.Map.Strict qualified as Map
import Hydra.Chain.ChainState (IsChainState (..))
import Hydra.Tx (
  HeadId,
  HeadParameters,
  HeadSeed,
  IsTx (..),
  Party,
 )
import Hydra.Tx.Crypto (Signature, getSignableRepresentation)
import Hydra.Tx.Snapshot (
  ConfirmedSnapshot,
  Snapshot (..),
  SnapshotNumber,
  SnapshotVersion,
 )

-- | The main state of the Hydra protocol state machine. It holds both, the
-- overall protocol state, but also the off-chain 'CoordinatedHeadState'.
--
-- Each of the sub-types (OpenState, etc.) contain a black-box
-- 'chainState' corresponding to the 'ChainEvent' that has been observed leading
-- to the state.
--
-- Note that rollbacks are currently not fully handled in the head logic and
-- only this internal chain state gets replaced with the "rolled back to"
-- version.
--
-- TODO: chainState would actually not be needed in the HeadState anymore as we
-- do not persist the 'HeadState' and not access it in the HeadLogic either.
data HeadState tx
  = Idle (IdleState tx)
  | Open (OpenState tx)
  | Closed (ClosedState tx)
  | -- | A closed head whose UTxO is being fanned out across multiple
    -- transactions (on-chain in the @FanoutProgress@ state). Reached from
    -- 'Closed' once the first partial fanout is observed.
    FanoutProgress (PartialFanoutState tx)
  deriving stock ((forall x. HeadState tx -> Rep (HeadState tx) x)
-> (forall x. Rep (HeadState tx) x -> HeadState tx)
-> Generic (HeadState tx)
forall x. Rep (HeadState tx) x -> HeadState tx
forall x. HeadState tx -> Rep (HeadState tx) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall tx x. Rep (HeadState tx) x -> HeadState tx
forall tx x. HeadState tx -> Rep (HeadState tx) x
$cfrom :: forall tx x. HeadState tx -> Rep (HeadState tx) x
from :: forall x. HeadState tx -> Rep (HeadState tx) x
$cto :: forall tx x. Rep (HeadState tx) x -> HeadState tx
to :: forall x. Rep (HeadState tx) x -> HeadState tx
Generic)

deriving stock instance (IsTx tx, Eq (ChainStateType tx)) => Eq (HeadState tx)
deriving stock instance (IsTx tx, Show (ChainStateType tx)) => Show (HeadState tx)
deriving anyclass instance (IsTx tx, ToJSON (ChainStateType tx)) => ToJSON (HeadState tx)
deriving anyclass instance (IsTx tx, FromJSON (ChainStateType tx)) => FromJSON (HeadState tx)

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

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

-- | Update the chain state in any 'HeadState'.
setChainState :: ChainStateType tx -> HeadState tx -> HeadState tx
setChainState :: forall tx. ChainStateType tx -> HeadState tx -> HeadState tx
setChainState ChainStateType tx
chainState = \case
  Idle IdleState tx
st -> IdleState tx -> HeadState tx
forall tx. IdleState tx -> HeadState tx
Idle IdleState tx
st{chainState}
  Open OpenState tx
st -> OpenState tx -> HeadState tx
forall tx. OpenState tx -> HeadState tx
Open OpenState tx
st{chainState}
  Closed ClosedState tx
st -> ClosedState tx -> HeadState tx
forall tx. ClosedState tx -> HeadState tx
Closed ClosedState tx
st{chainState}
  FanoutProgress PartialFanoutState tx
st -> PartialFanoutState tx -> HeadState tx
forall tx. PartialFanoutState tx -> HeadState tx
FanoutProgress PartialFanoutState tx
st{chainState}

-- | Get the chain state in any 'HeadState'.
getChainState :: HeadState tx -> ChainStateType tx
getChainState :: forall tx. HeadState tx -> ChainStateType tx
getChainState = \case
  Idle IdleState{ChainStateType tx
chainState :: forall tx. IdleState tx -> ChainStateType tx
chainState :: ChainStateType tx
chainState} -> ChainStateType tx
chainState
  Open OpenState{ChainStateType tx
chainState :: forall tx. OpenState tx -> ChainStateType tx
chainState :: ChainStateType tx
chainState} -> ChainStateType tx
chainState
  Closed ClosedState{ChainStateType tx
chainState :: forall tx. ClosedState tx -> ChainStateType tx
chainState :: ChainStateType tx
chainState} -> ChainStateType tx
chainState
  FanoutProgress PartialFanoutState{ChainStateType tx
chainState :: forall tx. PartialFanoutState tx -> ChainStateType tx
chainState :: ChainStateType tx
chainState} -> ChainStateType tx
chainState

-- | Get the head parameters in any 'HeadState'.
getHeadParameters :: HeadState tx -> Maybe HeadParameters
getHeadParameters :: forall tx. HeadState tx -> Maybe HeadParameters
getHeadParameters = \case
  Idle IdleState tx
_ -> Maybe HeadParameters
forall a. Maybe a
Nothing
  Open OpenState{HeadParameters
parameters :: HeadParameters
$sel:parameters:OpenState :: forall tx. OpenState tx -> HeadParameters
parameters} -> HeadParameters -> Maybe HeadParameters
forall a. a -> Maybe a
Just HeadParameters
parameters
  Closed ClosedState{HeadParameters
parameters :: HeadParameters
$sel:parameters:ClosedState :: forall tx. ClosedState tx -> HeadParameters
parameters} -> HeadParameters -> Maybe HeadParameters
forall a. a -> Maybe a
Just HeadParameters
parameters
  FanoutProgress PartialFanoutState{HeadParameters
parameters :: HeadParameters
$sel:parameters:PartialFanoutState :: forall tx. PartialFanoutState tx -> HeadParameters
parameters} -> HeadParameters -> Maybe HeadParameters
forall a. a -> Maybe a
Just HeadParameters
parameters

-- | Get the head parameters in any 'HeadState'.
getOpenStateConfirmedSnapshot :: HeadState tx -> Maybe (ConfirmedSnapshot tx)
getOpenStateConfirmedSnapshot :: forall tx. HeadState tx -> Maybe (ConfirmedSnapshot tx)
getOpenStateConfirmedSnapshot = \case
  Idle IdleState tx
_ -> Maybe (ConfirmedSnapshot tx)
forall a. Maybe a
Nothing
  Open OpenState{$sel:coordinatedHeadState:OpenState :: forall tx. OpenState tx -> CoordinatedHeadState tx
coordinatedHeadState = CoordinatedHeadState{ConfirmedSnapshot tx
confirmedSnapshot :: ConfirmedSnapshot tx
$sel:confirmedSnapshot:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> ConfirmedSnapshot tx
confirmedSnapshot}} -> ConfirmedSnapshot tx -> Maybe (ConfirmedSnapshot tx)
forall a. a -> Maybe a
Just ConfirmedSnapshot tx
confirmedSnapshot
  Closed ClosedState{} -> Maybe (ConfirmedSnapshot tx)
forall a. Maybe a
Nothing
  FanoutProgress PartialFanoutState{} -> Maybe (ConfirmedSnapshot tx)
forall a. Maybe a
Nothing

-- ** Idle

-- | An 'Idle' head only having a chain state with things seen on chain so far.
newtype IdleState tx = IdleState {forall tx. IdleState tx -> ChainStateType tx
chainState :: ChainStateType tx}
  deriving stock ((forall x. IdleState tx -> Rep (IdleState tx) x)
-> (forall x. Rep (IdleState tx) x -> IdleState tx)
-> Generic (IdleState tx)
forall x. Rep (IdleState tx) x -> IdleState tx
forall x. IdleState tx -> Rep (IdleState tx) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall tx x. Rep (IdleState tx) x -> IdleState tx
forall tx x. IdleState tx -> Rep (IdleState tx) x
$cfrom :: forall tx x. IdleState tx -> Rep (IdleState tx) x
from :: forall x. IdleState tx -> Rep (IdleState tx) x
$cto :: forall tx x. Rep (IdleState tx) x -> IdleState tx
to :: forall x. Rep (IdleState tx) x -> IdleState tx
Generic)

deriving stock instance Eq (ChainStateType tx) => Eq (IdleState tx)
deriving stock instance Show (ChainStateType tx) => Show (IdleState tx)
deriving anyclass instance ToJSON (ChainStateType tx) => ToJSON (IdleState tx)
deriving anyclass instance FromJSON (ChainStateType tx) => FromJSON (IdleState tx)

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

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

-- ** Open

-- | An 'Open' head with a 'CoordinatedHeadState' tracking off-chain
-- transactions.
data OpenState tx = OpenState
  { forall tx. OpenState tx -> HeadParameters
parameters :: HeadParameters
  , forall tx. OpenState tx -> CoordinatedHeadState tx
coordinatedHeadState :: CoordinatedHeadState tx
  , forall tx. OpenState tx -> ChainStateType tx
chainState :: ChainStateType tx
  , forall tx. OpenState tx -> HeadId
headId :: HeadId
  , forall tx. OpenState tx -> HeadSeed
headSeed :: HeadSeed
  }
  deriving stock ((forall x. OpenState tx -> Rep (OpenState tx) x)
-> (forall x. Rep (OpenState tx) x -> OpenState tx)
-> Generic (OpenState tx)
forall x. Rep (OpenState tx) x -> OpenState tx
forall x. OpenState tx -> Rep (OpenState tx) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall tx x. Rep (OpenState tx) x -> OpenState tx
forall tx x. OpenState tx -> Rep (OpenState tx) x
$cfrom :: forall tx x. OpenState tx -> Rep (OpenState tx) x
from :: forall x. OpenState tx -> Rep (OpenState tx) x
$cto :: forall tx x. Rep (OpenState tx) x -> OpenState tx
to :: forall x. Rep (OpenState tx) x -> OpenState tx
Generic)

deriving stock instance (IsTx tx, Eq (ChainStateType tx)) => Eq (OpenState tx)
deriving stock instance (IsTx tx, Show (ChainStateType tx)) => Show (OpenState tx)
deriving anyclass instance (IsTx tx, ToJSON (ChainStateType tx)) => ToJSON (OpenState tx)
deriving anyclass instance (IsTx tx, FromJSON (ChainStateType tx)) => FromJSON (OpenState tx)

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

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

-- | Off-chain state of the Coordinated Head protocol.
data CoordinatedHeadState tx = CoordinatedHeadState
  { forall tx. CoordinatedHeadState tx -> UTxOType tx
localUTxO :: UTxOType tx
  -- ^ The latest UTxO resulting from applying 'localTxs' to
  -- 'confirmedSnapshot'. Spec: L̂
  , forall tx. CoordinatedHeadState tx -> Seq tx
localTxs :: Seq tx
  -- ^ Sequence of transactions applied locally and pending inclusion in a
  -- snapshot. Ordering is important as transactions are added in order of
  -- application. Spec: T̂
  , forall tx. CoordinatedHeadState tx -> Map (TxIdType tx) tx
allTxs :: !(Map.Map (TxIdType tx) tx)
  -- ^ Map containing all the transactions ever seen by this node and not yet
  -- included in a snapshot. Spec: Tall
  , forall tx. CoordinatedHeadState tx -> ConfirmedSnapshot tx
confirmedSnapshot :: ConfirmedSnapshot tx
  -- ^ The latest confirmed snapshot. Spec: S̅
  , forall tx. CoordinatedHeadState tx -> SeenSnapshot tx
seenSnapshot :: SeenSnapshot tx
  -- ^ Last seen snapshot and signatures accumulator. Spec: Û, ŝ and Σ̂
  , forall tx. CoordinatedHeadState tx -> Maybe (TxIdType tx)
currentDepositTxId :: Maybe (TxIdType tx)
  -- ^ Current/next deposit to incrementally commit. Spec: Uα
  -- TODO: update in spec: Uα -> tx^#α
  , forall tx. CoordinatedHeadState tx -> Maybe tx
decommitTx :: Maybe tx
  -- ^ Pending decommit transaction. Spec: txω
  , forall tx. CoordinatedHeadState tx -> SnapshotVersion
version :: SnapshotVersion
  -- ^ Last open state version as observed on chain. Spec: ̂v
  }
  deriving stock ((forall x.
 CoordinatedHeadState tx -> Rep (CoordinatedHeadState tx) x)
-> (forall x.
    Rep (CoordinatedHeadState tx) x -> CoordinatedHeadState tx)
-> Generic (CoordinatedHeadState tx)
forall x.
Rep (CoordinatedHeadState tx) x -> CoordinatedHeadState tx
forall x.
CoordinatedHeadState tx -> Rep (CoordinatedHeadState tx) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall tx x.
Rep (CoordinatedHeadState tx) x -> CoordinatedHeadState tx
forall tx x.
CoordinatedHeadState tx -> Rep (CoordinatedHeadState tx) x
$cfrom :: forall tx x.
CoordinatedHeadState tx -> Rep (CoordinatedHeadState tx) x
from :: forall x.
CoordinatedHeadState tx -> Rep (CoordinatedHeadState tx) x
$cto :: forall tx x.
Rep (CoordinatedHeadState tx) x -> CoordinatedHeadState tx
to :: forall x.
Rep (CoordinatedHeadState tx) x -> CoordinatedHeadState tx
Generic)

deriving stock instance IsTx tx => Eq (CoordinatedHeadState tx)
deriving stock instance IsTx tx => Show (CoordinatedHeadState tx)
deriving anyclass instance IsTx tx => ToJSON (CoordinatedHeadState tx)
deriving anyclass instance IsTx tx => FromJSON (CoordinatedHeadState tx)

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

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

-- | Data structure to help in tracking whether we have seen or requested a
-- ReqSn already and if seen, the signatures we collected already.
data SeenSnapshot tx
  = -- | Never saw a ReqSn.
    NoSeenSnapshot
  | -- | No snapshot in flight with last seen snapshot number as given.
    LastSeenSnapshot {forall tx. SeenSnapshot tx -> SnapshotNumber
lastSeen :: SnapshotNumber}
  | -- | ReqSn was sent out and it should be considered already in flight.
    RequestedSnapshot
      { lastSeen :: SnapshotNumber
      , forall tx. SeenSnapshot tx -> SnapshotNumber
requested :: SnapshotNumber
      }
  | -- | ReqSn for given snapshot was received.
    SeenSnapshot
      { forall tx. SeenSnapshot tx -> Snapshot tx
snapshot :: Snapshot tx
      , forall tx. SeenSnapshot tx -> Map Party (Signature (Snapshot tx))
signatories :: Map Party (Signature (Snapshot tx))
      -- ^ Collected signatures so far.
      , forall tx. SeenSnapshot tx -> ByteString
signableBytes :: ~ByteString
      -- ^ Pre-computed result of 'getSignableRepresentation snapshot', cached
      -- to avoid recomputing the expensive UTxO hash on every AckSn
      -- verification. Explicitly lazy under StrictData: state hydration folds
      -- every historical 'NodeState' to WHNF, and a strict field here would
      -- force one full accumulator commitment per replayed SnapshotRequested
      -- event. At runtime it is forced once, on the first AckSn.
      }
  deriving stock ((forall x. SeenSnapshot tx -> Rep (SeenSnapshot tx) x)
-> (forall x. Rep (SeenSnapshot tx) x -> SeenSnapshot tx)
-> Generic (SeenSnapshot tx)
forall x. Rep (SeenSnapshot tx) x -> SeenSnapshot tx
forall x. SeenSnapshot tx -> Rep (SeenSnapshot tx) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall tx x. Rep (SeenSnapshot tx) x -> SeenSnapshot tx
forall tx x. SeenSnapshot tx -> Rep (SeenSnapshot tx) x
$cfrom :: forall tx x. SeenSnapshot tx -> Rep (SeenSnapshot tx) x
from :: forall x. SeenSnapshot tx -> Rep (SeenSnapshot tx) x
$cto :: forall tx x. Rep (SeenSnapshot tx) x -> SeenSnapshot tx
to :: forall x. Rep (SeenSnapshot tx) x -> SeenSnapshot tx
Generic)

deriving stock instance IsTx tx => Eq (SeenSnapshot tx)
deriving stock instance IsTx tx => Show (SeenSnapshot tx)

-- Manual instances that exclude 'signableBytes' from JSON (it is derived from
-- 'snapshot' and recomputed on deserialisation).
instance IsTx tx => ToJSON (SeenSnapshot tx) where
  toJSON :: SeenSnapshot tx -> Value
toJSON = \case
    SeenSnapshot tx
NoSeenSnapshot ->
      [Pair] -> Value
object [Key
"tag" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Text
"NoSeenSnapshot" :: Text)]
    LastSeenSnapshot{SnapshotNumber
$sel:lastSeen:NoSeenSnapshot :: forall tx. SeenSnapshot tx -> SnapshotNumber
lastSeen :: SnapshotNumber
lastSeen} ->
      [Pair] -> Value
object [Key
"tag" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Text
"LastSeenSnapshot" :: Text), Key
"lastSeen" Key -> SnapshotNumber -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= SnapshotNumber
lastSeen]
    RequestedSnapshot{SnapshotNumber
$sel:lastSeen:NoSeenSnapshot :: forall tx. SeenSnapshot tx -> SnapshotNumber
lastSeen :: SnapshotNumber
lastSeen, SnapshotNumber
$sel:requested:NoSeenSnapshot :: forall tx. SeenSnapshot tx -> SnapshotNumber
requested :: SnapshotNumber
requested} ->
      [Pair] -> Value
object
        [ Key
"tag" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Text
"RequestedSnapshot" :: Text)
        , Key
"lastSeen" Key -> SnapshotNumber -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= SnapshotNumber
lastSeen
        , Key
"requested" Key -> SnapshotNumber -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= SnapshotNumber
requested
        ]
    SeenSnapshot{Snapshot tx
$sel:snapshot:NoSeenSnapshot :: forall tx. SeenSnapshot tx -> Snapshot tx
snapshot :: Snapshot tx
snapshot, Map Party (Signature (Snapshot tx))
$sel:signatories:NoSeenSnapshot :: forall tx. SeenSnapshot tx -> Map Party (Signature (Snapshot tx))
signatories :: Map Party (Signature (Snapshot tx))
signatories} ->
      [Pair] -> Value
object
        [ Key
"tag" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Text
"SeenSnapshot" :: Text)
        , Key
"snapshot" Key -> Snapshot tx -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Snapshot tx
snapshot
        , Key
"signatories" Key -> Map Party (Signature (Snapshot tx)) -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Map Party (Signature (Snapshot tx))
signatories
        ]

instance IsTx tx => FromJSON (SeenSnapshot tx) where
  parseJSON :: Value -> Parser (SeenSnapshot tx)
parseJSON = String
-> (Object -> Parser (SeenSnapshot tx))
-> Value
-> Parser (SeenSnapshot tx)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"SeenSnapshot" ((Object -> Parser (SeenSnapshot tx))
 -> Value -> Parser (SeenSnapshot tx))
-> (Object -> Parser (SeenSnapshot tx))
-> Value
-> Parser (SeenSnapshot tx)
forall a b. (a -> b) -> a -> b
$ \Object
obj -> do
    Text
tag :: Text <- Object
obj Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"tag"
    case Text
tag of
      Text
"NoSeenSnapshot" -> SeenSnapshot tx -> Parser (SeenSnapshot tx)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SeenSnapshot tx
forall tx. SeenSnapshot tx
NoSeenSnapshot
      Text
"LastSeenSnapshot" -> SnapshotNumber -> SeenSnapshot tx
forall tx. SnapshotNumber -> SeenSnapshot tx
LastSeenSnapshot (SnapshotNumber -> SeenSnapshot tx)
-> Parser SnapshotNumber -> Parser (SeenSnapshot tx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
obj Object -> Key -> Parser SnapshotNumber
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"lastSeen"
      Text
"RequestedSnapshot" ->
        SnapshotNumber -> SnapshotNumber -> SeenSnapshot tx
forall tx. SnapshotNumber -> SnapshotNumber -> SeenSnapshot tx
RequestedSnapshot
          (SnapshotNumber -> SnapshotNumber -> SeenSnapshot tx)
-> Parser SnapshotNumber
-> Parser (SnapshotNumber -> SeenSnapshot tx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
obj Object -> Key -> Parser SnapshotNumber
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"lastSeen"
          Parser (SnapshotNumber -> SeenSnapshot tx)
-> Parser SnapshotNumber -> Parser (SeenSnapshot 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
obj Object -> Key -> Parser SnapshotNumber
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"requested"
      Text
"SeenSnapshot" -> do
        Snapshot tx
snapshot <- Object
obj Object -> Key -> Parser (Snapshot tx)
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"snapshot"
        Map Party (Signature (Snapshot tx))
signatories <- Object
obj Object -> Key -> Parser (Map Party (Signature (Snapshot tx)))
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"signatories"
        SeenSnapshot tx -> Parser (SeenSnapshot tx)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SeenSnapshot tx -> Parser (SeenSnapshot tx))
-> SeenSnapshot tx -> Parser (SeenSnapshot tx)
forall a b. (a -> b) -> a -> b
$ Snapshot tx
-> Map Party (Signature (Snapshot tx)) -> SeenSnapshot tx
forall tx.
IsTx tx =>
Snapshot tx
-> Map Party (Signature (Snapshot tx)) -> SeenSnapshot tx
mkSeenSnapshot Snapshot tx
snapshot Map Party (Signature (Snapshot tx))
signatories
      Text
other -> String -> Parser (SeenSnapshot tx)
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser (SeenSnapshot tx))
-> String -> Parser (SeenSnapshot tx)
forall a b. (a -> b) -> a -> b
$ String
"unknown SeenSnapshot tag: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. ToString a => a -> String
toString Text
other

-- Manual instances that exclude 'signableBytes' from CBOR (it is derived from
-- 'snapshot' and recomputed on deserialisation), like the JSON instances above.
instance IsTx tx => ToCBOR (SeenSnapshot tx) where
  toCBOR :: SeenSnapshot tx -> Encoding
toCBOR = \case
    SeenSnapshot tx
NoSeenSnapshot ->
      Text -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (Text
"NoSeenSnapshot" :: Text)
    LastSeenSnapshot{SnapshotNumber
$sel:lastSeen:NoSeenSnapshot :: forall tx. SeenSnapshot tx -> SnapshotNumber
lastSeen :: SnapshotNumber
lastSeen} ->
      Text -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (Text
"LastSeenSnapshot" :: Text) Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> SnapshotNumber -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR SnapshotNumber
lastSeen
    RequestedSnapshot{SnapshotNumber
$sel:lastSeen:NoSeenSnapshot :: forall tx. SeenSnapshot tx -> SnapshotNumber
lastSeen :: SnapshotNumber
lastSeen, SnapshotNumber
$sel:requested:NoSeenSnapshot :: forall tx. SeenSnapshot tx -> SnapshotNumber
requested :: SnapshotNumber
requested} ->
      Text -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (Text
"RequestedSnapshot" :: Text) Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> SnapshotNumber -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR SnapshotNumber
lastSeen Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> SnapshotNumber -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR SnapshotNumber
requested
    SeenSnapshot{Snapshot tx
$sel:snapshot:NoSeenSnapshot :: forall tx. SeenSnapshot tx -> Snapshot tx
snapshot :: Snapshot tx
snapshot, Map Party (Signature (Snapshot tx))
$sel:signatories:NoSeenSnapshot :: forall tx. SeenSnapshot tx -> Map Party (Signature (Snapshot tx))
signatories :: Map Party (Signature (Snapshot tx))
signatories} ->
      Text -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (Text
"SeenSnapshot" :: Text) Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Snapshot tx -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR Snapshot tx
snapshot Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Map Party (Signature (Snapshot tx)) -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR Map Party (Signature (Snapshot tx))
signatories

instance IsTx tx => FromCBOR (SeenSnapshot tx) where
  fromCBOR :: forall s. Decoder s (SeenSnapshot 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 (SeenSnapshot tx))
-> Decoder s (SeenSnapshot 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
"NoSeenSnapshot" :: Text) -> SeenSnapshot tx -> Decoder s (SeenSnapshot tx)
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SeenSnapshot tx
forall tx. SeenSnapshot tx
NoSeenSnapshot
      Text
"LastSeenSnapshot" -> SnapshotNumber -> SeenSnapshot tx
forall tx. SnapshotNumber -> SeenSnapshot tx
LastSeenSnapshot (SnapshotNumber -> SeenSnapshot tx)
-> Decoder s SnapshotNumber -> Decoder s (SeenSnapshot tx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s SnapshotNumber
forall s. Decoder s SnapshotNumber
forall a s. FromCBOR a => Decoder s a
fromCBOR
      Text
"RequestedSnapshot" -> SnapshotNumber -> SnapshotNumber -> SeenSnapshot tx
forall tx. SnapshotNumber -> SnapshotNumber -> SeenSnapshot tx
RequestedSnapshot (SnapshotNumber -> SnapshotNumber -> SeenSnapshot tx)
-> Decoder s SnapshotNumber
-> Decoder s (SnapshotNumber -> SeenSnapshot tx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s SnapshotNumber
forall s. Decoder s SnapshotNumber
forall a s. FromCBOR a => Decoder s a
fromCBOR Decoder s (SnapshotNumber -> SeenSnapshot tx)
-> Decoder s SnapshotNumber -> Decoder s (SeenSnapshot 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 SnapshotNumber
forall s. Decoder s SnapshotNumber
forall a s. FromCBOR a => Decoder s a
fromCBOR
      Text
"SeenSnapshot" -> Snapshot tx
-> Map Party (Signature (Snapshot tx)) -> SeenSnapshot tx
forall tx.
IsTx tx =>
Snapshot tx
-> Map Party (Signature (Snapshot tx)) -> SeenSnapshot tx
mkSeenSnapshot (Snapshot tx
 -> Map Party (Signature (Snapshot tx)) -> SeenSnapshot tx)
-> Decoder s (Snapshot tx)
-> Decoder
     s (Map Party (Signature (Snapshot tx)) -> SeenSnapshot tx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s (Snapshot tx)
forall s. Decoder s (Snapshot tx)
forall a s. FromCBOR a => Decoder s a
fromCBOR Decoder s (Map Party (Signature (Snapshot tx)) -> SeenSnapshot tx)
-> Decoder s (Map Party (Signature (Snapshot tx)))
-> Decoder s (SeenSnapshot 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 (Map Party (Signature (Snapshot tx)))
forall s. Decoder s (Map Party (Signature (Snapshot tx)))
forall a s. FromCBOR a => Decoder s a
fromCBOR
      Text
tag -> String -> Decoder s (SeenSnapshot tx)
forall a. String -> Decoder s a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Decoder s (SeenSnapshot tx))
-> String -> Decoder s (SeenSnapshot 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 SeenSnapshot"

-- | Smart constructor for 'SeenSnapshot' that computes and caches
-- 'signableBytes' from 'snapshot', enforcing the invariant that they stay in sync.
mkSeenSnapshot ::
  IsTx tx =>
  Snapshot tx ->
  Map Party (Signature (Snapshot tx)) ->
  SeenSnapshot tx
mkSeenSnapshot :: forall tx.
IsTx tx =>
Snapshot tx
-> Map Party (Signature (Snapshot tx)) -> SeenSnapshot tx
mkSeenSnapshot Snapshot tx
snapshot Map Party (Signature (Snapshot tx))
signatories =
  SeenSnapshot{Snapshot tx
$sel:snapshot:NoSeenSnapshot :: Snapshot tx
snapshot :: Snapshot tx
snapshot, Map Party (Signature (Snapshot tx))
$sel:signatories:NoSeenSnapshot :: Map Party (Signature (Snapshot tx))
signatories :: Map Party (Signature (Snapshot tx))
signatories, $sel:signableBytes:NoSeenSnapshot :: ByteString
signableBytes = Snapshot tx -> ByteString
forall a. SignableRepresentation a => a -> ByteString
getSignableRepresentation Snapshot tx
snapshot}

-- | Get the last seen snapshot number given a 'SeenSnapshot'.
seenSnapshotNumber :: SeenSnapshot tx -> SnapshotNumber
seenSnapshotNumber :: forall tx. SeenSnapshot tx -> SnapshotNumber
seenSnapshotNumber = \case
  SeenSnapshot tx
NoSeenSnapshot -> SnapshotNumber
0
  LastSeenSnapshot{SnapshotNumber
$sel:lastSeen:NoSeenSnapshot :: forall tx. SeenSnapshot tx -> SnapshotNumber
lastSeen :: SnapshotNumber
lastSeen} -> SnapshotNumber
lastSeen
  RequestedSnapshot{SnapshotNumber
$sel:lastSeen:NoSeenSnapshot :: forall tx. SeenSnapshot tx -> SnapshotNumber
lastSeen :: SnapshotNumber
lastSeen} -> SnapshotNumber
lastSeen
  SeenSnapshot{$sel:snapshot:NoSeenSnapshot :: forall tx. SeenSnapshot tx -> Snapshot tx
snapshot = Snapshot{SnapshotNumber
number :: SnapshotNumber
$sel:number:Snapshot :: forall tx. Snapshot tx -> SnapshotNumber
number}} -> SnapshotNumber
number

-- | Whether a snapshot is currently in-flight (requested or being signed).
snapshotInFlight :: SeenSnapshot tx -> Bool
snapshotInFlight :: forall tx. SeenSnapshot tx -> Bool
snapshotInFlight = \case
  SeenSnapshot tx
NoSeenSnapshot -> Bool
False
  LastSeenSnapshot{} -> Bool
False
  RequestedSnapshot{} -> Bool
True
  SeenSnapshot{} -> Bool
True

-- | Whether AckSns are currently being collected for a snapshot.
-- Unlike 'snapshotInFlight', returns False for 'RequestedSnapshot' — a
-- snapshot sent but not yet echoed is stale once the version bumps and should
-- not block a fresh request with the new version.
isCollectingAcks :: SeenSnapshot tx -> Bool
isCollectingAcks :: forall tx. SeenSnapshot tx -> Bool
isCollectingAcks = \case
  SeenSnapshot{} -> Bool
True
  SeenSnapshot tx
_ -> Bool
False

-- ** Closed

-- | An 'Closed' head with an current candidate 'ConfirmedSnapshot', which may
-- be contested before the 'contestationDeadline'.
data ClosedState tx = ClosedState
  { forall tx. ClosedState tx -> HeadParameters
parameters :: HeadParameters
  , forall tx. ClosedState tx -> ConfirmedSnapshot tx
confirmedSnapshot :: ConfirmedSnapshot tx
  , forall tx. ClosedState tx -> UTCTime
contestationDeadline :: UTCTime
  , forall tx. ClosedState tx -> Bool
readyToFanoutSent :: Bool
  -- ^ Tracks whether we have informed clients already about being
  -- 'ReadyToFanout'.
  , forall tx. ClosedState tx -> ChainStateType tx
chainState :: ChainStateType tx
  , forall tx. ClosedState tx -> HeadId
headId :: HeadId
  , forall tx. ClosedState tx -> HeadSeed
headSeed :: HeadSeed
  , forall tx. ClosedState tx -> SnapshotVersion
version :: SnapshotVersion
  }
  deriving stock ((forall x. ClosedState tx -> Rep (ClosedState tx) x)
-> (forall x. Rep (ClosedState tx) x -> ClosedState tx)
-> Generic (ClosedState tx)
forall x. Rep (ClosedState tx) x -> ClosedState tx
forall x. ClosedState tx -> Rep (ClosedState tx) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall tx x. Rep (ClosedState tx) x -> ClosedState tx
forall tx x. ClosedState tx -> Rep (ClosedState tx) x
$cfrom :: forall tx x. ClosedState tx -> Rep (ClosedState tx) x
from :: forall x. ClosedState tx -> Rep (ClosedState tx) x
$cto :: forall tx x. Rep (ClosedState tx) x -> ClosedState tx
to :: forall x. Rep (ClosedState tx) x -> ClosedState tx
Generic)

deriving stock instance (IsTx tx, Eq (ChainStateType tx)) => Eq (ClosedState tx)
deriving stock instance (IsTx tx, Show (ChainStateType tx)) => Show (ClosedState tx)
deriving anyclass instance (IsTx tx, ToJSON (ChainStateType tx)) => ToJSON (ClosedState tx)
deriving anyclass instance (IsTx tx, FromJSON (ChainStateType tx)) => FromJSON (ClosedState tx)

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

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

-- ** PartialFanout

-- Terminology note: the selective-fanout feature spans several near-synonymous
-- names; they map as follows:
--
--   * PartialFanout          — the client input (a user-selected subset to fan out)
--   * HeadPartiallyFannedOut — the server output reporting one observed step
--   * FanningOut             — the client-visible HeadStatus
--   * FanoutProgress         — this off-chain HeadState constructor (and the
--                              matching on-chain head datum), holding a PartialFanoutState
--   * FanoutMode             — how the next step is chosen while in FanoutProgress

-- | How the node decides which UTxOs to distribute in the next fanout step
-- while the head is in 'FanoutProgress'.
data FanoutMode tx
  = -- | Entered only via the 'Fanout' client command: drain the whole remaining
    -- set automatically, dynamically chunked, ending in the final fanout.
    AutoDrain
  | -- | Manual mode: keep distributing this (content-tracked) user selection,
    -- dynamically chunked, until it is exhausted.
    DistributingSelection (UTxOType tx)
  | -- | Manual mode: the previous selection has been fully distributed. Wait for
    -- the next 'PartialFanout' command; do not auto-drain.
    AwaitingSelection
  deriving stock ((forall x. FanoutMode tx -> Rep (FanoutMode tx) x)
-> (forall x. Rep (FanoutMode tx) x -> FanoutMode tx)
-> Generic (FanoutMode tx)
forall x. Rep (FanoutMode tx) x -> FanoutMode tx
forall x. FanoutMode tx -> Rep (FanoutMode tx) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall tx x. Rep (FanoutMode tx) x -> FanoutMode tx
forall tx x. FanoutMode tx -> Rep (FanoutMode tx) x
$cfrom :: forall tx x. FanoutMode tx -> Rep (FanoutMode tx) x
from :: forall x. FanoutMode tx -> Rep (FanoutMode tx) x
$cto :: forall tx x. Rep (FanoutMode tx) x -> FanoutMode tx
to :: forall x. Rep (FanoutMode tx) x -> FanoutMode tx
Generic)

deriving stock instance IsTx tx => Eq (FanoutMode tx)
deriving stock instance IsTx tx => Show (FanoutMode tx)
deriving anyclass instance IsTx tx => ToJSON (FanoutMode tx)
deriving anyclass instance IsTx tx => FromJSON (FanoutMode tx)

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

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

-- | A closed head whose UTxO is being distributed across multiple fanout
-- transactions (on-chain @FanoutProgress@). Holds the partial-fanout bookkeeping
-- that used to live in 'ClosedState'.
data PartialFanoutState tx = PartialFanoutState
  { forall tx. PartialFanoutState tx -> HeadParameters
parameters :: HeadParameters
  , forall tx. PartialFanoutState tx -> ConfirmedSnapshot tx
confirmedSnapshot :: ConfirmedSnapshot tx
  , forall tx. PartialFanoutState tx -> UTCTime
contestationDeadline :: UTCTime
  , forall tx. PartialFanoutState tx -> ChainStateType tx
chainState :: ChainStateType tx
  , forall tx. PartialFanoutState tx -> HeadId
headId :: HeadId
  , forall tx. PartialFanoutState tx -> HeadSeed
headSeed :: HeadSeed
  , forall tx. PartialFanoutState tx -> SnapshotVersion
version :: SnapshotVersion
  , forall tx. PartialFanoutState tx -> UTxOType tx
remainingOutputs :: UTxOType tx
  -- ^ UTxO still to be fanned out (tracked by content, via set difference).
  , forall tx. PartialFanoutState tx -> UTxOType tx
distributedOutputs :: UTxOType tx
  -- ^ Accumulates UTxO distributed so far; used to reconstruct the full set in
  --   'HeadFannedOut' once the head is finalized.
  , forall tx. PartialFanoutState tx -> FanoutMode tx
mode :: FanoutMode tx
  -- ^ Drives the chunk source for the next step (see 'FanoutMode').
  }
  deriving stock ((forall x. PartialFanoutState tx -> Rep (PartialFanoutState tx) x)
-> (forall x.
    Rep (PartialFanoutState tx) x -> PartialFanoutState tx)
-> Generic (PartialFanoutState tx)
forall x. Rep (PartialFanoutState tx) x -> PartialFanoutState tx
forall x. PartialFanoutState tx -> Rep (PartialFanoutState tx) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall tx x. Rep (PartialFanoutState tx) x -> PartialFanoutState tx
forall tx x. PartialFanoutState tx -> Rep (PartialFanoutState tx) x
$cfrom :: forall tx x. PartialFanoutState tx -> Rep (PartialFanoutState tx) x
from :: forall x. PartialFanoutState tx -> Rep (PartialFanoutState tx) x
$cto :: forall tx x. Rep (PartialFanoutState tx) x -> PartialFanoutState tx
to :: forall x. Rep (PartialFanoutState tx) x -> PartialFanoutState tx
Generic)

deriving stock instance (IsTx tx, Eq (ChainStateType tx)) => Eq (PartialFanoutState tx)
deriving stock instance (IsTx tx, Show (ChainStateType tx)) => Show (PartialFanoutState tx)
deriving anyclass instance (IsTx tx, ToJSON (ChainStateType tx)) => ToJSON (PartialFanoutState tx)
deriving anyclass instance (IsTx tx, FromJSON (ChainStateType tx)) => FromJSON (PartialFanoutState tx)

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

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