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

-- | Implements the Head Protocol's /state machine/ as /pure functions/ in an event sourced manner.
--
-- More specifically, the 'update' will handle 'Input's (or rather "commands" in
-- event sourcing speak) and convert that into a list of side-'Effect's and
-- 'StateChanged' events, which in turn are applied via 'aggregateNodeState' into
-- a single 'NodeState'.
--
-- As the specification is using a more imperative way of specifying the protocol
-- behavior, one would find the decision logic in 'update' while state updates
-- can be found in the corresponding 'applyEvent' branch.
module Hydra.HeadLogic (
  module Hydra.HeadLogic,
  module Hydra.HeadLogic.Input,
  module Hydra.HeadLogic.Error,
  module Hydra.HeadLogic.State,
  module Hydra.HeadLogic.Outcome,
) where

import Hydra.Prelude

import Data.List (elemIndex, minimumBy)
import Data.Map.Strict qualified as Map
import Data.Sequence qualified as Seq
import Data.Set ((\\))
import Data.Set qualified as Set
import Hydra.API.ClientInput (ClientInput (..))
import Hydra.API.ServerOutput (DecommitInvalidReason (..))
import Hydra.API.ServerOutput qualified as ServerOutput
import Hydra.Chain (
  ChainEvent (..),
  ChainStateHistory,
  OnChainTx (..),
  PostChainTx (..),
  PostTxError (..),
  initHistory,
  pushNewState,
  rollbackHistory,
  setLastKnown,
 )
import Hydra.Chain.ChainState (ChainSlot (..), IsChainState (..), chainStateSlot)
import Hydra.HeadLogic.Error (
  LogicError (..),
  RequirementFailure (..),
  SideLoadRequirementFailure (..),
 )
import Hydra.HeadLogic.Input (Input (..), TTL)
import Hydra.HeadLogic.Outcome (
  Effect (..),
  Outcome (..),
  StateChanged (..),
  WaitReason (..),
  cause,
  causes,
  changes,
  newState,
  noop,
  wait,
 )
import Hydra.HeadLogic.State (
  ClosedState (..),
  CoordinatedHeadState (..),
  FanoutMode (..),
  HeadState (..),
  IdleState (IdleState, chainState),
  OpenState (..),
  PartialFanoutState (..),
  SeenSnapshot (..),
  getChainState,
  isCollectingAcks,
  mkSeenSnapshot,
  seenSnapshotNumber,
  setChainState,
  snapshotInFlight,
 )
import Hydra.Ledger (Ledger (..), ValidationError (..), applyTransactions, reapplyTransactions)
import Hydra.Network qualified as Network
import Hydra.Network.Message (Message (..), NetworkEvent (..))
import Hydra.Node.Environment (Environment (..), mkHeadParameters)
import Hydra.Node.State (ChainPointTime (..), Deposit (..), DepositStatus (..), NodeState (..), PendingDeposits, SyncedStatus (..), depositsForHead, syncedStatus)
import Hydra.Node.UnsyncedPeriod (UnsyncedPeriod (..))
import Hydra.Tx (
  HeadId,
  HeadSeed,
  IsTx (..),
  TxIdType,
  UTxOType,
  txId,
  utxoFromTx,
  withoutUTxO,
 )
import Hydra.Tx.Accumulator qualified as Accumulator
import Hydra.Tx.Crypto (
  Signature,
  Verified (..),
  aggregateInOrder,
  sign,
  verifyMultiSignature,
  verifyMultiSignatureBytes,
 )
import Hydra.Tx.DepositPeriod (DepositPeriod (..))
import Hydra.Tx.HeadParameters (HeadParameters (..))
import Hydra.Tx.OnChainId (OnChainId)
import Hydra.Tx.Party (Party (vkey))
import Hydra.Tx.Snapshot (ConfirmedSnapshot (..), Snapshot (..), SnapshotNumber, SnapshotVersion, getSnapshot, snapshotUTxO)

-- * The Coordinated Head protocol

-- | Maximum number of transaction ids per snapshot. This effectively limits our
-- "block size" and ensures it does not grow arbitrarily with the backlog of
-- pending transactions (localTxs). Only applied when requesting snapshots as
-- a leader; followers accept larger requests, so this can change without a
-- coordinated upgrade.
--
-- 1000 was chosen from a sweep against 100/250 on sustained-load benchmarks
-- (see hydra-cluster/bench/BASELINES.md): per-round costs that scale with the
-- backlog dominate at small caps (4.6-5.7x lower throughput at 100 with a
-- deep backlog), while peak node memory was flat across the sweep.
maxTxsPerSnapshot :: Int
maxTxsPerSnapshot :: Int
maxTxsPerSnapshot = Int
1000

-- ** On-Chain Protocol

-- | Client request to init the head. This leads to an init transaction on chain,
-- containing the head parameters.
--
-- __Transition__: 'IdleState' → 'IdleState'
onIdleClientInit ::
  Environment ->
  Outcome tx
onIdleClientInit :: forall tx. Environment -> Outcome tx
onIdleClientInit Environment
env =
  Effect tx -> Outcome tx
forall tx. Effect tx -> Outcome tx
cause OnChainEffect{$sel:postChainTx:ClientEffect :: PostChainTx tx
postChainTx = InitTx{[OnChainId]
participants :: [OnChainId]
$sel:participants:InitTx :: [OnChainId]
participants, HeadParameters
headParameters :: HeadParameters
$sel:headParameters:InitTx :: HeadParameters
headParameters}}
 where
  headParameters :: HeadParameters
headParameters = Environment -> HeadParameters
mkHeadParameters Environment
env

  Environment{[OnChainId]
participants :: [OnChainId]
$sel:participants:Environment :: Environment -> [OnChainId]
participants} = Environment
env

-- | Observe an init transaction and initialize parameters in an 'OpenState'.
--
-- __Transition__: 'IdleState' → 'OpenState'
onIdleChainInitTx ::
  Environment ->
  -- | New chain state.
  ChainStateType tx ->
  HeadId ->
  HeadSeed ->
  HeadParameters ->
  [OnChainId] ->
  Outcome tx
onIdleChainInitTx :: forall tx.
Environment
-> ChainStateType tx
-> HeadId
-> HeadSeed
-> HeadParameters
-> [OnChainId]
-> Outcome tx
onIdleChainInitTx Environment
env ChainStateType tx
newChainState HeadId
headId HeadSeed
headSeed HeadParameters
headParameters [OnChainId]
participants
  | Set Party
configuredParties Set Party -> Set Party -> Bool
forall a. Eq a => a -> a -> Bool
== Set Party
initializedParties
      Bool -> Bool -> Bool
&& Key (Set Party)
Party
party Key (Set Party) -> Set Party -> Bool
forall t. StaticMap t => Key t -> t -> Bool
`member` Set Party
initializedParties
      Bool -> Bool -> Bool
&& ContestationPeriod
configuredContestationPeriod ContestationPeriod -> ContestationPeriod -> Bool
forall a. Eq a => a -> a -> Bool
== ContestationPeriod
contestationPeriod
      Bool -> Bool -> Bool
&& DepositPeriod
configuredDepositPeriod DepositPeriod -> DepositPeriod -> Bool
forall a. Eq a => a -> a -> Bool
== DepositPeriod
depositPeriod
      Bool -> Bool -> Bool
&& [OnChainId] -> Set OnChainId
forall a. Ord a => [a] -> Set a
Set.fromList [OnChainId]
configuredParticipants Set OnChainId -> Set OnChainId -> Bool
forall a. Eq a => a -> a -> Bool
== [OnChainId] -> Set OnChainId
forall a. Ord a => [a] -> Set a
Set.fromList [OnChainId]
participants =
      StateChanged tx -> Outcome tx
forall tx. StateChanged tx -> Outcome tx
newState
        HeadOpened
          { $sel:parameters:NetworkConnected :: HeadParameters
parameters = HeadParameters
headParameters
          , $sel:chainState:NetworkConnected :: ChainStateType tx
chainState = ChainStateType tx
newChainState
          , HeadId
headId :: HeadId
$sel:headId:NetworkConnected :: HeadId
headId
          , HeadSeed
headSeed :: HeadSeed
$sel:headSeed:NetworkConnected :: HeadSeed
headSeed
          , [Party]
parties :: [Party]
$sel:parties:NetworkConnected :: [Party]
parties
          }
  | Bool
otherwise =
      StateChanged tx -> Outcome tx
forall tx. StateChanged tx -> Outcome tx
newState
        IgnoredHeadInitializing
          { HeadId
headId :: HeadId
$sel:headId:NetworkConnected :: HeadId
headId
          , ContestationPeriod
contestationPeriod :: ContestationPeriod
$sel:contestationPeriod:NetworkConnected :: ContestationPeriod
contestationPeriod
          , [Party]
parties :: [Party]
$sel:parties:NetworkConnected :: [Party]
parties
          , [OnChainId]
participants :: [OnChainId]
$sel:participants:NetworkConnected :: [OnChainId]
participants
          }
 where
  initializedParties :: Set Party
initializedParties = [Party] -> Set Party
forall a. Ord a => [a] -> Set a
Set.fromList [Party]
parties

  configuredParties :: Set Party
configuredParties = [Party] -> Set Party
forall a. Ord a => [a] -> Set a
Set.fromList (Party
party Party -> [Party] -> [Party]
forall a. a -> [a] -> [a]
: [Party]
otherParties)

  HeadParameters{[Party]
parties :: [Party]
$sel:parties:HeadParameters :: HeadParameters -> [Party]
parties, ContestationPeriod
contestationPeriod :: ContestationPeriod
$sel:contestationPeriod:HeadParameters :: HeadParameters -> ContestationPeriod
contestationPeriod, DepositPeriod
depositPeriod :: DepositPeriod
$sel:depositPeriod:HeadParameters :: HeadParameters -> DepositPeriod
depositPeriod} = HeadParameters
headParameters

  Environment
    { Party
party :: Party
$sel:party:Environment :: Environment -> Party
party
    , [Party]
otherParties :: [Party]
$sel:otherParties:Environment :: Environment -> [Party]
otherParties
    , $sel:contestationPeriod:Environment :: Environment -> ContestationPeriod
contestationPeriod = ContestationPeriod
configuredContestationPeriod
    , $sel:depositPeriod:Environment :: Environment -> DepositPeriod
depositPeriod = DepositPeriod
configuredDepositPeriod
    , $sel:participants:Environment :: Environment -> [OnChainId]
participants = [OnChainId]
configuredParticipants
    } = Environment
env

-- ** Off-chain protocol

-- | Client request to ingest a new transaction into the head.
--
-- __Transition__: 'OpenState' → 'OpenState'
onOpenClientNewTx ::
  -- | The transaction to be submitted to the head.
  tx ->
  Outcome tx
onOpenClientNewTx :: forall tx. tx -> Outcome tx
onOpenClientNewTx tx
tx =
  Effect tx -> Outcome tx
forall tx. Effect tx -> Outcome tx
cause (Effect tx -> Outcome tx)
-> (Message tx -> Effect tx) -> Message tx -> Outcome tx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Message tx -> Effect tx
forall tx. Message tx -> Effect tx
NetworkEffect (Message tx -> Outcome tx) -> Message tx -> Outcome tx
forall a b. (a -> b) -> a -> b
$ tx -> Message tx
forall tx. tx -> Message tx
ReqTx tx
tx

-- | Process a transaction request ('ReqTx') from a party.
--
-- We apply this transaction to the seen utxo (ledger state). If not applicable,
-- we wait and retry later. If it applies, this yields an updated seen ledger
-- state. Then, we check whether we are the leader for the next snapshot and
-- emit a snapshot request 'ReqSn' including this transaction if needed.
--
-- __Transition__: 'OpenState' → 'OpenState'
onOpenNetworkReqTx ::
  IsTx tx =>
  Environment ->
  Ledger tx ->
  ChainSlot ->
  OpenState tx ->
  TTL ->
  PendingDeposits tx ->
  -- | The transaction to be submitted to the head.
  tx ->
  Outcome tx
onOpenNetworkReqTx :: forall tx.
IsTx tx =>
Environment
-> Ledger tx
-> ChainSlot
-> OpenState tx
-> TTL
-> PendingDeposits tx
-> tx
-> Outcome tx
onOpenNetworkReqTx Environment
env Ledger tx
ledger ChainSlot
currentSlot OpenState tx
st TTL
ttl PendingDeposits tx
pendingDeposits tx
tx =
  -- Keep track of transactions by-id
  (StateChanged tx -> Outcome tx
forall tx. StateChanged tx -> Outcome tx
newState TransactionReceived{tx
tx :: tx
$sel:tx:NetworkConnected :: tx
tx} <>) (Outcome tx -> Outcome tx) -> Outcome tx -> Outcome tx
forall a b. (a -> b) -> a -> b
$
    -- Spec: wait L̂ ◦ tx ≠ ⊥
    Outcome tx -> Outcome tx
waitApplyTx (Outcome tx -> Outcome tx) -> Outcome tx -> Outcome tx
forall a b. (a -> b) -> a -> b
$
      -- Spec: T̂ ← T̂ ⋃ {tx}
      --       L̂  ← L̂ ◦ tx
      StateChanged tx -> Outcome tx
forall tx. StateChanged tx -> Outcome tx
newState TransactionAppliedToLocalUTxO{HeadId
$sel:headId:NetworkConnected :: HeadId
headId :: HeadId
headId, tx
tx :: tx
$sel:tx:NetworkConnected :: tx
tx}
        -- Spec: if ŝ = ̅S.s ∧ leader(̅S.s + 1) = i
        --         multicast (reqSn, v, ̅S.s + 1, T̂ , 𝑈𝛼, txω )
        Outcome tx -> (Outcome tx -> Outcome tx) -> Outcome tx
forall a b. a -> (a -> b) -> b
& SnapshotNumber -> Outcome tx -> Outcome tx
maybeRequestSnapshot (SnapshotNumber
confirmedSn SnapshotNumber -> SnapshotNumber -> SnapshotNumber
forall a. Num a => a -> a -> a
+ SnapshotNumber
1)
 where
  waitApplyTx :: Outcome tx -> Outcome tx
waitApplyTx Outcome tx
cont =
    case ChainSlot
-> UTxOType tx
-> [tx]
-> Either (tx, ValidationError) (UTxOType tx)
applyTransactions ChainSlot
currentSlot UTxOType tx
localUTxO [tx
tx] of
      Right UTxOType tx
_ -> Outcome tx
cont
      Left (tx
_, ValidationError
err)
        | TTL
ttl TTL -> TTL -> Bool
forall a. Ord a => a -> a -> Bool
> TTL
0 ->
            WaitReason tx -> Outcome tx
forall tx. WaitReason tx -> Outcome tx
wait (ValidationError -> WaitReason tx
forall tx. ValidationError -> WaitReason tx
WaitOnNotApplicableTx ValidationError
err)
        | Bool
otherwise ->
            -- XXX: We are removing invalid txs from allTxs here to
            -- prevent them piling up infinitely. However, this is not really
            -- covered by the spec and this could be problematic in case of
            -- conflicting transactions paired with network latency and/or
            -- message resubmission. For example: Assume tx2 depends on tx1, but
            -- only tx2 is seen by a participant and eventually times out
            -- because of network latency when receiving tx1. The leader,
            -- however, saw both as valid and requests a snapshot including
            -- both. This is a valid request and it could make the head stuck.
            StateChanged tx -> Outcome tx
forall tx. StateChanged tx -> Outcome tx
newState TxInvalid{HeadId
$sel:headId:NetworkConnected :: HeadId
headId :: HeadId
headId, $sel:utxo:NetworkConnected :: UTxOType tx
utxo = UTxOType tx
localUTxO, $sel:transaction:NetworkConnected :: tx
transaction = tx
tx, $sel:validationError:NetworkConnected :: ValidationError
validationError = ValidationError
err}

  maybeRequestSnapshot :: SnapshotNumber -> Outcome tx -> Outcome tx
maybeRequestSnapshot SnapshotNumber
nextSn Outcome tx
outcome =
    if Bool -> Bool
not (SeenSnapshot tx -> Bool
forall tx. SeenSnapshot tx -> Bool
snapshotInFlight SeenSnapshot tx
seenSnapshot) Bool -> Bool -> Bool
&& HeadParameters -> Party -> SnapshotNumber -> Bool
isLeader HeadParameters
parameters Party
party SnapshotNumber
nextSn
      then
        Outcome tx
outcome
          -- XXX: This state update has no equivalence in the
          -- spec. Do we really need to store that we have
          -- requested a snapshot? If yes, should update spec.
          Outcome tx -> Outcome tx -> Outcome tx
forall a. Semigroup a => a -> a -> a
<> StateChanged tx -> Outcome tx
forall tx. StateChanged tx -> Outcome tx
newState SnapshotRequestDecided{$sel:snapshotNumber:NetworkConnected :: SnapshotNumber
snapshotNumber = SnapshotNumber
nextSn}
          Outcome tx -> Outcome tx -> Outcome tx
forall a. Semigroup a => a -> a -> a
<> Effect tx -> Outcome tx
forall tx. Effect tx -> Outcome tx
cause
            ( Message tx -> Effect tx
forall tx. Message tx -> Effect tx
NetworkEffect (Message tx -> Effect tx) -> Message tx -> Effect tx
forall a b. (a -> b) -> a -> b
$
                let (Maybe tx
nextDecommitTx, Maybe (TxIdType tx)
nextDeposit) =
                      PendingDeposits tx
-> Maybe (TxIdType tx)
-> Maybe tx
-> Maybe (UTxOType tx)
-> (Maybe tx, Maybe (TxIdType tx))
forall tx.
IsTx tx =>
PendingDeposits tx
-> Maybe (TxIdType tx)
-> Maybe tx
-> Maybe (UTxOType tx)
-> (Maybe tx, Maybe (TxIdType tx))
selectNextIncrementalAction
                        PendingDeposits tx
pendingDeposits
                        Maybe (TxIdType tx)
currentDepositTxId
                        Maybe tx
decommitTx
                        (ConfirmedSnapshot tx -> Snapshot tx
forall tx. IsTx tx => ConfirmedSnapshot tx -> Snapshot tx
getSnapshot ConfirmedSnapshot tx
confirmedSnapshot).utxoToCommit
                 in SnapshotVersion
-> SnapshotNumber
-> [TxIdType tx]
-> Maybe tx
-> Maybe (TxIdType tx)
-> Message tx
forall tx.
SnapshotVersion
-> SnapshotNumber
-> [TxIdType tx]
-> Maybe tx
-> Maybe (TxIdType tx)
-> Message tx
ReqSn
                      SnapshotVersion
version
                      SnapshotNumber
nextSn
                      (Seq (TxIdType tx) -> [TxIdType tx]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Seq (TxIdType tx) -> [TxIdType tx])
-> Seq (TxIdType tx) -> [TxIdType tx]
forall a b. (a -> b) -> a -> b
$ tx -> TxIdType tx
forall tx. IsTx tx => tx -> TxIdType tx
txId (tx -> TxIdType tx) -> Seq tx -> Seq (TxIdType tx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Seq tx -> Seq tx
forall a. Int -> Seq a -> Seq a
Seq.take Int
maxTxsPerSnapshot Seq tx
localTxs')
                      Maybe tx
nextDecommitTx
                      Maybe (TxIdType tx)
nextDeposit
            )
      else Outcome tx
outcome

  Environment{Party
$sel:party:Environment :: Environment -> Party
party :: Party
party} = Environment
env

  Ledger{ChainSlot
-> UTxOType tx
-> [tx]
-> Either (tx, ValidationError) (UTxOType tx)
$sel:applyTransactions:Ledger :: forall tx.
Ledger tx
-> ChainSlot
-> UTxOType tx
-> [tx]
-> Either (tx, ValidationError) (UTxOType tx)
applyTransactions :: ChainSlot
-> UTxOType tx
-> [tx]
-> Either (tx, ValidationError) (UTxOType tx)
applyTransactions} = Ledger tx
ledger

  CoordinatedHeadState
    { Seq tx
localTxs :: Seq tx
$sel:localTxs:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> Seq tx
localTxs
    , UTxOType tx
localUTxO :: UTxOType tx
$sel:localUTxO:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> UTxOType tx
localUTxO
    , ConfirmedSnapshot tx
confirmedSnapshot :: ConfirmedSnapshot tx
$sel:confirmedSnapshot:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> ConfirmedSnapshot tx
confirmedSnapshot
    , SeenSnapshot tx
seenSnapshot :: SeenSnapshot tx
$sel:seenSnapshot:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> SeenSnapshot tx
seenSnapshot
    , Maybe tx
decommitTx :: Maybe tx
$sel:decommitTx:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> Maybe tx
decommitTx
    , SnapshotVersion
version :: SnapshotVersion
$sel:version:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> SnapshotVersion
version
    , Maybe (TxIdType tx)
currentDepositTxId :: Maybe (TxIdType tx)
$sel:currentDepositTxId:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> Maybe (TxIdType tx)
currentDepositTxId
    } = CoordinatedHeadState tx
coordinatedHeadState

  Snapshot{$sel:number:Snapshot :: forall tx. Snapshot tx -> SnapshotNumber
number = SnapshotNumber
confirmedSn} = ConfirmedSnapshot tx -> Snapshot tx
forall tx. IsTx tx => ConfirmedSnapshot tx -> Snapshot tx
getSnapshot ConfirmedSnapshot tx
confirmedSnapshot

  OpenState{CoordinatedHeadState tx
coordinatedHeadState :: CoordinatedHeadState tx
$sel:coordinatedHeadState:OpenState :: forall tx. OpenState tx -> CoordinatedHeadState tx
coordinatedHeadState, HeadId
headId :: HeadId
$sel:headId:OpenState :: forall tx. OpenState tx -> HeadId
headId, HeadParameters
parameters :: HeadParameters
$sel:parameters:OpenState :: forall tx. OpenState tx -> HeadParameters
parameters} = OpenState tx
st

  -- NOTE: Order of transactions is important here. See also
  -- 'pruneTransactions'.
  localTxs' :: Seq tx
localTxs' = Seq tx
localTxs Seq tx -> tx -> Seq tx
forall a. Seq a -> a -> Seq a
Seq.|> tx
tx

-- | Process a snapshot request ('ReqSn') from party.
--
-- This checks that s is the next snapshot number and that the party is
-- responsible for leading that snapshot. Then, we potentially wait until the
-- previous snapshot is confirmed (no snapshot is in flight), before we apply
-- (or wait until applicable) the requested transactions to the last confirmed
-- snapshot. Only then, we start tracking this new "seen" snapshot, compute a
-- signature of it and send the corresponding 'AckSn' to all parties. Finally,
-- the pending transaction set gets pruned to only contain still applicable
-- transactions.
--
-- __Transition__: 'OpenState' → 'OpenState'
onOpenNetworkReqSn ::
  IsTx tx =>
  Environment ->
  Ledger tx ->
  PendingDeposits tx ->
  ChainSlot ->
  OpenState tx ->
  -- | Party which sent the ReqSn.
  Party ->
  -- | Requested snapshot version.
  SnapshotVersion ->
  -- | Requested snapshot number.
  SnapshotNumber ->
  -- | List of transactions to snapshot.
  [TxIdType tx] ->
  -- | Optional decommit transaction of removing funds from the head.
  Maybe tx ->
  -- | Optional commit of additional funds into the head.
  Maybe (TxIdType tx) ->
  Outcome tx
onOpenNetworkReqSn :: forall tx.
IsTx tx =>
Environment
-> Ledger tx
-> PendingDeposits tx
-> ChainSlot
-> OpenState tx
-> Party
-> SnapshotVersion
-> SnapshotNumber
-> [TxIdType tx]
-> Maybe tx
-> Maybe (TxIdType tx)
-> Outcome tx
onOpenNetworkReqSn Environment
env Ledger tx
ledger PendingDeposits tx
pendingDeposits ChainSlot
currentSlot OpenState tx
st Party
otherParty SnapshotVersion
sv SnapshotNumber
sn [TxIdType tx]
requestedTxIds Maybe tx
mDecommitTx Maybe (TxIdType tx)
mDepositTxId =
  -- Spec: require v = v̂ ∧ s = ŝ + 1 ∧ leader(s) = j
  Outcome tx -> Outcome tx
requireReqSn (Outcome tx -> Outcome tx) -> Outcome tx -> Outcome tx
forall a b. (a -> b) -> a -> b
$
    -- Spec: wait ŝ = ̅S.s
    Outcome tx -> Outcome tx
waitNoSnapshotInFlight (Outcome tx -> Outcome tx) -> Outcome tx -> Outcome tx
forall a b. (a -> b) -> a -> b
$
      -- Spec: wait v = v̂
      -- NOTE: must be a Wait, not a require: a follower can receive ReqSn for
      -- the bumped version before its own chain handler has processed the
      -- triggering OnIncrementTx/OnDecrementTx. Erroring here would drop the
      -- message permanently (Error outcomes are not re-enqueued), leaving the
      -- head stuck until the deposit expires.
      Outcome tx -> Outcome tx
waitOnSnapshotVersion (Outcome tx -> Outcome tx) -> Outcome tx -> Outcome tx
forall a b. (a -> b) -> a -> b
$
        -- Require any pending utxo to decommit to be consistent
        ((UTxOType tx, Maybe (UTxOType tx)) -> Outcome tx) -> Outcome tx
requireApplicableDecommitTx (((UTxOType tx, Maybe (UTxOType tx)) -> Outcome tx) -> Outcome tx)
-> ((UTxOType tx, Maybe (UTxOType tx)) -> Outcome tx) -> Outcome tx
forall a b. (a -> b) -> a -> b
$ \(UTxOType tx
activeUTxOAfterDecommit, Maybe (UTxOType tx)
mUtxoToDecommit) ->
          -- Wait for the deposit and require any pending commit to be consistent
          UTxOType tx
-> ((UTxOType tx, Maybe (UTxOType tx)) -> Outcome tx) -> Outcome tx
waitForDeposit UTxOType tx
activeUTxOAfterDecommit (((UTxOType tx, Maybe (UTxOType tx)) -> Outcome tx) -> Outcome tx)
-> ((UTxOType tx, Maybe (UTxOType tx)) -> Outcome tx) -> Outcome tx
forall a b. (a -> b) -> a -> b
$ \(UTxOType tx
activeUTxO, Maybe (UTxOType tx)
mUtxoToCommit) ->
            -- Resolve transactions by-id
            ([tx] -> Outcome tx) -> Outcome tx
waitResolvableTxs (([tx] -> Outcome tx) -> Outcome tx)
-> ([tx] -> Outcome tx) -> Outcome tx
forall a b. (a -> b) -> a -> b
$ \[tx]
requestedTxs -> do
              -- Spec: require 𝑈_active ◦ Treq ≠ ⊥
              --       𝑈 ← 𝑈_active ◦ Treq
              UTxOType tx -> [tx] -> (UTxOType tx -> Outcome tx) -> Outcome tx
requireApplyTxs UTxOType tx
activeUTxO [tx]
requestedTxs ((UTxOType tx -> Outcome tx) -> Outcome tx)
-> (UTxOType tx -> Outcome tx) -> Outcome tx
forall a b. (a -> b) -> a -> b
$ \UTxOType tx
u ->
                let nextUTxO :: UTxOType tx
nextUTxO = UTxOType tx
u UTxOType tx -> UTxOType tx -> UTxOType tx
forall tx. IsTx tx => UTxOType tx -> UTxOType tx -> UTxOType tx
`withoutUTxO` UTxOType tx -> Maybe (UTxOType tx) -> UTxOType tx
forall a. a -> Maybe a -> a
fromMaybe UTxOType tx
forall a. Monoid a => a
mempty Maybe (UTxOType tx)
mUtxoToCommit
                    nextCombined :: UTxOType tx
nextCombined = UTxOType tx
nextUTxO 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 Maybe (UTxOType tx)
mUtxoToCommit 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 Maybe (UTxOType tx)
mUtxoToDecommit
                    -- The predecessor is confirmed at this point (see
                    -- requireReqSn and waitNoSnapshotInFlight), so its
                    -- accumulator covers exactly 'snapshotUTxO prevSnapshot'
                    -- and can be updated by the UTxO delta instead of
                    -- re-serializing and re-hashing every output.
                    prevSnapshot :: Snapshot tx
prevSnapshot = ConfirmedSnapshot tx -> Snapshot tx
forall tx. IsTx tx => ConfirmedSnapshot tx -> Snapshot tx
getSnapshot ConfirmedSnapshot tx
confirmedSnapshot
                    accumulator :: HydraAccumulator
accumulator = HydraAccumulator -> UTxOType tx -> UTxOType tx -> HydraAccumulator
forall tx.
IsTx tx =>
HydraAccumulator -> UTxOType tx -> UTxOType tx -> HydraAccumulator
Accumulator.applyUTxODelta Snapshot tx
prevSnapshot.accumulator (Snapshot tx -> UTxOType tx
forall tx. IsTx tx => Snapshot tx -> UTxOType tx
snapshotUTxO Snapshot tx
prevSnapshot) UTxOType tx
nextCombined
                 in HydraAccumulator -> Outcome tx -> Outcome tx
forall tx. HydraAccumulator -> Outcome tx -> Outcome tx
requireValidAccumulatorSize HydraAccumulator
accumulator (Outcome tx -> Outcome tx) -> Outcome tx -> Outcome tx
forall a b. (a -> b) -> a -> b
$ do
                      -- Spec: ŝ ← ̅S.s + 1
                      -- NOTE: confSn == seenSn == sn here
                      let nextSnapshot :: Snapshot tx
nextSnapshot =
                            Snapshot
                              { HeadId
headId :: HeadId
$sel:headId:Snapshot :: HeadId
headId
                              , $sel:version:Snapshot :: SnapshotVersion
version = SnapshotVersion
version
                              , $sel:number:Snapshot :: SnapshotNumber
number = SnapshotNumber
sn
                              , $sel:confirmed:Snapshot :: [tx]
confirmed = [tx]
requestedTxs
                              , $sel:utxo:Snapshot :: UTxOType tx
utxo = UTxOType tx
nextUTxO
                              , $sel:utxoToCommit:Snapshot :: Maybe (UTxOType tx)
utxoToCommit = Maybe (UTxOType tx)
mUtxoToCommit
                              , $sel:utxoToDecommit:Snapshot :: Maybe (UTxOType tx)
utxoToDecommit = Maybe (UTxOType tx)
mUtxoToDecommit
                              , -- Bound into the signature so the increment can only
                                -- claim this very deposit, see 'Hydra.Tx.Snapshot'.
                                $sel:depositTxId:Snapshot :: Maybe (TxIdType tx)
depositTxId = Maybe (TxIdType tx)
mDepositTxId
                              , HydraAccumulator
accumulator :: HydraAccumulator
$sel:accumulator:Snapshot :: HydraAccumulator
accumulator
                              }

                      -- Spec: 𝜂 ← combine(𝑈)
                      --       σᵢ ← MS-Sign(kₕˢⁱᵍ, (cid‖v‖ŝ‖η))
                      let snapshotSignature :: Signature (Snapshot tx)
snapshotSignature = Secret (SigningKey HydraKey)
-> Snapshot tx -> Signature (Snapshot tx)
forall a.
SignableRepresentation a =>
Secret (SigningKey HydraKey) -> a -> Signature a
sign Secret (SigningKey HydraKey)
signingKey Snapshot tx
nextSnapshot
                      -- Spec: multicast (ackSn, ŝ, σᵢ)
                      (Effect tx -> Outcome tx
forall tx. Effect tx -> Outcome tx
cause (Message tx -> Effect tx
forall tx. Message tx -> Effect tx
NetworkEffect (Message tx -> Effect tx) -> Message tx -> Effect tx
forall a b. (a -> b) -> a -> b
$ Signature (Snapshot tx) -> SnapshotNumber -> Message tx
forall tx. Signature (Snapshot tx) -> SnapshotNumber -> Message tx
AckSn Signature (Snapshot tx)
snapshotSignature SnapshotNumber
sn) <>) (Outcome tx -> Outcome tx) -> Outcome tx -> Outcome tx
forall a b. (a -> b) -> a -> b
$ do
                        -- Spec: ̂Σ ← ∅
                        --       L̂ ← 𝑈
                        --       𝑋 ← T
                        --       T̂ ← ∅
                        --       for tx ∈ 𝑋 : L̂ ◦ tx ≠ ⊥
                        --         T̂ ← T̂ ⋃ {tx}
                        --         L̂ ← L̂ ◦ tx
                        let newLocalTxs :: Seq tx
newLocalTxs = UTxOType tx -> Seq tx
pruneTransactions UTxOType tx
u
                        StateChanged tx -> Outcome tx
forall tx. StateChanged tx -> Outcome tx
newState
                          SnapshotRequested
                            { $sel:requestedSnapshot:NetworkConnected :: Snapshot tx
requestedSnapshot = Snapshot tx
nextSnapshot
                            , Seq tx
newLocalTxs :: Seq tx
$sel:newLocalTxs:NetworkConnected :: Seq tx
newLocalTxs
                            , $sel:newCurrentDepositTxId:NetworkConnected :: Maybe (TxIdType tx)
newCurrentDepositTxId = Maybe (TxIdType tx)
mDepositTxId
                            }
 where
  requireReqSn :: Outcome tx -> Outcome tx
requireReqSn Outcome tx
continue
    | SnapshotNumber
sn SnapshotNumber -> SnapshotNumber -> Bool
forall a. Eq a => a -> a -> Bool
/= SnapshotNumber
seenSn SnapshotNumber -> SnapshotNumber -> SnapshotNumber
forall a. Num a => a -> a -> a
+ SnapshotNumber
1 =
        LogicError tx -> Outcome tx
forall tx. LogicError tx -> Outcome tx
Error (LogicError tx -> Outcome tx) -> LogicError tx -> Outcome tx
forall a b. (a -> b) -> a -> b
$ RequirementFailure tx -> LogicError tx
forall tx. RequirementFailure tx -> LogicError tx
RequireFailed (RequirementFailure tx -> LogicError tx)
-> RequirementFailure tx -> LogicError tx
forall a b. (a -> b) -> a -> b
$ ReqSnNumberInvalid{$sel:requestedSn:ReqSnNumberInvalid :: SnapshotNumber
requestedSn = SnapshotNumber
sn, $sel:lastSeenSn:ReqSnNumberInvalid :: SnapshotNumber
lastSeenSn = SnapshotNumber
seenSn}
    | Bool -> Bool
not (HeadParameters -> Party -> SnapshotNumber -> Bool
isLeader HeadParameters
parameters Party
otherParty SnapshotNumber
sn) =
        LogicError tx -> Outcome tx
forall tx. LogicError tx -> Outcome tx
Error (LogicError tx -> Outcome tx) -> LogicError tx -> Outcome tx
forall a b. (a -> b) -> a -> b
$ RequirementFailure tx -> LogicError tx
forall tx. RequirementFailure tx -> LogicError tx
RequireFailed (RequirementFailure tx -> LogicError tx)
-> RequirementFailure tx -> LogicError tx
forall a b. (a -> b) -> a -> b
$ ReqSnNotLeader{$sel:requestedSn:ReqSnNumberInvalid :: SnapshotNumber
requestedSn = SnapshotNumber
sn, $sel:leader:ReqSnNumberInvalid :: Party
leader = Party
otherParty}
    | Bool
otherwise =
        Outcome tx
continue

  waitNoSnapshotInFlight :: Outcome tx -> Outcome tx
waitNoSnapshotInFlight Outcome tx
continue
    | SnapshotNumber
confSn SnapshotNumber -> SnapshotNumber -> Bool
forall a. Eq a => a -> a -> Bool
== SnapshotNumber
seenSn =
        Outcome tx
continue
    | Bool
otherwise =
        WaitReason tx -> Outcome tx
forall tx. WaitReason tx -> Outcome tx
wait (WaitReason tx -> Outcome tx) -> WaitReason tx -> Outcome tx
forall a b. (a -> b) -> a -> b
$ SnapshotNumber -> WaitReason tx
forall tx. SnapshotNumber -> WaitReason tx
WaitOnSnapshotNumber SnapshotNumber
seenSn

  waitOnSnapshotVersion :: Outcome tx -> Outcome tx
waitOnSnapshotVersion Outcome tx
continue
    | SnapshotVersion
version SnapshotVersion -> SnapshotVersion -> Bool
forall a. Eq a => a -> a -> Bool
== SnapshotVersion
sv =
        Outcome tx
continue
    | Bool
otherwise =
        WaitReason tx -> Outcome tx
forall tx. WaitReason tx -> Outcome tx
wait (WaitReason tx -> Outcome tx) -> WaitReason tx -> Outcome tx
forall a b. (a -> b) -> a -> b
$ SnapshotVersion -> WaitReason tx
forall tx. SnapshotVersion -> WaitReason tx
WaitOnSnapshotVersion SnapshotVersion
sv

  waitResolvableTxs :: ([tx] -> Outcome tx) -> Outcome tx
waitResolvableTxs [tx] -> Outcome tx
continue =
    case Set (TxIdType tx) -> [TxIdType tx]
forall a. Set a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList ([Item (Set (TxIdType tx))] -> Set (TxIdType tx)
forall l. IsList l => [Item l] -> l
fromList [Item (Set (TxIdType tx))]
[TxIdType tx]
requestedTxIds Set (TxIdType tx) -> Set (TxIdType tx) -> Set (TxIdType tx)
forall a. Ord a => Set a -> Set a -> Set a
\\ Map (TxIdType tx) tx -> Set (TxIdType tx)
forall k a. Map k a -> Set k
Map.keysSet Map (TxIdType tx) tx
allTxs) of
      [] -> [tx] -> Outcome tx
continue ([tx] -> Outcome tx) -> [tx] -> Outcome tx
forall a b. (a -> b) -> a -> b
$ (TxIdType tx -> Maybe tx) -> [TxIdType tx] -> [tx]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (TxIdType tx -> Map (TxIdType tx) tx -> Maybe tx
forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map (TxIdType tx) tx
allTxs) [TxIdType tx]
requestedTxIds
      [TxIdType tx]
unseen -> WaitReason tx -> Outcome tx
forall tx. WaitReason tx -> Outcome tx
wait (WaitReason tx -> Outcome tx) -> WaitReason tx -> Outcome tx
forall a b. (a -> b) -> a -> b
$ [TxIdType tx] -> WaitReason tx
forall tx. [TxIdType tx] -> WaitReason tx
WaitOnTxs [TxIdType tx]
unseen

  waitForDeposit :: UTxOType tx
-> ((UTxOType tx, Maybe (UTxOType tx)) -> Outcome tx) -> Outcome tx
waitForDeposit UTxOType tx
activeUTxOAfterDecommit (UTxOType tx, Maybe (UTxOType tx)) -> Outcome tx
cont =
    case Maybe (TxIdType tx)
mDepositTxId of
      Maybe (TxIdType tx)
Nothing -> (UTxOType tx, Maybe (UTxOType tx)) -> Outcome tx
cont (UTxOType tx
activeUTxOAfterDecommit, Maybe (UTxOType tx)
forall a. Maybe a
Nothing)
      Just TxIdType tx
depositTxId ->
        case TxIdType tx -> PendingDeposits tx -> Maybe (Deposit tx)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TxIdType tx
depositTxId PendingDeposits tx
pendingDeposits of
          Maybe (Deposit tx)
Nothing ->
            -- Error out in case we receive a ReqSn that doesn't match local deposit
            LogicError tx -> Outcome tx
forall tx. LogicError tx -> Outcome tx
Error (LogicError tx -> Outcome tx) -> LogicError tx -> Outcome tx
forall a b. (a -> b) -> a -> b
$ RequirementFailure tx -> LogicError tx
forall tx. RequirementFailure tx -> LogicError tx
RequireFailed RequestedDepositNotFoundLocally{TxIdType tx
depositTxId :: TxIdType tx
$sel:depositTxId:ReqSnNumberInvalid :: TxIdType tx
depositTxId}
          Just Deposit{DepositStatus
status :: DepositStatus
$sel:status:Deposit :: forall tx. Deposit tx -> DepositStatus
status, UTxOType tx
deposited :: UTxOType tx
$sel:deposited:Deposit :: forall tx. Deposit tx -> UTxOType tx
deposited}
            | DepositStatus
status DepositStatus -> DepositStatus -> Bool
forall a. Eq a => a -> a -> Bool
== DepositStatus
Inactive -> WaitReason tx -> Outcome tx
forall tx. WaitReason tx -> Outcome tx
wait WaitOnDepositActivation{TxIdType tx
depositTxId :: TxIdType tx
$sel:depositTxId:WaitOnNotApplicableTx :: TxIdType tx
depositTxId}
            | DepositStatus
status DepositStatus -> DepositStatus -> Bool
forall a. Eq a => a -> a -> Bool
== DepositStatus
Expired -> LogicError tx -> Outcome tx
forall tx. LogicError tx -> Outcome tx
Error (LogicError tx -> Outcome tx) -> LogicError tx -> Outcome tx
forall a b. (a -> b) -> a -> b
$ RequirementFailure tx -> LogicError tx
forall tx. RequirementFailure tx -> LogicError tx
RequireFailed RequestedDepositExpired{TxIdType tx
depositTxId :: TxIdType tx
$sel:depositTxId:ReqSnNumberInvalid :: TxIdType tx
depositTxId}
            | Bool
otherwise ->
                -- NOTE: this makes the commits sequential in a sense that you can't
                -- commit unless the previous commit is settled.
                if SnapshotVersion
sv SnapshotVersion -> SnapshotVersion -> Bool
forall a. Eq a => a -> a -> Bool
== SnapshotVersion
confVersion Bool -> Bool -> Bool
&& Maybe (UTxOType tx) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (UTxOType tx)
confUTxOToCommit
                  then
                    -- NOTE: identity, not just content. Two deposits can record
                    -- the same UTxO, and only the one bound into the confirmed
                    -- snapshot is the pending commit being settled.
                    if Maybe (UTxOType tx)
confUTxOToCommit Maybe (UTxOType tx) -> Maybe (UTxOType tx) -> Bool
forall a. Eq a => a -> a -> Bool
== UTxOType tx -> Maybe (UTxOType tx)
forall a. a -> Maybe a
Just UTxOType tx
deposited Bool -> Bool -> Bool
&& Maybe (TxIdType tx)
confDepositTxId Maybe (TxIdType tx) -> Maybe (TxIdType tx) -> Bool
forall a. Eq a => a -> a -> Bool
== TxIdType tx -> Maybe (TxIdType tx)
forall a. a -> Maybe a
Just TxIdType tx
depositTxId
                      then (UTxOType tx, Maybe (UTxOType tx)) -> Outcome tx
cont (UTxOType tx
activeUTxOAfterDecommit UTxOType tx -> UTxOType tx -> UTxOType tx
forall a. Semigroup a => a -> a -> a
<> UTxOType tx
deposited, Maybe (UTxOType tx)
confUTxOToCommit)
                      else LogicError tx -> Outcome tx
forall tx. LogicError tx -> Outcome tx
Error (LogicError tx -> Outcome tx) -> LogicError tx -> Outcome tx
forall a b. (a -> b) -> a -> b
$ RequirementFailure tx -> LogicError tx
forall tx. RequirementFailure tx -> LogicError tx
RequireFailed RequirementFailure tx
forall tx. RequirementFailure tx
ReqSnCommitNotSettled
                  else do
                    let activeUTxOAfterCommit :: UTxOType tx
activeUTxOAfterCommit = UTxOType tx
activeUTxOAfterDecommit UTxOType tx -> UTxOType tx -> UTxOType tx
forall a. Semigroup a => a -> a -> a
<> UTxOType tx
deposited
                    (UTxOType tx, Maybe (UTxOType tx)) -> Outcome tx
cont (UTxOType tx
activeUTxOAfterCommit, UTxOType tx -> Maybe (UTxOType tx)
forall a. a -> Maybe a
Just UTxOType tx
deposited)

  requireApplicableDecommitTx :: ((UTxOType tx, Maybe (UTxOType tx)) -> Outcome tx) -> Outcome tx
requireApplicableDecommitTx (UTxOType tx, Maybe (UTxOType tx)) -> Outcome tx
cont =
    case Maybe tx
mDecommitTx of
      Maybe tx
Nothing -> (UTxOType tx, Maybe (UTxOType tx)) -> Outcome tx
cont (UTxOType tx
confirmedUTxO, Maybe (UTxOType tx)
forall a. Maybe a
Nothing)
      -- Spec: require tx𝜔 = ⊥ ∨ tx𝛼 = ⊥
      --
      -- A snapshot settling both a commit and a decommit cannot be closed:
      -- close and fanout express a single incremental action
      -- ('setIncrementalActionMaybe'). The leader never proposes both (see
      -- 'selectNextIncrementalAction'), so this rejects a request that does
      -- anyway rather than confirming an unclosable snapshot.
      Just tx
decommitTx
        | Just TxIdType tx
depositTxId <- Maybe (TxIdType tx)
mDepositTxId ->
            LogicError tx -> Outcome tx
forall tx. LogicError tx -> Outcome tx
Error (LogicError tx -> Outcome tx) -> LogicError tx -> Outcome tx
forall a b. (a -> b) -> a -> b
$ RequirementFailure tx -> LogicError tx
forall tx. RequirementFailure tx -> LogicError tx
RequireFailed ReqSnBothCommitAndDecommit{TxIdType tx
$sel:depositTxId:ReqSnNumberInvalid :: TxIdType tx
depositTxId :: TxIdType tx
depositTxId, $sel:decommitTxId:ReqSnNumberInvalid :: TxIdType tx
decommitTxId = tx -> TxIdType tx
forall tx. IsTx tx => tx -> TxIdType tx
txId tx
decommitTx}
      -- 'Hydra.Contract.Head.checkDecrement' requires at least one decommit
      -- output, so a decommit materializing none could never settle on-chain and
      -- would be re-proposed by every later snapshot.
      Just tx
decommitTx
        | tx -> UTxOType tx
forall tx. IsTx tx => tx -> UTxOType tx
utxoFromTx tx
decommitTx UTxOType tx -> UTxOType tx -> Bool
forall a. Eq a => a -> a -> Bool
== UTxOType tx
forall a. Monoid a => a
mempty ->
            LogicError tx -> Outcome tx
forall tx. LogicError tx -> Outcome tx
Error (LogicError tx -> Outcome tx) -> LogicError tx -> Outcome tx
forall a b. (a -> b) -> a -> b
$ RequirementFailure tx -> LogicError tx
forall tx. RequirementFailure tx -> LogicError tx
RequireFailed ReqSnDecommitNoOutputs{$sel:decommitTxId:ReqSnNumberInvalid :: TxIdType tx
decommitTxId = tx -> TxIdType tx
forall tx. IsTx tx => tx -> TxIdType tx
txId tx
decommitTx}
      Just tx
decommitTx ->
        -- Spec:
        -- require 𝑣 = 𝑣 ̂ ∧ 𝑠 = 𝑠 ̂ + 1 ∧ leader(𝑠) = 𝑗
        -- wait 𝑠 ̂ = 𝒮.𝑠
        if SnapshotVersion
sv SnapshotVersion -> SnapshotVersion -> Bool
forall a. Eq a => a -> a -> Bool
== SnapshotVersion
confVersion Bool -> Bool -> Bool
&& Maybe (UTxOType tx) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (UTxOType tx)
confUTxOToDecommit
          then
            if Maybe (UTxOType tx)
confUTxOToDecommit Maybe (UTxOType tx) -> Maybe (UTxOType tx) -> Bool
forall a. Eq a => a -> a -> Bool
== UTxOType tx -> Maybe (UTxOType tx)
forall a. a -> Maybe a
Just (tx -> UTxOType tx
forall tx. IsTx tx => tx -> UTxOType tx
utxoFromTx tx
decommitTx)
              then (UTxOType tx, Maybe (UTxOType tx)) -> Outcome tx
cont (UTxOType tx
confirmedUTxO, Maybe (UTxOType tx)
confUTxOToDecommit)
              else LogicError tx -> Outcome tx
forall tx. LogicError tx -> Outcome tx
Error (LogicError tx -> Outcome tx) -> LogicError tx -> Outcome tx
forall a b. (a -> b) -> a -> b
$ RequirementFailure tx -> LogicError tx
forall tx. RequirementFailure tx -> LogicError tx
RequireFailed RequirementFailure tx
forall tx. RequirementFailure tx
ReqSnDecommitNotSettled
          else case Ledger tx
-> ChainSlot
-> UTxOType tx
-> [tx]
-> Either (tx, ValidationError) (UTxOType tx)
forall tx.
Ledger tx
-> ChainSlot
-> UTxOType tx
-> [tx]
-> Either (tx, ValidationError) (UTxOType tx)
applyTransactions Ledger tx
ledger ChainSlot
currentSlot UTxOType tx
confirmedUTxO [tx
decommitTx] of
            Left (tx
_, ValidationError
err) ->
              LogicError tx -> Outcome tx
forall tx. LogicError tx -> Outcome tx
Error (LogicError tx -> Outcome tx) -> LogicError tx -> Outcome tx
forall a b. (a -> b) -> a -> b
$ RequirementFailure tx -> LogicError tx
forall tx. RequirementFailure tx -> LogicError tx
RequireFailed (RequirementFailure tx -> LogicError tx)
-> RequirementFailure tx -> LogicError tx
forall a b. (a -> b) -> a -> b
$ SnapshotNumber
-> TxIdType tx -> ValidationError -> RequirementFailure tx
forall tx.
SnapshotNumber
-> TxIdType tx -> ValidationError -> RequirementFailure tx
SnapshotDoesNotApply SnapshotNumber
sn (tx -> TxIdType tx
forall tx. IsTx tx => tx -> TxIdType tx
txId tx
decommitTx) ValidationError
err
            Right UTxOType tx
newConfirmedUTxO -> do
              let utxoToDecommit :: UTxOType tx
utxoToDecommit = tx -> UTxOType tx
forall tx. IsTx tx => tx -> UTxOType tx
utxoFromTx tx
decommitTx
              let activeUTxO :: UTxOType tx
activeUTxO = UTxOType tx
newConfirmedUTxO UTxOType tx -> UTxOType tx -> UTxOType tx
forall tx. IsTx tx => UTxOType tx -> UTxOType tx -> UTxOType tx
`withoutUTxO` UTxOType tx
utxoToDecommit
              (UTxOType tx, Maybe (UTxOType tx)) -> Outcome tx
cont (UTxOType tx
activeUTxO, UTxOType tx -> Maybe (UTxOType tx)
forall a. a -> Maybe a
Just UTxOType tx
utxoToDecommit)

  -- NOTE: at this point we know those transactions apply on the localUTxO because they
  -- are part of the localTxs. The snapshot can contain less transactions than the ones
  -- we have seen at this stage, but they all _must_ apply correctly to the latest
  -- snapshot's UTxO set, eg. it's illegal for a snapshot leader to request a snapshot
  -- containing transactions that do not apply cleanly.
  requireApplyTxs :: UTxOType tx -> [tx] -> (UTxOType tx -> Outcome tx) -> Outcome tx
requireApplyTxs UTxOType tx
utxo [tx]
requestedTxs UTxOType tx -> Outcome tx
cont =
    case Ledger tx
-> ChainSlot
-> UTxOType tx
-> [tx]
-> Either (tx, ValidationError) (UTxOType tx)
reapplyOrApply Ledger tx
ledger ChainSlot
currentSlot UTxOType tx
utxo [tx]
requestedTxs of
      Left (tx
tx, ValidationError
err) ->
        LogicError tx -> Outcome tx
forall tx. LogicError tx -> Outcome tx
Error (LogicError tx -> Outcome tx) -> LogicError tx -> Outcome tx
forall a b. (a -> b) -> a -> b
$ RequirementFailure tx -> LogicError tx
forall tx. RequirementFailure tx -> LogicError tx
RequireFailed (RequirementFailure tx -> LogicError tx)
-> RequirementFailure tx -> LogicError tx
forall a b. (a -> b) -> a -> b
$ SnapshotNumber
-> TxIdType tx -> ValidationError -> RequirementFailure tx
forall tx.
SnapshotNumber
-> TxIdType tx -> ValidationError -> RequirementFailure tx
SnapshotDoesNotApply SnapshotNumber
sn (tx -> TxIdType tx
forall tx. IsTx tx => tx -> TxIdType tx
txId tx
tx) ValidationError
err
      Right UTxOType tx
u -> UTxOType tx -> Outcome tx
cont UTxOType tx
u

  -- The requested transactions were already validated on receipt ('ReqTx'), so
  -- re-applying them to the confirmed UTxO only needs the state-dependent ledger
  -- checks (inputs present, value preserved) and can skip the expensive Plutus
  -- script re-evaluation. When a commit or decommit reshapes the active UTxO we
  -- conservatively fall back to full application, since the script context may
  -- then differ from what was validated.
  reapplyOrApply :: Ledger tx
-> ChainSlot
-> UTxOType tx
-> [tx]
-> Either (tx, ValidationError) (UTxOType tx)
reapplyOrApply
    | Maybe tx -> Bool
forall a. Maybe a -> Bool
isNothing Maybe tx
mDecommitTx Bool -> Bool -> Bool
&& Maybe (TxIdType tx) -> Bool
forall a. Maybe a -> Bool
isNothing Maybe (TxIdType tx)
mDepositTxId = Ledger tx
-> ChainSlot
-> UTxOType tx
-> [tx]
-> Either (tx, ValidationError) (UTxOType tx)
forall tx.
Ledger tx
-> ChainSlot
-> UTxOType tx
-> [tx]
-> Either (tx, ValidationError) (UTxOType tx)
reapplyTransactions
    | Bool
otherwise = Ledger tx
-> ChainSlot
-> UTxOType tx
-> [tx]
-> Either (tx, ValidationError) (UTxOType tx)
forall tx.
Ledger tx
-> ChainSlot
-> UTxOType tx
-> [tx]
-> Either (tx, ValidationError) (UTxOType tx)
applyTransactions

  requireValidAccumulatorSize :: Accumulator.HydraAccumulator -> Outcome tx -> Outcome tx
  requireValidAccumulatorSize :: forall tx. HydraAccumulator -> Outcome tx -> Outcome tx
requireValidAccumulatorSize HydraAccumulator
accumulator Outcome tx
continue
    | HydraAccumulator -> Int
Accumulator.accumulatorSize HydraAccumulator
accumulator Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
Accumulator.maxAccumulatorSize =
        LogicError tx -> Outcome tx
forall tx. LogicError tx -> Outcome tx
Error (LogicError tx -> Outcome tx) -> LogicError tx -> Outcome tx
forall a b. (a -> b) -> a -> b
$
          RequirementFailure tx -> LogicError tx
forall tx. RequirementFailure tx -> LogicError tx
RequireFailed (RequirementFailure tx -> LogicError tx)
-> RequirementFailure tx -> LogicError tx
forall a b. (a -> b) -> a -> b
$
            ReqSnUTxOSetTooLarge
              { $sel:utxoCount:ReqSnNumberInvalid :: Int
utxoCount = HydraAccumulator -> Int
Accumulator.accumulatorSize HydraAccumulator
accumulator
              , $sel:maxAllowed:ReqSnNumberInvalid :: Int
maxAllowed = Int
Accumulator.maxAccumulatorSize
              }
    | Bool
otherwise =
        Outcome tx
continue

  -- \| Filter 'localTxs' to those that still apply against the running UTxO
  -- after each previous successful tx. The post-snapshot UTxO is not returned:
  -- aggregate will recompute it.
  pruneTransactions :: UTxOType tx -> Seq tx
pruneTransactions UTxOType tx
utxo0 = UTxOType tx -> Seq tx -> Seq tx
go UTxOType tx
utxo0 Seq tx
localTxs
   where
    go :: UTxOType tx -> Seq tx -> Seq tx
go UTxOType tx
_ Seq tx
Seq.Empty = Seq tx
forall a. Seq a
Seq.empty
    go UTxOType tx
u (tx
tx Seq.:<| Seq tx
rest) =
      -- XXX: We prune transactions on any error, while only some of them are
      -- actually expected.
      -- For example: `OutsideValidityIntervalUTxO` ledger errors are expected
      -- here when a tx becomes invalid.
      -- These txs are part of 'localTxs' and were already validated on receipt,
      -- so we re-apply (skipping Plutus re-evaluation); the state-dependent
      -- checks still run and prune txs that no longer apply.
      case Ledger tx
-> ChainSlot
-> UTxOType tx
-> [tx]
-> Either (tx, ValidationError) (UTxOType tx)
reapplyOrApply Ledger tx
ledger ChainSlot
currentSlot UTxOType tx
u [tx
tx] of
        Left (tx, ValidationError)
_ -> UTxOType tx -> Seq tx -> Seq tx
go UTxOType tx
u Seq tx
rest
        Right UTxOType tx
u' -> tx
tx tx -> Seq tx -> Seq tx
forall a. a -> Seq a -> Seq a
Seq.<| UTxOType tx -> Seq tx -> Seq tx
go UTxOType tx
u' Seq tx
rest
  confSn :: SnapshotNumber
confSn = case ConfirmedSnapshot tx
confirmedSnapshot of
    InitialSnapshot{} -> SnapshotNumber
0
    ConfirmedSnapshot{$sel:snapshot:InitialSnapshot :: forall tx. ConfirmedSnapshot tx -> Snapshot tx
snapshot = Snapshot{SnapshotNumber
$sel:number:Snapshot :: forall tx. Snapshot tx -> SnapshotNumber
number :: SnapshotNumber
number}} -> SnapshotNumber
number

  Snapshot{$sel:version:Snapshot :: forall tx. Snapshot tx -> SnapshotVersion
version = SnapshotVersion
confVersion} = ConfirmedSnapshot tx -> Snapshot tx
forall tx. IsTx tx => ConfirmedSnapshot tx -> Snapshot tx
getSnapshot ConfirmedSnapshot tx
confirmedSnapshot

  confUTxOToCommit :: Maybe (UTxOType tx)
confUTxOToCommit = case ConfirmedSnapshot tx
confirmedSnapshot of
    InitialSnapshot{} -> Maybe (UTxOType tx)
forall a. Maybe a
Nothing
    ConfirmedSnapshot{$sel:snapshot:InitialSnapshot :: forall tx. ConfirmedSnapshot tx -> Snapshot tx
snapshot = Snapshot{Maybe (UTxOType tx)
$sel:utxoToCommit:Snapshot :: forall tx. Snapshot tx -> Maybe (UTxOType tx)
utxoToCommit :: Maybe (UTxOType tx)
utxoToCommit}} -> Maybe (UTxOType tx)
utxoToCommit

  confDepositTxId :: Maybe (TxIdType tx)
confDepositTxId = case ConfirmedSnapshot tx
confirmedSnapshot of
    InitialSnapshot{} -> Maybe (TxIdType tx)
forall a. Maybe a
Nothing
    ConfirmedSnapshot{$sel:snapshot:InitialSnapshot :: forall tx. ConfirmedSnapshot tx -> Snapshot tx
snapshot = Snapshot{Maybe (TxIdType tx)
$sel:depositTxId:Snapshot :: forall tx. Snapshot tx -> Maybe (TxIdType tx)
depositTxId :: Maybe (TxIdType tx)
depositTxId}} -> Maybe (TxIdType tx)
depositTxId

  confUTxOToDecommit :: Maybe (UTxOType tx)
confUTxOToDecommit = case ConfirmedSnapshot tx
confirmedSnapshot of
    InitialSnapshot{} -> Maybe (UTxOType tx)
forall a. Maybe a
Nothing
    ConfirmedSnapshot{$sel:snapshot:InitialSnapshot :: forall tx. ConfirmedSnapshot tx -> Snapshot tx
snapshot = Snapshot{Maybe (UTxOType tx)
$sel:utxoToDecommit:Snapshot :: forall tx. Snapshot tx -> Maybe (UTxOType tx)
utxoToDecommit :: Maybe (UTxOType tx)
utxoToDecommit}} -> Maybe (UTxOType tx)
utxoToDecommit

  seenSn :: SnapshotNumber
seenSn = SeenSnapshot tx -> SnapshotNumber
forall tx. SeenSnapshot tx -> SnapshotNumber
seenSnapshotNumber SeenSnapshot tx
seenSnapshot

  confirmedUTxO :: UTxOType tx
confirmedUTxO = case ConfirmedSnapshot tx
confirmedSnapshot of
    InitialSnapshot{} -> UTxOType tx
forall a. Monoid a => a
mempty
    ConfirmedSnapshot{$sel:snapshot:InitialSnapshot :: forall tx. ConfirmedSnapshot tx -> Snapshot tx
snapshot = Snapshot{UTxOType tx
$sel:utxo:Snapshot :: forall tx. Snapshot tx -> UTxOType tx
utxo :: UTxOType tx
utxo, Maybe (UTxOType tx)
$sel:utxoToCommit:Snapshot :: forall tx. Snapshot tx -> Maybe (UTxOType tx)
utxoToCommit :: Maybe (UTxOType tx)
utxoToCommit, $sel:version:Snapshot :: forall tx. Snapshot tx -> SnapshotVersion
version = SnapshotVersion
snapshotVersion}} ->
      if SnapshotVersion
version SnapshotVersion -> SnapshotVersion -> Bool
forall a. Ord a => a -> a -> Bool
> SnapshotVersion
snapshotVersion
        then UTxOType tx
utxo 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 Maybe (UTxOType tx)
utxoToCommit
        else UTxOType tx
utxo

  CoordinatedHeadState{ConfirmedSnapshot tx
$sel:confirmedSnapshot:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> ConfirmedSnapshot tx
confirmedSnapshot :: ConfirmedSnapshot tx
confirmedSnapshot, SeenSnapshot tx
$sel:seenSnapshot:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> SeenSnapshot tx
seenSnapshot :: SeenSnapshot tx
seenSnapshot, Map (TxIdType tx) tx
allTxs :: Map (TxIdType tx) tx
$sel:allTxs:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> Map (TxIdType tx) tx
allTxs, Seq tx
$sel:localTxs:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> Seq tx
localTxs :: Seq tx
localTxs, SnapshotVersion
$sel:version:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> SnapshotVersion
version :: SnapshotVersion
version} = CoordinatedHeadState tx
coordinatedHeadState

  OpenState{HeadParameters
$sel:parameters:OpenState :: forall tx. OpenState tx -> HeadParameters
parameters :: HeadParameters
parameters, CoordinatedHeadState tx
$sel:coordinatedHeadState:OpenState :: forall tx. OpenState tx -> CoordinatedHeadState tx
coordinatedHeadState :: CoordinatedHeadState tx
coordinatedHeadState, HeadId
$sel:headId:OpenState :: forall tx. OpenState tx -> HeadId
headId :: HeadId
headId} = OpenState tx
st

  Environment{Secret (SigningKey HydraKey)
signingKey :: Secret (SigningKey HydraKey)
$sel:signingKey:Environment :: Environment -> Secret (SigningKey HydraKey)
signingKey} = Environment
env

-- | Process a snapshot acknowledgement ('AckSn') from a party.
--
-- We do require that the is from the last seen or next expected snapshot, and
-- potentially wait wait for the corresponding 'ReqSn' before proceeding. If the
-- party hasn't sent us a signature yet, we store it. Once a signature from each
-- party has been collected, we aggregate a multi-signature and verify it is
-- correct. If everything is fine, the snapshot can be considered as the latest
-- confirmed one. Similar to processing a 'ReqTx', we check whether we are
-- leading the next snapshot and craft a corresponding 'ReqSn' if needed.
--
-- __Transition__: 'OpenState' → 'OpenState'
onOpenNetworkAckSn ::
  IsTx tx =>
  Environment ->
  PendingDeposits tx ->
  OpenState tx ->
  -- | Party which sent the AckSn.
  Party ->
  -- | Signature from other party.
  Signature (Snapshot tx) ->
  -- | Snapshot number of this AckSn.
  SnapshotNumber ->
  Outcome tx
onOpenNetworkAckSn :: forall tx.
IsTx tx =>
Environment
-> PendingDeposits tx
-> OpenState tx
-> Party
-> Signature (Snapshot tx)
-> SnapshotNumber
-> Outcome tx
onOpenNetworkAckSn Environment{Party
$sel:party:Environment :: Environment -> Party
party :: Party
party} PendingDeposits tx
pendingDeposits OpenState tx
openState Party
otherParty Signature (Snapshot tx)
snapshotSignature SnapshotNumber
sn =
  -- Spec: require s ∈ {ŝ, ŝ + 1}
  Outcome tx -> Outcome tx
requireValidAckSn (Outcome tx -> Outcome tx) -> Outcome tx -> Outcome tx
forall a b. (a -> b) -> a -> b
$ do
    -- Spec: wait ŝ = s
    (Snapshot tx
 -> Map Party (Signature (Snapshot tx)) -> ByteString -> Outcome tx)
-> Outcome tx
waitOnSeenSnapshot ((Snapshot tx
  -> Map Party (Signature (Snapshot tx)) -> ByteString -> Outcome tx)
 -> Outcome tx)
-> (Snapshot tx
    -> Map Party (Signature (Snapshot tx)) -> ByteString -> Outcome tx)
-> Outcome tx
forall a b. (a -> b) -> a -> b
$ \Snapshot tx
snapshot Map Party (Signature (Snapshot tx))
sigs ByteString
snapshotBytes -> do
      -- Spec: require (j,⋅) ∉ ̂Σ
      Map Party (Signature (Snapshot tx)) -> Outcome tx -> Outcome tx
requireNotSignedYet Map Party (Signature (Snapshot tx))
sigs (Outcome tx -> Outcome tx) -> Outcome tx -> Outcome tx
forall a b. (a -> b) -> a -> b
$ do
        -- Spec: ̂Σ[j] ← σⱼ
        (StateChanged tx -> Outcome tx
forall tx. StateChanged tx -> Outcome tx
newState PartySignedSnapshot{$sel:snapshotNumber:NetworkConnected :: SnapshotNumber
snapshotNumber = Snapshot tx
snapshot.number, $sel:party:NetworkConnected :: Party
party = Party
otherParty, $sel:signature:NetworkConnected :: Signature (Snapshot tx)
signature = Signature (Snapshot tx)
snapshotSignature} <>) (Outcome tx -> Outcome tx) -> Outcome tx -> Outcome tx
forall a b. (a -> b) -> a -> b
$
          --       if ∀k ∈ [1..n] : (k,·) ∈ ̂Σ
          Snapshot tx
-> Map Party (Signature (Snapshot tx))
-> (Map Party (Signature (Snapshot tx)) -> Outcome tx)
-> Outcome tx
ifAllMembersHaveSigned Snapshot tx
snapshot Map Party (Signature (Snapshot tx))
sigs ((Map Party (Signature (Snapshot tx)) -> Outcome tx) -> Outcome tx)
-> (Map Party (Signature (Snapshot tx)) -> Outcome tx)
-> Outcome tx
forall a b. (a -> b) -> a -> b
$ \Map Party (Signature (Snapshot tx))
sigs' -> do
            -- Spec: σ̃ ← MS-ASig(kₕˢᵉᵗᵘᵖ,̂Σ)
            let multisig :: MultiSignature (Snapshot tx)
multisig = Map Party (Signature (Snapshot tx))
-> [Party] -> MultiSignature (Snapshot tx)
forall k a. Ord k => Map k (Signature a) -> [k] -> MultiSignature a
aggregateInOrder Map Party (Signature (Snapshot tx))
sigs' [Party]
parties
            -- Spec: η ← combine(𝑈ˆ)
            --       require MS-Verify(k ̃H, (cid‖v̂‖ŝ‖η), σ̃)
            MultiSignature (Snapshot tx)
-> ByteString -> Outcome tx -> Outcome tx
requireVerifiedMultisignature MultiSignature (Snapshot tx)
multisig ByteString
snapshotBytes (Outcome tx -> Outcome tx) -> Outcome tx -> Outcome tx
forall a b. (a -> b) -> a -> b
$
              do
                -- NOTE: Fix all the spec comments once specification is in place
                -- Spec: ̅S ← snObj(v̂, ŝ, Û, T̂, 𝑈𝛼, 𝑈𝜔)
                --       ̅S.σ ← ̃σ
                StateChanged tx -> Outcome tx
forall tx. StateChanged tx -> Outcome tx
newState SnapshotConfirmed{HeadId
$sel:headId:NetworkConnected :: HeadId
headId :: HeadId
headId, $sel:snapshot:NetworkConnected :: Maybe (Snapshot tx)
snapshot = Maybe (Snapshot tx)
forall a. Maybe a
Nothing, $sel:signatures:NetworkConnected :: MultiSignature (Snapshot tx)
signatures = MultiSignature (Snapshot tx)
multisig}
                -- Spec: if 𝑈𝛼 ≠ ⊥
                --         postTx (increment, v̂, ŝ, η)
                Outcome tx -> (Outcome tx -> Outcome tx) -> Outcome tx
forall a b. a -> (a -> b) -> b
& Snapshot tx
-> MultiSignature (Snapshot tx) -> Outcome tx -> Outcome tx
maybePostIncrementTx Snapshot tx
snapshot MultiSignature (Snapshot tx)
multisig
                -- Spec: if txω ≠ ⊥
                --         postTx (decrement, v̂, ŝ, η)
                Outcome tx -> (Outcome tx -> Outcome tx) -> Outcome tx
forall a b. a -> (a -> b) -> b
& Snapshot tx
-> MultiSignature (Snapshot tx) -> Outcome tx -> Outcome tx
maybePostDecrementTx Snapshot tx
snapshot MultiSignature (Snapshot tx)
multisig
                -- Spec: if leader(s + 1) = i ∧ T̂ ≠ ∅
                -- REVIEW: multicast (reqSn, v, ̅S.s + 1, T̂, S.𝑈𝛼, S.txω)
                Outcome tx -> (Outcome tx -> Outcome tx) -> Outcome tx
forall a b. a -> (a -> b) -> b
& Snapshot tx -> Outcome tx -> Outcome tx
maybeRequestNextSnapshot Snapshot tx
snapshot
 where
  seenSn :: SnapshotNumber
seenSn = SeenSnapshot tx -> SnapshotNumber
forall tx. SeenSnapshot tx -> SnapshotNumber
seenSnapshotNumber SeenSnapshot tx
seenSnapshot

  requireValidAckSn :: Outcome tx -> Outcome tx
requireValidAckSn Outcome tx
continue =
    if SnapshotNumber
sn SnapshotNumber -> [SnapshotNumber] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` [SnapshotNumber
seenSn, SnapshotNumber
seenSn SnapshotNumber -> SnapshotNumber -> SnapshotNumber
forall a. Num a => a -> a -> a
+ SnapshotNumber
1]
      then Outcome tx
continue
      else LogicError tx -> Outcome tx
forall tx. LogicError tx -> Outcome tx
Error (LogicError tx -> Outcome tx) -> LogicError tx -> Outcome tx
forall a b. (a -> b) -> a -> b
$ RequirementFailure tx -> LogicError tx
forall tx. RequirementFailure tx -> LogicError tx
RequireFailed (RequirementFailure tx -> LogicError tx)
-> RequirementFailure tx -> LogicError tx
forall a b. (a -> b) -> a -> b
$ AckSnNumberInvalid{$sel:requestedSn:ReqSnNumberInvalid :: SnapshotNumber
requestedSn = SnapshotNumber
sn, $sel:lastSeenSn:ReqSnNumberInvalid :: SnapshotNumber
lastSeenSn = SnapshotNumber
seenSn}

  waitOnSeenSnapshot :: (Snapshot tx
 -> Map Party (Signature (Snapshot tx)) -> ByteString -> Outcome tx)
-> Outcome tx
waitOnSeenSnapshot Snapshot tx
-> Map Party (Signature (Snapshot tx)) -> ByteString -> Outcome tx
continue =
    case SeenSnapshot tx
seenSnapshot of
      -- NOTE: Ignore any redundant AckSn for snapshots we have already seen as
      -- confirmed. This is for example happening if a party runs multiple
      -- instances of hydra-node using the same keys.
      LastSeenSnapshot{SnapshotNumber
lastSeen :: SnapshotNumber
$sel:lastSeen:NoSeenSnapshot :: forall tx. SeenSnapshot tx -> SnapshotNumber
lastSeen}
        | SnapshotNumber
sn SnapshotNumber -> SnapshotNumber -> Bool
forall a. Ord a => a -> a -> Bool
<= SnapshotNumber
lastSeen -> Outcome tx
forall tx. Outcome tx
noop
      SeenSnapshot{Snapshot tx
snapshot :: Snapshot tx
$sel:snapshot:NoSeenSnapshot :: forall tx. SeenSnapshot tx -> Snapshot tx
snapshot, $sel:signatories:NoSeenSnapshot :: forall tx. SeenSnapshot tx -> Map Party (Signature (Snapshot tx))
signatories = Map Party (Signature (Snapshot tx))
sigs, ByteString
signableBytes :: ByteString
$sel:signableBytes:NoSeenSnapshot :: forall tx. SeenSnapshot tx -> ByteString
signableBytes}
        | SnapshotNumber
seenSn SnapshotNumber -> SnapshotNumber -> Bool
forall a. Eq a => a -> a -> Bool
== SnapshotNumber
sn -> Snapshot tx
-> Map Party (Signature (Snapshot tx)) -> ByteString -> Outcome tx
continue Snapshot tx
snapshot Map Party (Signature (Snapshot tx))
sigs ByteString
signableBytes
      SeenSnapshot tx
_ -> WaitReason tx -> Outcome tx
forall tx. WaitReason tx -> Outcome tx
wait WaitReason tx
forall tx. WaitReason tx
WaitOnSeenSnapshot

  requireNotSignedYet :: Map Party (Signature (Snapshot tx)) -> Outcome tx -> Outcome tx
requireNotSignedYet Map Party (Signature (Snapshot tx))
sigs Outcome tx
continue =
    if Bool -> Bool
not (Party -> Map Party (Signature (Snapshot tx)) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member Party
otherParty Map Party (Signature (Snapshot tx))
sigs)
      then Outcome tx
continue
      else LogicError tx -> Outcome tx
forall tx. LogicError tx -> Outcome tx
Error (LogicError tx -> Outcome tx) -> LogicError tx -> Outcome tx
forall a b. (a -> b) -> a -> b
$ RequirementFailure tx -> LogicError tx
forall tx. RequirementFailure tx -> LogicError tx
RequireFailed (RequirementFailure tx -> LogicError tx)
-> RequirementFailure tx -> LogicError tx
forall a b. (a -> b) -> a -> b
$ SnapshotAlreadySigned{$sel:knownSignatures:ReqSnNumberInvalid :: [Party]
knownSignatures = Map Party (Signature (Snapshot tx)) -> [Party]
forall k a. Map k a -> [k]
Map.keys Map Party (Signature (Snapshot tx))
sigs, $sel:receivedSignature:ReqSnNumberInvalid :: Party
receivedSignature = Party
otherParty}

  ifAllMembersHaveSigned :: Snapshot tx
-> Map Party (Signature (Snapshot tx))
-> (Map Party (Signature (Snapshot tx)) -> Outcome tx)
-> Outcome tx
ifAllMembersHaveSigned Snapshot tx
snapshot Map Party (Signature (Snapshot tx))
sigs Map Party (Signature (Snapshot tx)) -> Outcome tx
cont =
    let sigs' :: Map Party (Signature (Snapshot tx))
sigs' = Party
-> Signature (Snapshot tx)
-> Map Party (Signature (Snapshot tx))
-> Map Party (Signature (Snapshot tx))
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Party
otherParty Signature (Snapshot tx)
snapshotSignature Map Party (Signature (Snapshot tx))
sigs
     in if Map Party (Signature (Snapshot tx)) -> Set Party
forall k a. Map k a -> Set k
Map.keysSet Map Party (Signature (Snapshot tx))
sigs' Set Party -> Set Party -> Bool
forall a. Eq a => a -> a -> Bool
== [Party] -> Set Party
forall a. Ord a => [a] -> Set a
Set.fromList [Party]
parties
          then Map Party (Signature (Snapshot tx)) -> Outcome tx
cont Map Party (Signature (Snapshot tx))
sigs'
          else
            StateChanged tx -> Outcome tx
forall tx. StateChanged tx -> Outcome tx
newState
              PartySignedSnapshot
                { $sel:snapshotNumber:NetworkConnected :: SnapshotNumber
snapshotNumber = Snapshot tx
snapshot.number
                , $sel:party:NetworkConnected :: Party
party = Party
otherParty
                , $sel:signature:NetworkConnected :: Signature (Snapshot tx)
signature = Signature (Snapshot tx)
snapshotSignature
                }

  requireVerifiedMultisignature :: MultiSignature (Snapshot tx)
-> ByteString -> Outcome tx -> Outcome tx
requireVerifiedMultisignature MultiSignature (Snapshot tx)
multisig ByteString
msg Outcome tx
cont =
    case [VerificationKey HydraKey]
-> MultiSignature (Snapshot tx) -> ByteString -> Verified
forall a.
[VerificationKey HydraKey]
-> MultiSignature a -> ByteString -> Verified
verifyMultiSignatureBytes [VerificationKey HydraKey]
vkeys MultiSignature (Snapshot tx)
multisig ByteString
msg of
      Verified
Verified -> Outcome tx
cont
      FailedKeys [VerificationKey HydraKey]
failures ->
        LogicError tx -> Outcome tx
forall tx. LogicError tx -> Outcome tx
Error (LogicError tx -> Outcome tx) -> LogicError tx -> Outcome tx
forall a b. (a -> b) -> a -> b
$
          RequirementFailure tx -> LogicError tx
forall tx. RequirementFailure tx -> LogicError tx
RequireFailed (RequirementFailure tx -> LogicError tx)
-> RequirementFailure tx -> LogicError tx
forall a b. (a -> b) -> a -> b
$
            InvalidMultisignature{$sel:multisig:ReqSnNumberInvalid :: Text
multisig = MultiSignature (Snapshot tx) -> Text
forall b a. (Show a, IsString b) => a -> b
show MultiSignature (Snapshot tx)
multisig, $sel:vkeys:ReqSnNumberInvalid :: [VerificationKey HydraKey]
vkeys = [VerificationKey HydraKey]
failures}
      Verified
KeyNumberMismatch ->
        LogicError tx -> Outcome tx
forall tx. LogicError tx -> Outcome tx
Error (LogicError tx -> Outcome tx) -> LogicError tx -> Outcome tx
forall a b. (a -> b) -> a -> b
$
          RequirementFailure tx -> LogicError tx
forall tx. RequirementFailure tx -> LogicError tx
RequireFailed (RequirementFailure tx -> LogicError tx)
-> RequirementFailure tx -> LogicError tx
forall a b. (a -> b) -> a -> b
$
            InvalidMultisignature{$sel:multisig:ReqSnNumberInvalid :: Text
multisig = MultiSignature (Snapshot tx) -> Text
forall b a. (Show a, IsString b) => a -> b
show MultiSignature (Snapshot tx)
multisig, [VerificationKey HydraKey]
vkeys :: [VerificationKey HydraKey]
$sel:vkeys:ReqSnNumberInvalid :: [VerificationKey HydraKey]
vkeys}

  maybeRequestNextSnapshot :: Snapshot tx -> Outcome tx -> Outcome tx
maybeRequestNextSnapshot Snapshot tx
previous Outcome tx
outcome = do
    let nextSn :: SnapshotNumber
nextSn = Snapshot tx
previous.number SnapshotNumber -> SnapshotNumber -> SnapshotNumber
forall a. Num a => a -> a -> a
+ SnapshotNumber
1
        (Maybe tx
nextDecommitTx, Maybe (TxIdType tx)
nextDeposit) =
          PendingDeposits tx
-> Maybe (TxIdType tx)
-> Maybe tx
-> Maybe (UTxOType tx)
-> (Maybe tx, Maybe (TxIdType tx))
forall tx.
IsTx tx =>
PendingDeposits tx
-> Maybe (TxIdType tx)
-> Maybe tx
-> Maybe (UTxOType tx)
-> (Maybe tx, Maybe (TxIdType tx))
selectNextIncrementalAction PendingDeposits tx
pendingDeposits Maybe (TxIdType tx)
currentDepositTxId Maybe tx
decommitTx Snapshot tx
previous.utxoToCommit
    if HeadParameters -> Party -> SnapshotNumber -> Bool
isLeader HeadParameters
parameters Party
party SnapshotNumber
nextSn Bool -> Bool -> Bool
&& Bool -> Bool
not (Seq tx -> Bool
forall a. Seq a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Seq tx
localTxs)
      then
        Outcome tx
outcome
          Outcome tx -> Outcome tx -> Outcome tx
forall a. Semigroup a => a -> a -> a
<> StateChanged tx -> Outcome tx
forall tx. StateChanged tx -> Outcome tx
newState SnapshotRequestDecided{$sel:snapshotNumber:NetworkConnected :: SnapshotNumber
snapshotNumber = SnapshotNumber
nextSn}
          Outcome tx -> Outcome tx -> Outcome tx
forall a. Semigroup a => a -> a -> a
<> Effect tx -> Outcome tx
forall tx. Effect tx -> Outcome tx
cause (Message tx -> Effect tx
forall tx. Message tx -> Effect tx
NetworkEffect (Message tx -> Effect tx) -> Message tx -> Effect tx
forall a b. (a -> b) -> a -> b
$ SnapshotVersion
-> SnapshotNumber
-> [TxIdType tx]
-> Maybe tx
-> Maybe (TxIdType tx)
-> Message tx
forall tx.
SnapshotVersion
-> SnapshotNumber
-> [TxIdType tx]
-> Maybe tx
-> Maybe (TxIdType tx)
-> Message tx
ReqSn SnapshotVersion
version SnapshotNumber
nextSn (Seq (TxIdType tx) -> [TxIdType tx]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Seq (TxIdType tx) -> [TxIdType tx])
-> Seq (TxIdType tx) -> [TxIdType tx]
forall a b. (a -> b) -> a -> b
$ tx -> TxIdType tx
forall tx. IsTx tx => tx -> TxIdType tx
txId (tx -> TxIdType tx) -> Seq tx -> Seq (TxIdType tx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Seq tx -> Seq tx
forall a. Int -> Seq a -> Seq a
Seq.take Int
maxTxsPerSnapshot Seq tx
localTxs) Maybe tx
nextDecommitTx Maybe (TxIdType tx)
nextDeposit)
      else Outcome tx
outcome

  maybePostIncrementTx :: Snapshot tx
-> MultiSignature (Snapshot tx) -> Outcome tx -> Outcome tx
maybePostIncrementTx snapshot :: Snapshot tx
snapshot@Snapshot{Maybe (UTxOType tx)
$sel:utxoToCommit:Snapshot :: forall tx. Snapshot tx -> Maybe (UTxOType tx)
utxoToCommit :: Maybe (UTxOType tx)
utxoToCommit, $sel:depositTxId:Snapshot :: forall tx. Snapshot tx -> Maybe (TxIdType tx)
depositTxId = Maybe (TxIdType tx)
signedDepositTxId} MultiSignature (Snapshot tx)
signatures Outcome tx
outcome =
    -- NOTE: use the snapshot's own deposit and not 'currentDepositTxId'. The
    -- latter can be set by a 'DepositActivated' during the ack flow of an
    -- unrelated snapshot, and only the deposit bound into the signed snapshot
    -- can be claimed by an increment on-chain.
    case (Maybe (TxIdType tx)
signedDepositTxId, Maybe (UTxOType tx)
utxoToCommit) of
      (Just TxIdType tx
depositTxId, Just UTxOType tx
_) ->
        case TxIdType tx -> PendingDeposits tx -> Maybe (Deposit tx)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TxIdType tx
depositTxId PendingDeposits tx
pendingDeposits of
          Just Deposit{UTxOType tx
$sel:deposited:Deposit :: forall tx. Deposit tx -> UTxOType tx
deposited :: UTxOType tx
deposited} ->
            Outcome tx
outcome
              Outcome tx -> Outcome tx -> Outcome tx
forall a. Semigroup a => a -> a -> a
<> StateChanged tx -> Outcome tx
forall tx. StateChanged tx -> Outcome tx
newState CommitApproved{HeadId
$sel:headId:NetworkConnected :: HeadId
headId :: HeadId
headId, $sel:utxoToCommit:NetworkConnected :: UTxOType tx
utxoToCommit = UTxOType tx
deposited}
              Outcome tx -> Outcome tx -> Outcome tx
forall a. Semigroup a => a -> a -> a
<> Effect tx -> Outcome tx
forall tx. Effect tx -> Outcome tx
cause
                OnChainEffect
                  { $sel:postChainTx:ClientEffect :: PostChainTx tx
postChainTx =
                      IncrementTx
                        { HeadSeed
headSeed :: HeadSeed
$sel:headSeed:InitTx :: HeadSeed
headSeed
                        , HeadId
headId :: HeadId
$sel:headId:InitTx :: HeadId
headId
                        , $sel:headParameters:InitTx :: HeadParameters
headParameters = HeadParameters
parameters
                        , $sel:incrementingSnapshot:InitTx :: ConfirmedSnapshot tx
incrementingSnapshot = ConfirmedSnapshot{Snapshot tx
$sel:snapshot:InitialSnapshot :: Snapshot tx
snapshot :: Snapshot tx
snapshot, MultiSignature (Snapshot tx)
signatures :: MultiSignature (Snapshot tx)
$sel:signatures:InitialSnapshot :: MultiSignature (Snapshot tx)
signatures}
                        , TxIdType tx
depositTxId :: TxIdType tx
$sel:depositTxId:InitTx :: TxIdType tx
depositTxId
                        }
                  }
          Maybe (Deposit tx)
Nothing -> Outcome tx
outcome
      (Maybe (TxIdType tx), Maybe (UTxOType tx))
_ -> Outcome tx
outcome

  maybePostDecrementTx :: Snapshot tx
-> MultiSignature (Snapshot tx) -> Outcome tx -> Outcome tx
maybePostDecrementTx snapshot :: Snapshot tx
snapshot@Snapshot{Maybe (UTxOType tx)
$sel:utxoToDecommit:Snapshot :: forall tx. Snapshot tx -> Maybe (UTxOType tx)
utxoToDecommit :: Maybe (UTxOType tx)
utxoToDecommit} MultiSignature (Snapshot tx)
signatures Outcome tx
outcome =
    case (Maybe tx
decommitTx, Maybe (UTxOType tx)
utxoToDecommit) of
      (Just tx
tx, Just UTxOType tx
utxo) ->
        Outcome tx
outcome
          Outcome tx -> Outcome tx -> Outcome tx
forall a. Semigroup a => a -> a -> a
<> StateChanged tx -> Outcome tx
forall tx. StateChanged tx -> Outcome tx
newState
            DecommitApproved
              { HeadId
$sel:headId:NetworkConnected :: HeadId
headId :: HeadId
headId
              , $sel:decommitTxId:NetworkConnected :: TxIdType tx
decommitTxId = tx -> TxIdType tx
forall tx. IsTx tx => tx -> TxIdType tx
txId tx
tx
              , $sel:utxoToDecommit:NetworkConnected :: UTxOType tx
utxoToDecommit = UTxOType tx
utxo
              }
          Outcome tx -> Outcome tx -> Outcome tx
forall a. Semigroup a => a -> a -> a
<> Effect tx -> Outcome tx
forall tx. Effect tx -> Outcome tx
cause
            OnChainEffect
              { $sel:postChainTx:ClientEffect :: PostChainTx tx
postChainTx =
                  DecrementTx
                    { HeadSeed
headSeed :: HeadSeed
$sel:headSeed:InitTx :: HeadSeed
headSeed
                    , HeadId
headId :: HeadId
$sel:headId:InitTx :: HeadId
headId
                    , $sel:headParameters:InitTx :: HeadParameters
headParameters = HeadParameters
parameters
                    , $sel:decrementingSnapshot:InitTx :: ConfirmedSnapshot tx
decrementingSnapshot = ConfirmedSnapshot{Snapshot tx
$sel:snapshot:InitialSnapshot :: Snapshot tx
snapshot :: Snapshot tx
snapshot, MultiSignature (Snapshot tx)
$sel:signatures:InitialSnapshot :: MultiSignature (Snapshot tx)
signatures :: MultiSignature (Snapshot tx)
signatures}
                    }
              }
      (Maybe tx, Maybe (UTxOType tx))
_ -> Outcome tx
outcome

  vkeys :: [VerificationKey HydraKey]
vkeys = Party -> VerificationKey HydraKey
vkey (Party -> VerificationKey HydraKey)
-> [Party] -> [VerificationKey HydraKey]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Party]
parties

  OpenState
    { $sel:parameters:OpenState :: forall tx. OpenState tx -> HeadParameters
parameters = parameters :: HeadParameters
parameters@HeadParameters{[Party]
$sel:parties:HeadParameters :: HeadParameters -> [Party]
parties :: [Party]
parties}
    , CoordinatedHeadState tx
$sel:coordinatedHeadState:OpenState :: forall tx. OpenState tx -> CoordinatedHeadState tx
coordinatedHeadState :: CoordinatedHeadState tx
coordinatedHeadState
    , HeadId
$sel:headId:OpenState :: forall tx. OpenState tx -> HeadId
headId :: HeadId
headId
    , HeadSeed
headSeed :: HeadSeed
$sel:headSeed:OpenState :: forall tx. OpenState tx -> HeadSeed
headSeed
    } = OpenState tx
openState

  CoordinatedHeadState{SeenSnapshot tx
$sel:seenSnapshot:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> SeenSnapshot tx
seenSnapshot :: SeenSnapshot tx
seenSnapshot, Seq tx
$sel:localTxs:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> Seq tx
localTxs :: Seq tx
localTxs, Maybe tx
$sel:decommitTx:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> Maybe tx
decommitTx :: Maybe tx
decommitTx, Maybe (TxIdType tx)
$sel:currentDepositTxId:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> Maybe (TxIdType tx)
currentDepositTxId :: Maybe (TxIdType tx)
currentDepositTxId, SnapshotVersion
$sel:version:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> SnapshotVersion
version :: SnapshotVersion
version} = CoordinatedHeadState tx
coordinatedHeadState

-- | Client request to recover deposited UTxO.
--
-- __Transition__: 'OpenState' → 'OpenState'
-- Client request to recover a deposit by posting a recover transaction on-chain.
-- Works in any head state (Open, Closed, or Idle after fanout). Deposits from a
-- previous head are never cleared from 'pendingDeposits' on fanout, so recovery
-- remains available after a head closes. A new head only sees its own deposits via
-- 'depositsForHead', so old deposits are never accidentally ingested into L2.
-- On-chain, the deposit validator only enforces that the deadline has passed and
-- that the recovered outputs match the originals — it does not require the head to
-- still be active.
onClientRecover ::
  IsTx tx =>
  ChainSlot ->
  PendingDeposits tx ->
  TxIdType tx ->
  Outcome tx
onClientRecover :: forall tx.
IsTx tx =>
ChainSlot -> PendingDeposits tx -> TxIdType tx -> Outcome tx
onClientRecover ChainSlot
currentSlot PendingDeposits tx
pendingDeposits TxIdType tx
recoverTxId =
  case TxIdType tx -> PendingDeposits tx -> Maybe (Deposit tx)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TxIdType tx
recoverTxId PendingDeposits tx
pendingDeposits of
    Maybe (Deposit tx)
Nothing ->
      LogicError tx -> Outcome tx
forall tx. LogicError tx -> Outcome tx
Error (LogicError tx -> Outcome tx) -> LogicError tx -> Outcome tx
forall a b. (a -> b) -> a -> b
$ RequirementFailure tx -> LogicError tx
forall tx. RequirementFailure tx -> LogicError tx
RequireFailed RequirementFailure tx
forall tx. RequirementFailure tx
NoMatchingDeposit
    Just Deposit{HeadId
headId :: HeadId
$sel:headId:Deposit :: forall tx. Deposit tx -> HeadId
headId, UTxOType tx
$sel:deposited:Deposit :: forall tx. Deposit tx -> UTxOType tx
deposited :: UTxOType tx
deposited} ->
      [Effect tx] -> Outcome tx
forall tx. [Effect tx] -> Outcome tx
causes
        [ OnChainEffect
            { $sel:postChainTx:ClientEffect :: PostChainTx tx
postChainTx =
                RecoverTx
                  { HeadId
$sel:headId:InitTx :: HeadId
headId :: HeadId
headId
                  , $sel:recoverTxId:InitTx :: TxIdType tx
recoverTxId = TxIdType tx
recoverTxId
                  , -- XXX: Why is this called deadline?
                    $sel:deadline:InitTx :: ChainSlot
deadline = ChainSlot
currentSlot
                  , $sel:recoverUTxO:InitTx :: UTxOType tx
recoverUTxO = UTxOType tx
deposited
                  }
            }
        ]

-- | Client request to decommit UTxO from the head.
--
-- Only possible if there is no decommit _in flight_ and if the tx applies
-- cleanly to the local ledger state.
--
-- __Transition__: 'OpenState' → 'OpenState'
onOpenClientDecommit ::
  IsTx tx =>
  HeadId ->
  Ledger tx ->
  ChainSlot ->
  CoordinatedHeadState tx ->
  -- | Decommit transaction.
  tx ->
  Outcome tx
onOpenClientDecommit :: forall tx.
IsTx tx =>
HeadId
-> Ledger tx
-> ChainSlot
-> CoordinatedHeadState tx
-> tx
-> Outcome tx
onOpenClientDecommit HeadId
headId Ledger tx
ledger ChainSlot
currentSlot CoordinatedHeadState tx
coordinatedHeadState tx
decommitTx =
  Outcome tx -> Outcome tx
checkNoDecommitInFlight (Outcome tx -> Outcome tx) -> Outcome tx -> Outcome tx
forall a b. (a -> b) -> a -> b
$
    Outcome tx -> Outcome tx
checkValidDecommitTx (Outcome tx -> Outcome tx) -> Outcome tx -> Outcome tx
forall a b. (a -> b) -> a -> b
$
      HeadId -> UTxOType tx -> tx -> Outcome tx -> Outcome tx
forall tx.
IsTx tx =>
HeadId -> UTxOType tx -> tx -> Outcome tx -> Outcome tx
requireDecommitOutputs HeadId
headId UTxOType tx
localUTxO tx
decommitTx (Outcome tx -> Outcome tx) -> Outcome tx -> Outcome tx
forall a b. (a -> b) -> a -> b
$
        Effect tx -> Outcome tx
forall tx. Effect tx -> Outcome tx
cause (Message tx -> Effect tx
forall tx. Message tx -> Effect tx
NetworkEffect ReqDec{$sel:transaction:ReqTx :: tx
transaction = tx
decommitTx})
 where
  checkNoDecommitInFlight :: Outcome tx -> Outcome tx
checkNoDecommitInFlight Outcome tx
continue =
    case Maybe tx
mExistingDecommitTx of
      Just tx
existingDecommitTx ->
        StateChanged tx -> Outcome tx
forall tx. StateChanged tx -> Outcome tx
newState
          DecommitInvalid
            { HeadId
$sel:headId:NetworkConnected :: HeadId
headId :: HeadId
headId
            , tx
decommitTx :: tx
$sel:decommitTx:NetworkConnected :: tx
decommitTx
            , $sel:decommitInvalidReason:NetworkConnected :: DecommitInvalidReason tx
decommitInvalidReason =
                ServerOutput.DecommitAlreadyInFlight
                  { $sel:otherDecommitTxId:DecommitTxInvalid :: TxIdType tx
otherDecommitTxId = tx -> TxIdType tx
forall tx. IsTx tx => tx -> TxIdType tx
txId tx
existingDecommitTx
                  }
            }
      Maybe tx
Nothing -> Outcome tx
continue

  checkValidDecommitTx :: Outcome tx -> Outcome tx
checkValidDecommitTx Outcome tx
cont =
    case Ledger tx
-> ChainSlot
-> UTxOType tx
-> [tx]
-> Either (tx, ValidationError) (UTxOType tx)
forall tx.
Ledger tx
-> ChainSlot
-> UTxOType tx
-> [tx]
-> Either (tx, ValidationError) (UTxOType tx)
applyTransactions Ledger tx
ledger ChainSlot
currentSlot UTxOType tx
localUTxO [tx
decommitTx] of
      Left (tx
_, ValidationError
err) ->
        StateChanged tx -> Outcome tx
forall tx. StateChanged tx -> Outcome tx
newState
          DecommitInvalid
            { HeadId
$sel:headId:NetworkConnected :: HeadId
headId :: HeadId
headId
            , tx
decommitTx :: tx
$sel:decommitTx:NetworkConnected :: tx
decommitTx
            , $sel:decommitInvalidReason:NetworkConnected :: DecommitInvalidReason tx
decommitInvalidReason =
                ServerOutput.DecommitTxInvalid
                  { UTxOType tx
localUTxO :: UTxOType tx
$sel:localUTxO:DecommitTxInvalid :: UTxOType tx
localUTxO
                  , $sel:validationError:DecommitTxInvalid :: ValidationError
validationError = ValidationError
err
                  }
            }
      Right UTxOType tx
_ -> Outcome tx
cont

  CoordinatedHeadState{$sel:decommitTx:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> Maybe tx
decommitTx = Maybe tx
mExistingDecommitTx, UTxOType tx
$sel:localUTxO:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> UTxOType tx
localUTxO :: UTxOType tx
localUTxO} = CoordinatedHeadState tx
coordinatedHeadState

-- | Process the request 'ReqDec' to decommit something from the Open head.
--
-- __Transition__: 'OpenState' → 'OpenState'
--
-- When node receives 'ReqDec' network message it should:
-- - Check there is no decommit in flight:
--   - Alter it's state to record what is to be decommitted
--   - Issue a server output 'DecommitRequested' with the relevant utxo
--   - Issue a 'ReqSn' since all parties need to agree in order for decommit to
--   be taken out of a Head.
-- - Check if we are the leader
onOpenNetworkReqDec ::
  IsTx tx =>
  Environment ->
  Ledger tx ->
  TTL ->
  ChainSlot ->
  PendingDeposits tx ->
  OpenState tx ->
  tx ->
  Outcome tx
onOpenNetworkReqDec :: forall tx.
IsTx tx =>
Environment
-> Ledger tx
-> TTL
-> ChainSlot
-> PendingDeposits tx
-> OpenState tx
-> tx
-> Outcome tx
onOpenNetworkReqDec Environment
env Ledger tx
ledger TTL
ttl ChainSlot
currentSlot PendingDeposits tx
pendingDeposits OpenState tx
openState tx
decommitTx =
  -- Spec: wait 𝑈𝛼 = ∅ ^ txω =⊥ ∧ L̂ ◦ tx ≠ ⊥
  Outcome tx -> Outcome tx
waitOnApplicableDecommit (Outcome tx -> Outcome tx) -> Outcome tx -> Outcome tx
forall a b. (a -> b) -> a -> b
$
    HeadId -> UTxOType tx -> tx -> Outcome tx -> Outcome tx
forall tx.
IsTx tx =>
HeadId -> UTxOType tx -> tx -> Outcome tx -> Outcome tx
requireDecommitOutputs HeadId
headId UTxOType tx
localUTxO tx
decommitTx (Outcome tx -> Outcome tx) -> Outcome tx -> Outcome tx
forall a b. (a -> b) -> a -> b
$
      -- Spec: L̂ ← L̂ ◦ tx \ outputs(tx)
      -- Spec: txω ← tx
      StateChanged tx -> Outcome tx
forall tx. StateChanged tx -> Outcome tx
newState DecommitRecorded{HeadId
$sel:headId:NetworkConnected :: HeadId
headId :: HeadId
headId, tx
$sel:decommitTx:NetworkConnected :: tx
decommitTx :: tx
decommitTx}
        -- Spec: if ŝ = ̅S.s ∧ leader(̅S.s + 1) = i
        --         multicast (reqSn, v, ̅S.s + 1, T̂ , 𝑈𝛼, txω )
        Outcome tx -> Outcome tx -> Outcome tx
forall a. Semigroup a => a -> a -> a
<> Outcome tx
maybeRequestSnapshot
 where
  -- Spec: wait 𝑈𝛼 = ∅. A pending commit (deposit) must settle before a
  -- decommit can be recorded, otherwise a later snapshot would carry both (see
  -- the symmetric guard on 'DepositActivated', which blocks a deposit while a
  -- decommit is pending). While ttl remains we wait, so the decommit proceeds
  -- once the increment finalises and clears 'currentDepositTxId'; once ttl is
  -- exhausted we reject with 'DepositInFlight' (mirroring the branches below) so
  -- the client can act (e.g. recover the deposit) instead of the request being
  -- silently dropped.
  --
  -- Via 'existingDeposit', not 'currentDepositTxId' on its own: that field is not
  -- cleared when a deposit expires or is recovered, so reading it directly would
  -- block every later decommit on a deposit that can never settle, and the wait
  -- would never resolve. Only a registered, unexpired deposit holds a decommit back.
  waitOnApplicableDecommit :: Outcome tx -> Outcome tx
waitOnApplicableDecommit Outcome tx
cont
    | Just (TxIdType tx
depositTxId, Deposit tx
deposit) <- PendingDeposits tx
-> Maybe (TxIdType tx) -> Maybe (TxIdType tx, Deposit tx)
forall tx.
IsTx tx =>
PendingDeposits tx
-> Maybe (TxIdType tx) -> Maybe (TxIdType tx, Deposit tx)
existingDeposit PendingDeposits tx
pendingDeposits Maybe (TxIdType tx)
currentDepositTxId =
        let commitUTxO :: UTxOType tx
commitUTxO = Deposit tx
deposit.deposited
         in if TTL
ttl TTL -> TTL -> Bool
forall a. Ord a => a -> a -> Bool
> TTL
0
              then WaitReason tx -> Outcome tx
forall tx. WaitReason tx -> Outcome tx
wait (WaitReason tx -> Outcome tx) -> WaitReason tx -> Outcome tx
forall a b. (a -> b) -> a -> b
$ WaitOnUnresolvedCommit{UTxOType tx
commitUTxO :: UTxOType tx
$sel:commitUTxO:WaitOnNotApplicableTx :: UTxOType tx
commitUTxO}
              else
                StateChanged tx -> Outcome tx
forall tx. StateChanged tx -> Outcome tx
newState
                  DecommitInvalid
                    { HeadId
$sel:headId:NetworkConnected :: HeadId
headId :: HeadId
headId
                    , tx
$sel:decommitTx:NetworkConnected :: tx
decommitTx :: tx
decommitTx
                    , $sel:decommitInvalidReason:NetworkConnected :: DecommitInvalidReason tx
decommitInvalidReason = DepositInFlight{TxIdType tx
depositTxId :: TxIdType tx
$sel:depositTxId:DecommitTxInvalid :: TxIdType tx
depositTxId, UTxOType tx
commitUTxO :: UTxOType tx
$sel:commitUTxO:DecommitTxInvalid :: UTxOType tx
commitUTxO}
                    }
    | Bool
otherwise =
        case Maybe tx
mExistingDecommitTx of
          Maybe tx
Nothing ->
            case ChainSlot
-> UTxOType tx
-> [tx]
-> Either (tx, ValidationError) (UTxOType tx)
applyTransactions ChainSlot
currentSlot UTxOType tx
localUTxO [tx
decommitTx] of
              Right UTxOType tx
_ -> Outcome tx
cont
              Left (tx
_, ValidationError
validationError)
                | TTL
ttl TTL -> TTL -> Bool
forall a. Ord a => a -> a -> Bool
> TTL
0 ->
                    WaitReason tx -> Outcome tx
forall tx. WaitReason tx -> Outcome tx
wait (WaitReason tx -> Outcome tx) -> WaitReason tx -> Outcome tx
forall a b. (a -> b) -> a -> b
$
                      DecommitInvalidReason tx -> WaitReason tx
forall tx. DecommitInvalidReason tx -> WaitReason tx
WaitOnNotApplicableDecommitTx
                        ServerOutput.DecommitTxInvalid{UTxOType tx
$sel:localUTxO:DecommitTxInvalid :: UTxOType tx
localUTxO :: UTxOType tx
localUTxO, ValidationError
$sel:validationError:DecommitTxInvalid :: ValidationError
validationError :: ValidationError
validationError}
                | Bool
otherwise ->
                    StateChanged tx -> Outcome tx
forall tx. StateChanged tx -> Outcome tx
newState
                      DecommitInvalid
                        { HeadId
$sel:headId:NetworkConnected :: HeadId
headId :: HeadId
headId
                        , tx
$sel:decommitTx:NetworkConnected :: tx
decommitTx :: tx
decommitTx
                        , $sel:decommitInvalidReason:NetworkConnected :: DecommitInvalidReason tx
decommitInvalidReason =
                            ServerOutput.DecommitTxInvalid{UTxOType tx
$sel:localUTxO:DecommitTxInvalid :: UTxOType tx
localUTxO :: UTxOType tx
localUTxO, ValidationError
$sel:validationError:DecommitTxInvalid :: ValidationError
validationError :: ValidationError
validationError}
                        }
          Just tx
existingDecommitTx
            | TTL
ttl TTL -> TTL -> Bool
forall a. Ord a => a -> a -> Bool
> TTL
0 ->
                WaitReason tx -> Outcome tx
forall tx. WaitReason tx -> Outcome tx
wait (WaitReason tx -> Outcome tx) -> WaitReason tx -> Outcome tx
forall a b. (a -> b) -> a -> b
$
                  DecommitInvalidReason tx -> WaitReason tx
forall tx. DecommitInvalidReason tx -> WaitReason tx
WaitOnNotApplicableDecommitTx
                    DecommitAlreadyInFlight{$sel:otherDecommitTxId:DecommitTxInvalid :: TxIdType tx
otherDecommitTxId = tx -> TxIdType tx
forall tx. IsTx tx => tx -> TxIdType tx
txId tx
existingDecommitTx}
            | Bool
otherwise ->
                StateChanged tx -> Outcome tx
forall tx. StateChanged tx -> Outcome tx
newState
                  DecommitInvalid
                    { HeadId
$sel:headId:NetworkConnected :: HeadId
headId :: HeadId
headId
                    , tx
$sel:decommitTx:NetworkConnected :: tx
decommitTx :: tx
decommitTx
                    , $sel:decommitInvalidReason:NetworkConnected :: DecommitInvalidReason tx
decommitInvalidReason =
                        DecommitAlreadyInFlight{$sel:otherDecommitTxId:DecommitTxInvalid :: TxIdType tx
otherDecommitTxId = tx -> TxIdType tx
forall tx. IsTx tx => tx -> TxIdType tx
txId tx
existingDecommitTx}
                    }

  maybeRequestSnapshot :: Outcome tx
maybeRequestSnapshot =
    if Bool -> Bool
not (SeenSnapshot tx -> Bool
forall tx. SeenSnapshot tx -> Bool
snapshotInFlight SeenSnapshot tx
seenSnapshot) Bool -> Bool -> Bool
&& HeadParameters -> Party -> SnapshotNumber -> Bool
isLeader HeadParameters
parameters Party
party SnapshotNumber
nextSn
      then Effect tx -> Outcome tx
forall tx. Effect tx -> Outcome tx
cause (Message tx -> Effect tx
forall tx. Message tx -> Effect tx
NetworkEffect (SnapshotVersion
-> SnapshotNumber
-> [TxIdType tx]
-> Maybe tx
-> Maybe (TxIdType tx)
-> Message tx
forall tx.
SnapshotVersion
-> SnapshotNumber
-> [TxIdType tx]
-> Maybe tx
-> Maybe (TxIdType tx)
-> Message tx
ReqSn SnapshotVersion
version SnapshotNumber
nextSn (Seq (TxIdType tx) -> [TxIdType tx]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Seq (TxIdType tx) -> [TxIdType tx])
-> Seq (TxIdType tx) -> [TxIdType tx]
forall a b. (a -> b) -> a -> b
$ tx -> TxIdType tx
forall tx. IsTx tx => tx -> TxIdType tx
txId (tx -> TxIdType tx) -> Seq tx -> Seq (TxIdType tx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Seq tx -> Seq tx
forall a. Int -> Seq a -> Seq a
Seq.take Int
maxTxsPerSnapshot Seq tx
localTxs) (tx -> Maybe tx
forall a. a -> Maybe a
Just tx
decommitTx) Maybe (TxIdType tx)
forall a. Maybe a
Nothing))
      else Outcome tx
forall tx. Outcome tx
noop

  Environment{Party
$sel:party:Environment :: Environment -> Party
party :: Party
party} = Environment
env

  Ledger{ChainSlot
-> UTxOType tx
-> [tx]
-> Either (tx, ValidationError) (UTxOType tx)
$sel:applyTransactions:Ledger :: forall tx.
Ledger tx
-> ChainSlot
-> UTxOType tx
-> [tx]
-> Either (tx, ValidationError) (UTxOType tx)
applyTransactions :: ChainSlot
-> UTxOType tx
-> [tx]
-> Either (tx, ValidationError) (UTxOType tx)
applyTransactions} = Ledger tx
ledger

  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

  nextSn :: SnapshotNumber
nextSn = SnapshotNumber
number SnapshotNumber -> SnapshotNumber -> SnapshotNumber
forall a. Num a => a -> a -> a
+ SnapshotNumber
1

  CoordinatedHeadState
    { $sel:decommitTx:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> Maybe tx
decommitTx = Maybe tx
mExistingDecommitTx
    , ConfirmedSnapshot tx
$sel:confirmedSnapshot:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> ConfirmedSnapshot tx
confirmedSnapshot :: ConfirmedSnapshot tx
confirmedSnapshot
    , Seq tx
$sel:localTxs:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> Seq tx
localTxs :: Seq tx
localTxs
    , UTxOType tx
$sel:localUTxO:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> UTxOType tx
localUTxO :: UTxOType tx
localUTxO
    , SnapshotVersion
$sel:version:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> SnapshotVersion
version :: SnapshotVersion
version
    , SeenSnapshot tx
$sel:seenSnapshot:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> SeenSnapshot tx
seenSnapshot :: SeenSnapshot tx
seenSnapshot
    , Maybe (TxIdType tx)
$sel:currentDepositTxId:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> Maybe (TxIdType tx)
currentDepositTxId :: Maybe (TxIdType tx)
currentDepositTxId
    } = CoordinatedHeadState tx
coordinatedHeadState

  OpenState
    { HeadId
$sel:headId:OpenState :: forall tx. OpenState tx -> HeadId
headId :: HeadId
headId
    , HeadParameters
$sel:parameters:OpenState :: forall tx. OpenState tx -> HeadParameters
parameters :: HeadParameters
parameters
    , CoordinatedHeadState tx
$sel:coordinatedHeadState:OpenState :: forall tx. OpenState tx -> CoordinatedHeadState tx
coordinatedHeadState :: CoordinatedHeadState tx
coordinatedHeadState
    } = OpenState tx
openState

determineNextDepositStatus :: Ord (TxIdType tx) => Environment -> PendingDeposits tx -> UTCTime -> PendingDeposits tx
determineNextDepositStatus :: forall tx.
Ord (TxIdType tx) =>
Environment -> PendingDeposits tx -> UTCTime -> PendingDeposits tx
determineNextDepositStatus Environment
env Map (TxIdType tx) (Deposit tx)
pendingDeposits UTCTime
chainTime =
  (Map (TxIdType tx) (Deposit tx)
 -> TxIdType tx -> Deposit tx -> Map (TxIdType tx) (Deposit tx))
-> Map (TxIdType tx) (Deposit tx)
-> Map (TxIdType tx) (Deposit tx)
-> Map (TxIdType tx) (Deposit tx)
forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
Map.foldlWithKey Map (TxIdType tx) (Deposit tx)
-> TxIdType tx -> Deposit tx -> Map (TxIdType tx) (Deposit tx)
updateDeposit Map (TxIdType tx) (Deposit tx)
forall a. Monoid a => a
mempty Map (TxIdType tx) (Deposit tx)
pendingDeposits
 where
  updateDeposit :: Map (TxIdType tx) (Deposit tx)
-> TxIdType tx -> Deposit tx -> Map (TxIdType tx) (Deposit tx)
updateDeposit Map (TxIdType tx) (Deposit tx)
nextSelected TxIdType tx
depositTxId Deposit tx
deposit =
    let newStatus :: DepositStatus
newStatus = Deposit tx -> DepositStatus
determineStatus Deposit tx
deposit
        d' :: Deposit tx
d' = Deposit tx
deposit{status = newStatus}
     in TxIdType tx
-> Deposit tx
-> Map (TxIdType tx) (Deposit tx)
-> Map (TxIdType tx) (Deposit tx)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert TxIdType tx
depositTxId Deposit tx
d' Map (TxIdType tx) (Deposit tx)
nextSelected

  determineStatus :: Deposit tx -> DepositStatus
determineStatus Deposit{UTCTime
created :: UTCTime
$sel:created:Deposit :: forall tx. Deposit tx -> UTCTime
created, UTCTime
deadline :: UTCTime
$sel:deadline:Deposit :: forall tx. Deposit tx -> UTCTime
deadline}
    | UTCTime
chainTime UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
> UTCTime
deadline UTCTime -> NominalDiffTime -> UTCTime
`minusTime` DepositPeriod -> NominalDiffTime
toNominalDiffTime DepositPeriod
depositPeriod = DepositStatus
Expired
    | UTCTime
chainTime UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
> UTCTime
created UTCTime -> NominalDiffTime -> UTCTime
`plusTime` DepositPeriod -> NominalDiffTime
toNominalDiffTime DepositPeriod
depositActivation = DepositStatus
Active
    | Bool
otherwise = DepositStatus
Inactive

  minusTime :: UTCTime -> NominalDiffTime -> UTCTime
minusTime UTCTime
time NominalDiffTime
dt = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime (-NominalDiffTime
dt) UTCTime
time

  plusTime :: UTCTime -> NominalDiffTime -> UTCTime
plusTime = (NominalDiffTime -> UTCTime -> UTCTime)
-> UTCTime -> NominalDiffTime -> UTCTime
forall a b c. (a -> b -> c) -> b -> a -> c
flip NominalDiffTime -> UTCTime -> UTCTime
addUTCTime

  Environment{DepositPeriod
$sel:depositPeriod:Environment :: Environment -> DepositPeriod
depositPeriod :: DepositPeriod
depositPeriod, DepositPeriod
depositActivation :: DepositPeriod
$sel:depositActivation:Environment :: Environment -> DepositPeriod
depositActivation} = Environment
env

-- | Process the chain (and time) advancing in any head state.
--
-- __Transition__: 'AnyState' → 'AnyState'
--
-- This is primarily used to track deposits status changes.
onChainTick :: IsTx tx => Environment -> PendingDeposits tx -> UTCTime -> Outcome tx
onChainTick :: forall tx.
IsTx tx =>
Environment -> PendingDeposits tx -> UTCTime -> Outcome tx
onChainTick Environment
env PendingDeposits tx
pendingDeposits UTCTime
chainTime =
  PendingDeposits tx -> Outcome tx
mkDepositActivated PendingDeposits tx
newActive Outcome tx -> Outcome tx -> Outcome tx
forall a. Semigroup a => a -> a -> a
<> PendingDeposits tx -> Outcome tx
mkDepositExpired PendingDeposits tx
newExpired
 where
  -- XXX: This is a bit messy
  newActive :: PendingDeposits tx
newActive = PendingDeposits tx -> PendingDeposits tx -> PendingDeposits tx
forall k a b. Ord k => Map k a -> Map k b -> Map k a
Map.difference PendingDeposits tx
nextActive PendingDeposits tx
pendingActive

  newExpired :: PendingDeposits tx
newExpired = PendingDeposits tx -> PendingDeposits tx -> PendingDeposits tx
forall k a b. Ord k => Map k a -> Map k b -> Map k a
Map.difference PendingDeposits tx
nextExpired PendingDeposits tx
pendingExpired

  pendingActive :: PendingDeposits tx
pendingActive = (Deposit tx -> Bool) -> PendingDeposits tx -> PendingDeposits tx
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (\Deposit{DepositStatus
$sel:status:Deposit :: forall tx. Deposit tx -> DepositStatus
status :: DepositStatus
status} -> DepositStatus
status DepositStatus -> DepositStatus -> Bool
forall a. Eq a => a -> a -> Bool
== DepositStatus
Active) PendingDeposits tx
pendingDeposits

  pendingExpired :: PendingDeposits tx
pendingExpired = (Deposit tx -> Bool) -> PendingDeposits tx -> PendingDeposits tx
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (\Deposit{DepositStatus
$sel:status:Deposit :: forall tx. Deposit tx -> DepositStatus
status :: DepositStatus
status} -> DepositStatus
status DepositStatus -> DepositStatus -> Bool
forall a. Eq a => a -> a -> Bool
== DepositStatus
Expired) PendingDeposits tx
pendingDeposits

  nextDeposits :: PendingDeposits tx
nextDeposits = Environment -> PendingDeposits tx -> UTCTime -> PendingDeposits tx
forall tx.
Ord (TxIdType tx) =>
Environment -> PendingDeposits tx -> UTCTime -> PendingDeposits tx
determineNextDepositStatus Environment
env PendingDeposits tx
pendingDeposits UTCTime
chainTime

  nextActive :: PendingDeposits tx
nextActive = (Deposit tx -> Bool) -> PendingDeposits tx -> PendingDeposits tx
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (\Deposit{DepositStatus
$sel:status:Deposit :: forall tx. Deposit tx -> DepositStatus
status :: DepositStatus
status} -> DepositStatus
status DepositStatus -> DepositStatus -> Bool
forall a. Eq a => a -> a -> Bool
== DepositStatus
Active) PendingDeposits tx
nextDeposits

  nextExpired :: PendingDeposits tx
nextExpired = (Deposit tx -> Bool) -> PendingDeposits tx -> PendingDeposits tx
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (\Deposit{DepositStatus
$sel:status:Deposit :: forall tx. Deposit tx -> DepositStatus
status :: DepositStatus
status} -> DepositStatus
status DepositStatus -> DepositStatus -> Bool
forall a. Eq a => a -> a -> Bool
== DepositStatus
Expired) PendingDeposits tx
nextDeposits

  mkDepositActivated :: PendingDeposits tx -> Outcome tx
mkDepositActivated PendingDeposits tx
m = [StateChanged tx] -> Outcome tx
forall tx. [StateChanged tx] -> Outcome tx
changes ([StateChanged tx] -> Outcome tx)
-> ((TxIdType tx -> Deposit tx -> [StateChanged tx])
    -> [StateChanged tx])
-> (TxIdType tx -> Deposit tx -> [StateChanged tx])
-> Outcome tx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((TxIdType tx -> Deposit tx -> [StateChanged tx])
-> PendingDeposits tx -> [StateChanged tx]
forall m k a. Monoid m => (k -> a -> m) -> Map k a -> m
`Map.foldMapWithKey` PendingDeposits tx
m) ((TxIdType tx -> Deposit tx -> [StateChanged tx]) -> Outcome tx)
-> (TxIdType tx -> Deposit tx -> [StateChanged tx]) -> Outcome tx
forall a b. (a -> b) -> a -> b
$ \TxIdType tx
depositTxId Deposit tx
deposit ->
    StateChanged tx -> [StateChanged tx]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure DepositActivated{TxIdType tx
depositTxId :: TxIdType tx
$sel:depositTxId:NetworkConnected :: TxIdType tx
depositTxId, UTCTime
chainTime :: UTCTime
$sel:chainTime:NetworkConnected :: UTCTime
chainTime, Deposit tx
deposit :: Deposit tx
$sel:deposit:NetworkConnected :: Deposit tx
deposit}

  mkDepositExpired :: PendingDeposits tx -> Outcome tx
mkDepositExpired PendingDeposits tx
m = [StateChanged tx] -> Outcome tx
forall tx. [StateChanged tx] -> Outcome tx
changes ([StateChanged tx] -> Outcome tx)
-> ((TxIdType tx -> Deposit tx -> [StateChanged tx])
    -> [StateChanged tx])
-> (TxIdType tx -> Deposit tx -> [StateChanged tx])
-> Outcome tx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((TxIdType tx -> Deposit tx -> [StateChanged tx])
-> PendingDeposits tx -> [StateChanged tx]
forall m k a. Monoid m => (k -> a -> m) -> Map k a -> m
`Map.foldMapWithKey` PendingDeposits tx
m) ((TxIdType tx -> Deposit tx -> [StateChanged tx]) -> Outcome tx)
-> (TxIdType tx -> Deposit tx -> [StateChanged tx]) -> Outcome tx
forall a b. (a -> b) -> a -> b
$ \TxIdType tx
depositTxId Deposit tx
deposit ->
    StateChanged tx -> [StateChanged tx]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure DepositExpired{TxIdType tx
$sel:depositTxId:NetworkConnected :: TxIdType tx
depositTxId :: TxIdType tx
depositTxId, UTCTime
chainTime :: UTCTime
$sel:chainTime:NetworkConnected :: UTCTime
chainTime, Deposit tx
$sel:deposit:NetworkConnected :: Deposit tx
deposit :: Deposit tx
deposit}

-- | Process the chain (and time) advancing in an open head.
--
-- __Transition__: 'OpenState' → 'OpenState'
--
-- This is primarily used to track deposits and either drop them or request
-- snapshots for inclusion.
onOpenChainTick :: IsTx tx => Environment -> UTCTime -> PendingDeposits tx -> OpenState tx -> Outcome tx
onOpenChainTick :: forall tx.
IsTx tx =>
Environment
-> UTCTime -> PendingDeposits tx -> OpenState tx -> Outcome tx
onOpenChainTick Environment
env UTCTime
chainTime Map (TxIdType tx) (Deposit tx)
pendingDeposits OpenState tx
st =
  -- Determine new active and new expired
  let nextDeposits :: Map (TxIdType tx) (Deposit tx)
nextDeposits = Environment
-> Map (TxIdType tx) (Deposit tx)
-> UTCTime
-> Map (TxIdType tx) (Deposit tx)
forall tx.
Ord (TxIdType tx) =>
Environment -> PendingDeposits tx -> UTCTime -> PendingDeposits tx
determineNextDepositStatus Environment
env Map (TxIdType tx) (Deposit tx)
pendingDeposits UTCTime
chainTime
      newActive :: Map (TxIdType tx) (Deposit tx)
newActive = (Deposit tx -> Bool)
-> Map (TxIdType tx) (Deposit tx) -> Map (TxIdType tx) (Deposit tx)
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (\Deposit{DepositStatus
$sel:status:Deposit :: forall tx. Deposit tx -> DepositStatus
status :: DepositStatus
status} -> DepositStatus
status DepositStatus -> DepositStatus -> Bool
forall a. Eq a => a -> a -> Bool
== DepositStatus
Active) Map (TxIdType tx) (Deposit tx)
nextDeposits
      newExpired :: Map (TxIdType tx) (Deposit tx)
newExpired = (Deposit tx -> Bool)
-> Map (TxIdType tx) (Deposit tx) -> Map (TxIdType tx) (Deposit tx)
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (\Deposit{DepositStatus
$sel:status:Deposit :: forall tx. Deposit tx -> DepositStatus
status :: DepositStatus
status} -> DepositStatus
status DepositStatus -> DepositStatus -> Bool
forall a. Eq a => a -> a -> Bool
== DepositStatus
Expired) Map (TxIdType tx) (Deposit tx)
nextDeposits
   in -- Apply state changes and pick next active to request snapshot
      -- XXX: This is smelly as we rely on Map <> to override entries (left
      -- biased). This is also weird because we want to actually apply the state
      -- change and also to determine the next active.
      Map (TxIdType tx) (Deposit tx)
-> (TxIdType tx -> Outcome tx) -> Outcome tx
forall tx.
(Eq (UTxOType tx), Monoid (UTxOType tx)) =>
Map (TxIdType tx) (Deposit tx)
-> (TxIdType tx -> Outcome tx) -> Outcome tx
withNextActive (Map (TxIdType tx) (Deposit tx)
newActive Map (TxIdType tx) (Deposit tx)
-> Map (TxIdType tx) (Deposit tx) -> Map (TxIdType tx) (Deposit tx)
forall a. Semigroup a => a -> a -> a
<> Map (TxIdType tx) (Deposit tx)
newExpired Map (TxIdType tx) (Deposit tx)
-> Map (TxIdType tx) (Deposit tx) -> Map (TxIdType tx) (Deposit tx)
forall a. Semigroup a => a -> a -> a
<> Map (TxIdType tx) (Deposit tx)
pendingDeposits) ((TxIdType tx -> Outcome tx) -> Outcome tx)
-> (TxIdType tx -> Outcome tx) -> Outcome tx
forall a b. (a -> b) -> a -> b
$ \TxIdType tx
depositTxId ->
        -- REVIEW: this is not really a wait, but discard?
        -- TODO: Spec: wait tx𝜔 = ⊥ ∧ 𝑈𝛼 = ∅
        if Maybe tx -> Bool
forall a. Maybe a -> Bool
isNothing Maybe tx
decommitTx
          Bool -> Bool -> Bool
&& Maybe (TxIdType tx) -> Bool
forall a. Maybe a -> Bool
isNothing Maybe (TxIdType tx)
currentDepositTxId
          Bool -> Bool -> Bool
&& Bool -> Bool
not (SeenSnapshot tx -> Bool
forall tx. SeenSnapshot tx -> Bool
snapshotInFlight SeenSnapshot tx
seenSnapshot)
          Bool -> Bool -> Bool
&& HeadParameters -> Party -> SnapshotNumber -> Bool
isLeader HeadParameters
parameters Party
party SnapshotNumber
nextSn
          then
            -- XXX: This state update has no equivalence in the
            -- spec. Do we really need to store that we have
            -- requested a snapshot? If yes, should update spec.
            StateChanged tx -> Outcome tx
forall tx. StateChanged tx -> Outcome tx
newState SnapshotRequestDecided{$sel:snapshotNumber:NetworkConnected :: SnapshotNumber
snapshotNumber = SnapshotNumber
nextSn}
              -- Spec: multicast (reqSn,̂ 𝑣,̄ 𝒮.𝑠 + 1,̂ 𝒯, 𝑈𝛼, ⊥)
              Outcome tx -> Outcome tx -> Outcome tx
forall a. Semigroup a => a -> a -> a
<> Effect tx -> Outcome tx
forall tx. Effect tx -> Outcome tx
cause (Message tx -> Effect tx
forall tx. Message tx -> Effect tx
NetworkEffect (Message tx -> Effect tx) -> Message tx -> Effect tx
forall a b. (a -> b) -> a -> b
$ SnapshotVersion
-> SnapshotNumber
-> [TxIdType tx]
-> Maybe tx
-> Maybe (TxIdType tx)
-> Message tx
forall tx.
SnapshotVersion
-> SnapshotNumber
-> [TxIdType tx]
-> Maybe tx
-> Maybe (TxIdType tx)
-> Message tx
ReqSn SnapshotVersion
version SnapshotNumber
nextSn (Seq (TxIdType tx) -> [TxIdType tx]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Seq (TxIdType tx) -> [TxIdType tx])
-> Seq (TxIdType tx) -> [TxIdType tx]
forall a b. (a -> b) -> a -> b
$ tx -> TxIdType tx
forall tx. IsTx tx => tx -> TxIdType tx
txId (tx -> TxIdType tx) -> Seq tx -> Seq (TxIdType tx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Seq tx -> Seq tx
forall a. Int -> Seq a -> Seq a
Seq.take Int
maxTxsPerSnapshot Seq tx
localTxs) Maybe tx
forall a. Maybe a
Nothing (TxIdType tx -> Maybe (TxIdType tx)
forall a. a -> Maybe a
Just TxIdType tx
depositTxId))
          else
            Outcome tx
forall tx. Outcome tx
noop
 where
  -- Pending active deposits are selected in arrival order (FIFO).
  withNextActive :: forall tx. (Eq (UTxOType tx), Monoid (UTxOType tx)) => Map (TxIdType tx) (Deposit tx) -> (TxIdType tx -> Outcome tx) -> Outcome tx
  withNextActive :: forall tx.
(Eq (UTxOType tx), Monoid (UTxOType tx)) =>
Map (TxIdType tx) (Deposit tx)
-> (TxIdType tx -> Outcome tx) -> Outcome tx
withNextActive Map (TxIdType tx) (Deposit tx)
deposits TxIdType tx -> Outcome tx
cont = do
    -- NOTE: Do not consider empty deposits.
    let p :: (x, Deposit tx) -> Bool
        p :: forall x. (x, Deposit tx) -> Bool
p (x
_, Deposit{UTxOType tx
$sel:deposited:Deposit :: forall tx. Deposit tx -> UTxOType tx
deposited :: UTxOType tx
deposited, DepositStatus
$sel:status:Deposit :: forall tx. Deposit tx -> DepositStatus
status :: DepositStatus
status}) = UTxOType tx
deposited UTxOType tx -> UTxOType tx -> Bool
forall a. Eq a => a -> a -> Bool
/= UTxOType tx
forall a. Monoid a => a
mempty Bool -> Bool -> Bool
&& DepositStatus
status DepositStatus -> DepositStatus -> Bool
forall a. Eq a => a -> a -> Bool
== DepositStatus
Active
    case ((TxIdType tx, Deposit tx) -> Bool)
-> [(TxIdType tx, Deposit tx)] -> [(TxIdType tx, Deposit tx)]
forall a. (a -> Bool) -> [a] -> [a]
filter (TxIdType tx, Deposit tx) -> Bool
forall x. (x, Deposit tx) -> Bool
p (Map (TxIdType tx) (Deposit tx) -> [(TxIdType tx, Deposit tx)]
forall k a. Map k a -> [(k, a)]
Map.toList Map (TxIdType tx) (Deposit tx)
deposits) of
      [] -> Outcome tx
forall tx. Outcome tx
noop
      [(TxIdType tx, Deposit tx)]
xs -> TxIdType tx -> Outcome tx
cont ((TxIdType tx, Deposit tx) -> TxIdType tx
forall a b. (a, b) -> a
fst (((TxIdType tx, Deposit tx)
 -> (TxIdType tx, Deposit tx) -> Ordering)
-> [(TxIdType tx, Deposit tx)] -> (TxIdType tx, Deposit tx)
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
minimumBy (((TxIdType tx, Deposit tx) -> UTCTime)
-> (TxIdType tx, Deposit tx)
-> (TxIdType tx, Deposit tx)
-> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing ((\Deposit{UTCTime
$sel:created:Deposit :: forall tx. Deposit tx -> UTCTime
created :: UTCTime
created} -> UTCTime
created) (Deposit tx -> UTCTime)
-> ((TxIdType tx, Deposit tx) -> Deposit tx)
-> (TxIdType tx, Deposit tx)
-> UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxIdType tx, Deposit tx) -> Deposit tx
forall a b. (a, b) -> b
snd)) [(TxIdType tx, Deposit tx)]
xs))

  nextSn :: SnapshotNumber
nextSn = SnapshotNumber
confirmedSn SnapshotNumber -> SnapshotNumber -> SnapshotNumber
forall a. Num a => a -> a -> a
+ SnapshotNumber
1

  Environment{Party
$sel:party:Environment :: Environment -> Party
party :: Party
party} = Environment
env

  CoordinatedHeadState
    { Seq tx
$sel:localTxs:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> Seq tx
localTxs :: Seq tx
localTxs
    , ConfirmedSnapshot tx
$sel:confirmedSnapshot:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> ConfirmedSnapshot tx
confirmedSnapshot :: ConfirmedSnapshot tx
confirmedSnapshot
    , SeenSnapshot tx
$sel:seenSnapshot:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> SeenSnapshot tx
seenSnapshot :: SeenSnapshot tx
seenSnapshot
    , SnapshotVersion
$sel:version:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> SnapshotVersion
version :: SnapshotVersion
version
    , Maybe tx
$sel:decommitTx:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> Maybe tx
decommitTx :: Maybe tx
decommitTx
    , Maybe (TxIdType tx)
$sel:currentDepositTxId:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> Maybe (TxIdType tx)
currentDepositTxId :: Maybe (TxIdType tx)
currentDepositTxId
    } = CoordinatedHeadState tx
coordinatedHeadState

  Snapshot{$sel:number:Snapshot :: forall tx. Snapshot tx -> SnapshotNumber
number = SnapshotNumber
confirmedSn} = ConfirmedSnapshot tx -> Snapshot tx
forall tx. IsTx tx => ConfirmedSnapshot tx -> Snapshot tx
getSnapshot ConfirmedSnapshot tx
confirmedSnapshot

  OpenState{CoordinatedHeadState tx
$sel:coordinatedHeadState:OpenState :: forall tx. OpenState tx -> CoordinatedHeadState tx
coordinatedHeadState :: CoordinatedHeadState tx
coordinatedHeadState, HeadParameters
$sel:parameters:OpenState :: forall tx. OpenState tx -> HeadParameters
parameters :: HeadParameters
parameters} = OpenState tx
st

-- | If this node is the snapshot leader and there are pending local transactions,
-- request the next snapshot with the bumped version after a commit or decommit
-- finalises on-chain.
--
-- Guards:
--   * Only fires when 'version /= newVersion' to avoid duplicate
--     'SnapshotRequestDecided' events when multiple parties post the same
--     on-chain tx and each posting produces a separate finalisation observation.
--   * Skips when AckSns are already being collected ('SeenSnapshot'): the
--     in-flight snapshot will complete and 'maybeRequestNextSnapshot' will chain
--     the next one with the bumped version. Firing here would use stale
--     'localTxs' and cause 'BadInputsUTxO' on other parties.
--   * Allows 'RequestedSnapshot': the in-flight ReqSn carries the old version
--     and will be parked by 'waitOnSnapshotVersion' until TTL drops it, so we
--     re-request immediately with the new version to make progress without
--     waiting for the stale request's retries to exhaust.
--
-- The optional 'depositTxId' argument is forwarded into 'ReqSn': commit
-- finalisation passes 'Nothing' (deposit already included), while decommit
-- finalisation passes the next queued deposit if one is pending.
maybeRequestSnapshotAfterVersionBump ::
  IsTx tx =>
  HeadParameters ->
  Party ->
  SnapshotNumber ->
  Seq tx ->
  SnapshotVersion ->
  SnapshotVersion ->
  SeenSnapshot tx ->
  Maybe (TxIdType tx) ->
  Outcome tx
maybeRequestSnapshotAfterVersionBump :: forall tx.
IsTx tx =>
HeadParameters
-> Party
-> SnapshotNumber
-> Seq tx
-> SnapshotVersion
-> SnapshotVersion
-> SeenSnapshot tx
-> Maybe (TxIdType tx)
-> Outcome tx
maybeRequestSnapshotAfterVersionBump HeadParameters
parameters Party
party SnapshotNumber
nextSn Seq tx
localTxs SnapshotVersion
version SnapshotVersion
newVersion SeenSnapshot tx
seenSnapshot Maybe (TxIdType tx)
depositTxId =
  if HeadParameters -> Party -> SnapshotNumber -> Bool
isLeader HeadParameters
parameters Party
party SnapshotNumber
nextSn Bool -> Bool -> Bool
&& Bool -> Bool
not (Seq tx -> Bool
forall a. Seq a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Seq tx
localTxs) Bool -> Bool -> Bool
&& SnapshotVersion
version SnapshotVersion -> SnapshotVersion -> Bool
forall a. Eq a => a -> a -> Bool
/= SnapshotVersion
newVersion Bool -> Bool -> Bool
&& Bool -> Bool
not (SeenSnapshot tx -> Bool
forall tx. SeenSnapshot tx -> Bool
isCollectingAcks SeenSnapshot tx
seenSnapshot)
    then
      StateChanged tx -> Outcome tx
forall tx. StateChanged tx -> Outcome tx
newState SnapshotRequestDecided{$sel:snapshotNumber:NetworkConnected :: SnapshotNumber
snapshotNumber = SnapshotNumber
nextSn}
        Outcome tx -> Outcome tx -> Outcome tx
forall a. Semigroup a => a -> a -> a
<> Effect tx -> Outcome tx
forall tx. Effect tx -> Outcome tx
cause (Message tx -> Effect tx
forall tx. Message tx -> Effect tx
NetworkEffect (Message tx -> Effect tx) -> Message tx -> Effect tx
forall a b. (a -> b) -> a -> b
$ SnapshotVersion
-> SnapshotNumber
-> [TxIdType tx]
-> Maybe tx
-> Maybe (TxIdType tx)
-> Message tx
forall tx.
SnapshotVersion
-> SnapshotNumber
-> [TxIdType tx]
-> Maybe tx
-> Maybe (TxIdType tx)
-> Message tx
ReqSn SnapshotVersion
newVersion SnapshotNumber
nextSn (Seq (TxIdType tx) -> [TxIdType tx]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Seq (TxIdType tx) -> [TxIdType tx])
-> Seq (TxIdType tx) -> [TxIdType tx]
forall a b. (a -> b) -> a -> b
$ tx -> TxIdType tx
forall tx. IsTx tx => tx -> TxIdType tx
txId (tx -> TxIdType tx) -> Seq tx -> Seq (TxIdType tx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Seq tx -> Seq tx
forall a. Int -> Seq a -> Seq a
Seq.take Int
maxTxsPerSnapshot Seq tx
localTxs) Maybe tx
forall a. Maybe a
Nothing Maybe (TxIdType tx)
depositTxId)
    else Outcome tx
forall tx. Outcome tx
noop

-- | Observe a increment transaction. If the outputs match the ones of the
-- pending commit UTxO, then we consider the deposit/increment finalized, and remove the
-- increment UTxO from 'pendingDeposits' from the local state.
--
-- Finally, if the client observing happens to be the leader, then a new ReqSn
-- is broadcasted.
--
-- __Transition__: 'OpenState' → 'OpenState'
onOpenChainIncrementTx ::
  IsTx tx =>
  Environment ->
  OpenState tx ->
  ChainStateType tx ->
  -- | New open state version
  SnapshotVersion ->
  -- | Deposit TxId
  TxIdType tx ->
  Outcome tx
onOpenChainIncrementTx :: forall tx.
IsTx tx =>
Environment
-> OpenState tx
-> ChainStateType tx
-> SnapshotVersion
-> TxIdType tx
-> Outcome tx
onOpenChainIncrementTx Environment
env OpenState tx
openState ChainStateType tx
newChainState SnapshotVersion
newVersion TxIdType tx
depositTxId =
  StateChanged tx -> Outcome tx
forall tx. StateChanged tx -> Outcome tx
newState CommitFinalized{$sel:chainState:NetworkConnected :: ChainStateType tx
chainState = ChainStateType tx
newChainState, HeadId
$sel:headId:NetworkConnected :: HeadId
headId :: HeadId
headId, SnapshotVersion
newVersion :: SnapshotVersion
$sel:newVersion:NetworkConnected :: SnapshotVersion
newVersion, TxIdType tx
$sel:depositTxId:NetworkConnected :: TxIdType tx
depositTxId :: TxIdType tx
depositTxId}
    Outcome tx -> Outcome tx -> Outcome tx
forall a. Semigroup a => a -> a -> a
<> HeadParameters
-> Party
-> SnapshotNumber
-> Seq tx
-> SnapshotVersion
-> SnapshotVersion
-> SeenSnapshot tx
-> Maybe (TxIdType tx)
-> Outcome tx
forall tx.
IsTx tx =>
HeadParameters
-> Party
-> SnapshotNumber
-> Seq tx
-> SnapshotVersion
-> SnapshotVersion
-> SeenSnapshot tx
-> Maybe (TxIdType tx)
-> Outcome tx
maybeRequestSnapshotAfterVersionBump HeadParameters
parameters Party
party SnapshotNumber
nextSn Seq tx
localTxs SnapshotVersion
version SnapshotVersion
newVersion SeenSnapshot tx
seenSnapshot Maybe (TxIdType tx)
forall a. Maybe a
Nothing
 where
  OpenState{HeadId
$sel:headId:OpenState :: forall tx. OpenState tx -> HeadId
headId :: HeadId
headId, HeadParameters
$sel:parameters:OpenState :: forall tx. OpenState tx -> HeadParameters
parameters :: HeadParameters
parameters, CoordinatedHeadState tx
$sel:coordinatedHeadState:OpenState :: forall tx. OpenState tx -> CoordinatedHeadState tx
coordinatedHeadState :: CoordinatedHeadState tx
coordinatedHeadState} = OpenState tx
openState

  CoordinatedHeadState{Seq tx
$sel:localTxs:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> Seq tx
localTxs :: Seq tx
localTxs, ConfirmedSnapshot tx
$sel:confirmedSnapshot:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> ConfirmedSnapshot tx
confirmedSnapshot :: ConfirmedSnapshot tx
confirmedSnapshot, SnapshotVersion
$sel:version:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> SnapshotVersion
version :: SnapshotVersion
version, SeenSnapshot tx
$sel:seenSnapshot:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> SeenSnapshot tx
seenSnapshot :: SeenSnapshot tx
seenSnapshot} = CoordinatedHeadState tx
coordinatedHeadState

  Snapshot{$sel:number:Snapshot :: forall tx. Snapshot tx -> SnapshotNumber
number = SnapshotNumber
confirmedSn} = ConfirmedSnapshot tx -> Snapshot tx
forall tx. IsTx tx => ConfirmedSnapshot tx -> Snapshot tx
getSnapshot ConfirmedSnapshot tx
confirmedSnapshot

  Environment{Party
$sel:party:Environment :: Environment -> Party
party :: Party
party} = Environment
env

  nextSn :: SnapshotNumber
nextSn = SnapshotNumber
confirmedSn SnapshotNumber -> SnapshotNumber -> SnapshotNumber
forall a. Num a => a -> a -> a
+ SnapshotNumber
1

-- | Observe a decrement transaction. If the outputs match the ones of the
-- pending decommit tx, then we consider the decommit finalized, and remove the
-- decommit tx in flight.
--
-- Finally, if the client observing happens to be the leader, then a new ReqSn
-- is broadcasted.
--
-- __Transition__: 'OpenState' → 'OpenState'
onOpenChainDecrementTx ::
  IsTx tx =>
  Environment ->
  PendingDeposits tx ->
  OpenState tx ->
  ChainStateType tx ->
  -- | New open state version
  SnapshotVersion ->
  -- | Outputs removed by the decrement
  UTxOType tx ->
  Outcome tx
onOpenChainDecrementTx :: forall tx.
IsTx tx =>
Environment
-> PendingDeposits tx
-> OpenState tx
-> ChainStateType tx
-> SnapshotVersion
-> UTxOType tx
-> Outcome tx
onOpenChainDecrementTx Environment
env PendingDeposits tx
pendingDeposits OpenState tx
openState ChainStateType tx
newChainState SnapshotVersion
newVersion UTxOType tx
distributedUTxO =
  StateChanged tx -> Outcome tx
forall tx. StateChanged tx -> Outcome tx
newState
    DecommitFinalized
      { $sel:chainState:NetworkConnected :: ChainStateType tx
chainState = ChainStateType tx
newChainState
      , HeadId
$sel:headId:NetworkConnected :: HeadId
headId :: HeadId
headId
      , SnapshotVersion
$sel:newVersion:NetworkConnected :: SnapshotVersion
newVersion :: SnapshotVersion
newVersion
      , UTxOType tx
distributedUTxO :: UTxOType tx
$sel:distributedUTxO:NetworkConnected :: UTxOType tx
distributedUTxO
      }
    Outcome tx -> Outcome tx -> Outcome tx
forall a. Semigroup a => a -> a -> a
<> HeadParameters
-> Party
-> SnapshotNumber
-> Seq tx
-> SnapshotVersion
-> SnapshotVersion
-> SeenSnapshot tx
-> Maybe (TxIdType tx)
-> Outcome tx
forall tx.
IsTx tx =>
HeadParameters
-> Party
-> SnapshotNumber
-> Seq tx
-> SnapshotVersion
-> SnapshotVersion
-> SeenSnapshot tx
-> Maybe (TxIdType tx)
-> Outcome tx
maybeRequestSnapshotAfterVersionBump HeadParameters
parameters Party
party SnapshotNumber
nextSn Seq tx
localTxs SnapshotVersion
version SnapshotVersion
newVersion SeenSnapshot tx
seenSnapshot (PendingDeposits tx -> Maybe (TxIdType tx) -> Maybe (TxIdType tx)
forall tx.
IsTx tx =>
PendingDeposits tx -> Maybe (TxIdType tx) -> Maybe (TxIdType tx)
setExistingDeposit PendingDeposits tx
pendingDeposits Maybe (TxIdType tx)
currentDepositTxId)
 where
  OpenState{HeadId
$sel:headId:OpenState :: forall tx. OpenState tx -> HeadId
headId :: HeadId
headId, HeadParameters
$sel:parameters:OpenState :: forall tx. OpenState tx -> HeadParameters
parameters :: HeadParameters
parameters, CoordinatedHeadState tx
$sel:coordinatedHeadState:OpenState :: forall tx. OpenState tx -> CoordinatedHeadState tx
coordinatedHeadState :: CoordinatedHeadState tx
coordinatedHeadState} = OpenState tx
openState

  CoordinatedHeadState{Seq tx
$sel:localTxs:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> Seq tx
localTxs :: Seq tx
localTxs, ConfirmedSnapshot tx
$sel:confirmedSnapshot:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> ConfirmedSnapshot tx
confirmedSnapshot :: ConfirmedSnapshot tx
confirmedSnapshot, Maybe (TxIdType tx)
$sel:currentDepositTxId:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> Maybe (TxIdType tx)
currentDepositTxId :: Maybe (TxIdType tx)
currentDepositTxId, SnapshotVersion
$sel:version:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> SnapshotVersion
version :: SnapshotVersion
version, SeenSnapshot tx
$sel:seenSnapshot:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> SeenSnapshot tx
seenSnapshot :: SeenSnapshot tx
seenSnapshot} = CoordinatedHeadState tx
coordinatedHeadState

  Snapshot{$sel:number:Snapshot :: forall tx. Snapshot tx -> SnapshotNumber
number = SnapshotNumber
confirmedSn} = ConfirmedSnapshot tx -> Snapshot tx
forall tx. IsTx tx => ConfirmedSnapshot tx -> Snapshot tx
getSnapshot ConfirmedSnapshot tx
confirmedSnapshot

  Environment{Party
$sel:party:Environment :: Environment -> Party
party :: Party
party} = Environment
env

  nextSn :: SnapshotNumber
nextSn = SnapshotNumber
confirmedSn SnapshotNumber -> SnapshotNumber -> SnapshotNumber
forall a. Num a => a -> a -> a
+ SnapshotNumber
1

-- | On rollback, re-post the IncrementTx if there is a pending deposit whose
-- confirmed snapshot contains a matching utxoToCommit. The rollback may have
-- erased the original on-chain IncrementTx observation.
maybeRepostIncrementTx ::
  IsTx tx =>
  HeadSeed ->
  HeadId ->
  HeadParameters ->
  PendingDeposits tx ->
  ConfirmedSnapshot tx ->
  Outcome tx
maybeRepostIncrementTx :: forall tx.
IsTx tx =>
HeadSeed
-> HeadId
-> HeadParameters
-> PendingDeposits tx
-> ConfirmedSnapshot tx
-> Outcome tx
maybeRepostIncrementTx HeadSeed
headSeed HeadId
headId HeadParameters
parameters PendingDeposits tx
pendingDeposits ConfirmedSnapshot tx
confirmedSnapshot =
  -- NOTE: the deposit comes from the confirmed snapshot itself, not from
  -- 'currentDepositTxId'. Only the deposit bound into the signed snapshot can be
  -- claimed on-chain, and 'DepositActivated' can set 'currentDepositTxId' to an
  -- unrelated deposit after that snapshot was confirmed.
  case ConfirmedSnapshot tx
confirmedSnapshot of
    ConfirmedSnapshot{$sel:snapshot:InitialSnapshot :: forall tx. ConfirmedSnapshot tx -> Snapshot tx
snapshot = snapshot :: Snapshot tx
snapshot@Snapshot{$sel:utxoToCommit:Snapshot :: forall tx. Snapshot tx -> Maybe (UTxOType tx)
utxoToCommit = Just UTxOType tx
_, $sel:depositTxId:Snapshot :: forall tx. Snapshot tx -> Maybe (TxIdType tx)
depositTxId = Just TxIdType tx
depositTxId}, MultiSignature (Snapshot tx)
$sel:signatures:InitialSnapshot :: forall tx. ConfirmedSnapshot tx -> MultiSignature (Snapshot tx)
signatures :: MultiSignature (Snapshot tx)
signatures} ->
      case TxIdType tx -> PendingDeposits tx -> Maybe (Deposit tx)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TxIdType tx
depositTxId PendingDeposits tx
pendingDeposits of
        Just Deposit{} ->
          Effect tx -> Outcome tx
forall tx. Effect tx -> Outcome tx
cause
            OnChainEffect
              { $sel:postChainTx:ClientEffect :: PostChainTx tx
postChainTx =
                  IncrementTx
                    { HeadSeed
$sel:headSeed:InitTx :: HeadSeed
headSeed :: HeadSeed
headSeed
                    , HeadId
$sel:headId:InitTx :: HeadId
headId :: HeadId
headId
                    , $sel:headParameters:InitTx :: HeadParameters
headParameters = HeadParameters
parameters
                    , $sel:incrementingSnapshot:InitTx :: ConfirmedSnapshot tx
incrementingSnapshot = ConfirmedSnapshot{Snapshot tx
$sel:snapshot:InitialSnapshot :: Snapshot tx
snapshot :: Snapshot tx
snapshot, MultiSignature (Snapshot tx)
$sel:signatures:InitialSnapshot :: MultiSignature (Snapshot tx)
signatures :: MultiSignature (Snapshot tx)
signatures}
                    , TxIdType tx
$sel:depositTxId:InitTx :: TxIdType tx
depositTxId :: TxIdType tx
depositTxId
                    }
              }
        Maybe (Deposit tx)
Nothing -> Outcome tx
forall tx. Outcome tx
noop
    ConfirmedSnapshot tx
_ -> Outcome tx
forall tx. Outcome tx
noop

-- | On rollback, re-post the DecrementTx if there is a pending decommit whose
-- confirmed snapshot contains a matching utxoToDecommit. The rollback may have
-- erased the original on-chain DecrementTx observation.
maybeRepostDecrementTx ::
  HeadSeed ->
  HeadId ->
  HeadParameters ->
  Maybe tx ->
  ConfirmedSnapshot tx ->
  Outcome tx
maybeRepostDecrementTx :: forall tx.
HeadSeed
-> HeadId
-> HeadParameters
-> Maybe tx
-> ConfirmedSnapshot tx
-> Outcome tx
maybeRepostDecrementTx HeadSeed
headSeed HeadId
headId HeadParameters
parameters Maybe tx
mDecommitTx ConfirmedSnapshot tx
confirmedSnapshot =
  case (Maybe tx
mDecommitTx, ConfirmedSnapshot tx
confirmedSnapshot) of
    (Just tx
_, ConfirmedSnapshot{$sel:snapshot:InitialSnapshot :: forall tx. ConfirmedSnapshot tx -> Snapshot tx
snapshot = snapshot :: Snapshot tx
snapshot@Snapshot{$sel:utxoToDecommit:Snapshot :: forall tx. Snapshot tx -> Maybe (UTxOType tx)
utxoToDecommit = Just UTxOType tx
_}, MultiSignature (Snapshot tx)
$sel:signatures:InitialSnapshot :: forall tx. ConfirmedSnapshot tx -> MultiSignature (Snapshot tx)
signatures :: MultiSignature (Snapshot tx)
signatures}) ->
      Effect tx -> Outcome tx
forall tx. Effect tx -> Outcome tx
cause
        OnChainEffect
          { $sel:postChainTx:ClientEffect :: PostChainTx tx
postChainTx =
              DecrementTx
                { HeadSeed
$sel:headSeed:InitTx :: HeadSeed
headSeed :: HeadSeed
headSeed
                , HeadId
$sel:headId:InitTx :: HeadId
headId :: HeadId
headId
                , $sel:headParameters:InitTx :: HeadParameters
headParameters = HeadParameters
parameters
                , $sel:decrementingSnapshot:InitTx :: ConfirmedSnapshot tx
decrementingSnapshot = ConfirmedSnapshot{Snapshot tx
$sel:snapshot:InitialSnapshot :: Snapshot tx
snapshot :: Snapshot tx
snapshot, MultiSignature (Snapshot tx)
$sel:signatures:InitialSnapshot :: MultiSignature (Snapshot tx)
signatures :: MultiSignature (Snapshot tx)
signatures}
                }
          }
    (Maybe tx, ConfirmedSnapshot tx)
_ -> Outcome tx
forall tx. Outcome tx
noop

isLeader :: HeadParameters -> Party -> SnapshotNumber -> Bool
isLeader :: HeadParameters -> Party -> SnapshotNumber -> Bool
isLeader HeadParameters{[Party]
$sel:parties:HeadParameters :: HeadParameters -> [Party]
parties :: [Party]
parties} Party
p SnapshotNumber
sn =
  case Party
p Party -> [Party] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
`elemIndex` [Party]
parties of
    Just Int
i -> ((SnapshotNumber -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral SnapshotNumber
sn Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` [Party] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Party]
parties) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
i
    Maybe Int
_ -> Bool
False

-- ** Closing the Head

-- | Client request to close the head. This leads to a close transaction on
-- chain using the latest confirmed snaphshot of the 'OpenState'.
--
-- __Transition__: 'OpenState' → 'OpenState'
onOpenClientClose ::
  OpenState tx ->
  Outcome tx
onOpenClientClose :: forall tx. OpenState tx -> Outcome tx
onOpenClientClose OpenState tx
st =
  -- Spec: η# ← ̅S.(η')#  (the confirmed snapshot's stored accumulator hash; not recomputed at close/contest)
  --       ξ ← ̅S.σ
  --       postTx (close, ̅S.v, ̅S.s, η, ξ)
  Effect tx -> Outcome tx
forall tx. Effect tx -> Outcome tx
cause
    OnChainEffect
      { $sel:postChainTx:ClientEffect :: PostChainTx tx
postChainTx =
          CloseTx
            { HeadId
$sel:headId:InitTx :: HeadId
headId :: HeadId
headId
            , $sel:headParameters:InitTx :: HeadParameters
headParameters = HeadParameters
parameters
            , $sel:openVersion:InitTx :: SnapshotVersion
openVersion = SnapshotVersion
version
            , $sel:closingSnapshot:InitTx :: ConfirmedSnapshot tx
closingSnapshot = ConfirmedSnapshot tx
confirmedSnapshot
            }
      }
 where
  CoordinatedHeadState{ConfirmedSnapshot tx
$sel:confirmedSnapshot:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> ConfirmedSnapshot tx
confirmedSnapshot :: ConfirmedSnapshot tx
confirmedSnapshot, SnapshotVersion
$sel:version:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> SnapshotVersion
version :: SnapshotVersion
version} = CoordinatedHeadState tx
coordinatedHeadState

  OpenState{CoordinatedHeadState tx
$sel:coordinatedHeadState:OpenState :: forall tx. OpenState tx -> CoordinatedHeadState tx
coordinatedHeadState :: CoordinatedHeadState tx
coordinatedHeadState, HeadId
$sel:headId:OpenState :: forall tx. OpenState tx -> HeadId
headId :: HeadId
headId, HeadParameters
$sel:parameters:OpenState :: forall tx. OpenState tx -> HeadParameters
parameters :: HeadParameters
parameters} = OpenState tx
st

-- | Observe a close transaction. If the closed snapshot number is smaller than
-- our last confirmed, we post a contest transaction. Also, we do schedule a
-- notification for clients to fanout at the deadline.
--
-- __Transition__: 'OpenState' → 'ClosedState'
onOpenChainCloseTx ::
  IsTx tx =>
  OpenState tx ->
  -- | New chain state.
  ChainStateType tx ->
  -- | Closed snapshot number.
  SnapshotNumber ->
  -- | Contestation deadline.
  UTCTime ->
  Outcome tx
onOpenChainCloseTx :: forall tx.
IsTx tx =>
OpenState tx
-> ChainStateType tx -> SnapshotNumber -> UTCTime -> Outcome tx
onOpenChainCloseTx OpenState tx
openState ChainStateType tx
newChainState SnapshotNumber
closedSnapshotNumber UTCTime
contestationDeadline =
  StateChanged tx -> Outcome tx
forall tx. StateChanged tx -> Outcome tx
newState HeadClosed{HeadId
$sel:headId:NetworkConnected :: HeadId
headId :: HeadId
headId, $sel:snapshotNumber:NetworkConnected :: SnapshotNumber
snapshotNumber = SnapshotNumber
closedSnapshotNumber, $sel:chainState:NetworkConnected :: ChainStateType tx
chainState = ChainStateType tx
newChainState, UTCTime
contestationDeadline :: UTCTime
$sel:contestationDeadline:NetworkConnected :: UTCTime
contestationDeadline}
    Outcome tx -> (Outcome tx -> Outcome tx) -> Outcome tx
forall a b. a -> (a -> b) -> b
& Outcome tx -> Outcome tx
maybePostContest
 where
  maybePostContest :: Outcome tx -> Outcome tx
maybePostContest Outcome tx
outcome =
    -- Spec: if ̅S.s > sc
    if Snapshot tx -> SnapshotNumber
forall tx. Snapshot tx -> SnapshotNumber
number (ConfirmedSnapshot tx -> Snapshot tx
forall tx. IsTx tx => ConfirmedSnapshot tx -> Snapshot tx
getSnapshot ConfirmedSnapshot tx
confirmedSnapshot) SnapshotNumber -> SnapshotNumber -> Bool
forall a. Ord a => a -> a -> Bool
> SnapshotNumber
closedSnapshotNumber
      then
        Outcome tx
outcome
          -- Spec: η# ← ̅S.(η')#  (the confirmed snapshot's stored accumulator hash; not recomputed at close/contest)
          --       ξ ← ̅S.σ
          --       postTx (contest, ̅S.v, ̅S.s, η, ξ)
          Outcome tx -> Outcome tx -> Outcome tx
forall a. Semigroup a => a -> a -> a
<> Effect tx -> Outcome tx
forall tx. Effect tx -> Outcome tx
cause
            OnChainEffect
              { $sel:postChainTx:ClientEffect :: PostChainTx tx
postChainTx =
                  ContestTx
                    { HeadId
$sel:headId:InitTx :: HeadId
headId :: HeadId
headId
                    , HeadParameters
$sel:headParameters:InitTx :: HeadParameters
headParameters :: HeadParameters
headParameters
                    , $sel:openVersion:InitTx :: SnapshotVersion
openVersion = SnapshotVersion
version
                    , $sel:contestingSnapshot:InitTx :: ConfirmedSnapshot tx
contestingSnapshot = ConfirmedSnapshot tx
confirmedSnapshot
                    }
              }
      else Outcome tx
outcome

  CoordinatedHeadState{ConfirmedSnapshot tx
$sel:confirmedSnapshot:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> ConfirmedSnapshot tx
confirmedSnapshot :: ConfirmedSnapshot tx
confirmedSnapshot, SnapshotVersion
$sel:version:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> SnapshotVersion
version :: SnapshotVersion
version} = CoordinatedHeadState tx
coordinatedHeadState

  OpenState{$sel:parameters:OpenState :: forall tx. OpenState tx -> HeadParameters
parameters = HeadParameters
headParameters, HeadId
$sel:headId:OpenState :: forall tx. OpenState tx -> HeadId
headId :: HeadId
headId, CoordinatedHeadState tx
$sel:coordinatedHeadState:OpenState :: forall tx. OpenState tx -> CoordinatedHeadState tx
coordinatedHeadState :: CoordinatedHeadState tx
coordinatedHeadState} = OpenState tx
openState

-- | Client request to side load confirmed snapshot.
--
-- Note this is not covered by the spec as it is not reachable from an organic use of the protocol.
--
-- It must not have any effects outside of a neutral modification of the state to:
-- * something it was before (in the case of the initial snapshot).
-- * something it would be using side communication (in the case of a confirmed snapshot).
--
-- Besides the above, it is expected to work very much like the confirmed snapshot.
--
-- __Transition__: 'OpenState' → 'OpenState'
onOpenClientSideLoadSnapshot :: IsTx tx => OpenState tx -> ConfirmedSnapshot tx -> Outcome tx
onOpenClientSideLoadSnapshot :: forall tx.
IsTx tx =>
OpenState tx -> ConfirmedSnapshot tx -> Outcome tx
onOpenClientSideLoadSnapshot OpenState tx
openState ConfirmedSnapshot tx
requestedConfirmedSnapshot =
  case ConfirmedSnapshot tx
requestedConfirmedSnapshot of
    InitialSnapshot{} ->
      Outcome tx -> Outcome tx
requireVerifiedSameSnapshot (Outcome tx -> Outcome tx) -> Outcome tx -> Outcome tx
forall a b. (a -> b) -> a -> b
$
        StateChanged tx -> Outcome tx
forall tx. StateChanged tx -> Outcome tx
newState LocalStateCleared{HeadId
$sel:headId:NetworkConnected :: HeadId
headId :: HeadId
headId, $sel:snapshotNumber:NetworkConnected :: SnapshotNumber
snapshotNumber = SnapshotNumber
requestedSn}
    ConfirmedSnapshot{Snapshot tx
$sel:snapshot:InitialSnapshot :: forall tx. ConfirmedSnapshot tx -> Snapshot tx
snapshot :: Snapshot tx
snapshot, MultiSignature (Snapshot tx)
$sel:signatures:InitialSnapshot :: forall tx. ConfirmedSnapshot tx -> MultiSignature (Snapshot tx)
signatures :: MultiSignature (Snapshot tx)
signatures} ->
      Outcome tx -> Outcome tx
requireVerifiedSnapshotNumber (Outcome tx -> Outcome tx) -> Outcome tx -> Outcome tx
forall a b. (a -> b) -> a -> b
$
        Outcome tx -> Outcome tx
requireVerifiedL1Snapshot (Outcome tx -> Outcome tx) -> Outcome tx -> Outcome tx
forall a b. (a -> b) -> a -> b
$
          Snapshot tx
-> MultiSignature (Snapshot tx) -> Outcome tx -> Outcome tx
requireVerifiedMultisignature Snapshot tx
snapshot MultiSignature (Snapshot tx)
signatures (Outcome tx -> Outcome tx) -> Outcome tx -> Outcome tx
forall a b. (a -> b) -> a -> b
$
            [StateChanged tx] -> Outcome tx
forall tx. [StateChanged tx] -> Outcome tx
changes
              [ SnapshotConfirmed{HeadId
$sel:headId:NetworkConnected :: HeadId
headId :: HeadId
headId, $sel:snapshot:NetworkConnected :: Maybe (Snapshot tx)
snapshot = Snapshot tx -> Maybe (Snapshot tx)
forall a. a -> Maybe a
Just Snapshot tx
snapshot, MultiSignature (Snapshot tx)
$sel:signatures:NetworkConnected :: MultiSignature (Snapshot tx)
signatures :: MultiSignature (Snapshot tx)
signatures}
              , LocalStateCleared{HeadId
$sel:headId:NetworkConnected :: HeadId
headId :: HeadId
headId, $sel:snapshotNumber:NetworkConnected :: SnapshotNumber
snapshotNumber = SnapshotNumber
requestedSn}
              ]
 where
  OpenState
    { HeadId
$sel:headId:OpenState :: forall tx. OpenState tx -> HeadId
headId :: HeadId
headId
    , $sel:parameters:OpenState :: forall tx. OpenState tx -> HeadParameters
parameters = HeadParameters{[Party]
$sel:parties:HeadParameters :: HeadParameters -> [Party]
parties :: [Party]
parties}
    , CoordinatedHeadState tx
$sel:coordinatedHeadState:OpenState :: forall tx. OpenState tx -> CoordinatedHeadState tx
coordinatedHeadState :: CoordinatedHeadState tx
coordinatedHeadState
    } = OpenState tx
openState

  CoordinatedHeadState
    { $sel:confirmedSnapshot:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> ConfirmedSnapshot tx
confirmedSnapshot = ConfirmedSnapshot tx
currentConfirmedSnapshot
    } = CoordinatedHeadState tx
coordinatedHeadState

  vkeys :: [VerificationKey HydraKey]
vkeys = Party -> VerificationKey HydraKey
vkey (Party -> VerificationKey HydraKey)
-> [Party] -> [VerificationKey HydraKey]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Party]
parties

  currentSnapshot :: Snapshot tx
currentSnapshot@Snapshot
    { $sel:version:Snapshot :: forall tx. Snapshot tx -> SnapshotVersion
version = SnapshotVersion
lastSeenSv
    , $sel:number:Snapshot :: forall tx. Snapshot tx -> SnapshotNumber
number = SnapshotNumber
lastSeenSn
    , $sel:utxoToCommit:Snapshot :: forall tx. Snapshot tx -> Maybe (UTxOType tx)
utxoToCommit = Maybe (UTxOType tx)
lastSeenSc
    , $sel:depositTxId:Snapshot :: forall tx. Snapshot tx -> Maybe (TxIdType tx)
depositTxId = Maybe (TxIdType tx)
lastSeenDeposit
    , $sel:utxoToDecommit:Snapshot :: forall tx. Snapshot tx -> Maybe (UTxOType tx)
utxoToDecommit = Maybe (UTxOType tx)
lastSeenSd
    } = ConfirmedSnapshot tx -> Snapshot tx
forall tx. IsTx tx => ConfirmedSnapshot tx -> Snapshot tx
getSnapshot ConfirmedSnapshot tx
currentConfirmedSnapshot

  requestedSnapshot :: Snapshot tx
requestedSnapshot@Snapshot
    { $sel:version:Snapshot :: forall tx. Snapshot tx -> SnapshotVersion
version = SnapshotVersion
requestedSv
    , $sel:number:Snapshot :: forall tx. Snapshot tx -> SnapshotNumber
number = SnapshotNumber
requestedSn
    , $sel:utxoToCommit:Snapshot :: forall tx. Snapshot tx -> Maybe (UTxOType tx)
utxoToCommit = Maybe (UTxOType tx)
requestedSc
    , $sel:depositTxId:Snapshot :: forall tx. Snapshot tx -> Maybe (TxIdType tx)
depositTxId = Maybe (TxIdType tx)
requestedDeposit
    , $sel:utxoToDecommit:Snapshot :: forall tx. Snapshot tx -> Maybe (UTxOType tx)
utxoToDecommit = Maybe (UTxOType tx)
requestedSd
    } = ConfirmedSnapshot tx -> Snapshot tx
forall tx. IsTx tx => ConfirmedSnapshot tx -> Snapshot tx
getSnapshot ConfirmedSnapshot tx
requestedConfirmedSnapshot

  clientInput :: ClientInput tx
clientInput = ConfirmedSnapshot tx -> ClientInput tx
forall tx. ConfirmedSnapshot tx -> ClientInput tx
SideLoadSnapshot ConfirmedSnapshot tx
requestedConfirmedSnapshot

  sideLoadFailed :: SideLoadRequirementFailure tx -> Outcome tx
sideLoadFailed SideLoadRequirementFailure tx
requirementFailure =
    Effect tx -> Outcome tx
forall tx. Effect tx -> Outcome tx
cause (Effect tx -> Outcome tx)
-> (ClientMessage tx -> Effect tx)
-> ClientMessage tx
-> Outcome tx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClientMessage tx -> Effect tx
forall tx. ClientMessage tx -> Effect tx
ClientEffect (ClientMessage tx -> Outcome tx) -> ClientMessage tx -> Outcome tx
forall a b. (a -> b) -> a -> b
$
      ServerOutput.SideLoadSnapshotRejected{ClientInput tx
clientInput :: ClientInput tx
$sel:clientInput:CommandFailed :: ClientInput tx
clientInput, SideLoadRequirementFailure tx
requirementFailure :: SideLoadRequirementFailure tx
$sel:requirementFailure:CommandFailed :: SideLoadRequirementFailure tx
requirementFailure}

  requireVerifiedSameSnapshot :: Outcome tx -> Outcome tx
requireVerifiedSameSnapshot Outcome tx
cont =
    if Snapshot tx
requestedSnapshot Snapshot tx -> Snapshot tx -> Bool
forall a. Eq a => a -> a -> Bool
== Snapshot tx
currentSnapshot
      then Outcome tx
cont
      else SideLoadRequirementFailure tx -> Outcome tx
sideLoadFailed SideLoadRequirementFailure tx
forall tx. SideLoadRequirementFailure tx
SideLoadInitialSnapshotMismatch

  requireVerifiedSnapshotNumber :: Outcome tx -> Outcome tx
requireVerifiedSnapshotNumber Outcome tx
cont =
    if SnapshotNumber
requestedSn SnapshotNumber -> SnapshotNumber -> Bool
forall a. Ord a => a -> a -> Bool
>= SnapshotNumber
lastSeenSn
      then Outcome tx
cont
      else SideLoadRequirementFailure tx -> Outcome tx
sideLoadFailed SideLoadSnNumberInvalid{SnapshotNumber
requestedSn :: SnapshotNumber
$sel:requestedSn:SideLoadInitialSnapshotMismatch :: SnapshotNumber
requestedSn, SnapshotNumber
lastSeenSn :: SnapshotNumber
$sel:lastSeenSn:SideLoadInitialSnapshotMismatch :: SnapshotNumber
lastSeenSn}

  requireVerifiedL1Snapshot :: Outcome tx -> Outcome tx
requireVerifiedL1Snapshot Outcome tx
cont
    | SnapshotVersion
requestedSv SnapshotVersion -> SnapshotVersion -> Bool
forall a. Eq a => a -> a -> Bool
/= SnapshotVersion
lastSeenSv = SideLoadRequirementFailure tx -> Outcome tx
sideLoadFailed SideLoadSvNumberInvalid{SnapshotVersion
requestedSv :: SnapshotVersion
$sel:requestedSv:SideLoadInitialSnapshotMismatch :: SnapshotVersion
requestedSv, SnapshotVersion
lastSeenSv :: SnapshotVersion
$sel:lastSeenSv:SideLoadInitialSnapshotMismatch :: SnapshotVersion
lastSeenSv}
    | Maybe (UTxOType tx)
requestedSc Maybe (UTxOType tx) -> Maybe (UTxOType tx) -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe (UTxOType tx)
lastSeenSc = SideLoadRequirementFailure tx -> Outcome tx
sideLoadFailed SideLoadUTxOToCommitInvalid{Maybe (UTxOType tx)
requestedSc :: Maybe (UTxOType tx)
$sel:requestedSc:SideLoadInitialSnapshotMismatch :: Maybe (UTxOType tx)
requestedSc, Maybe (UTxOType tx)
lastSeenSc :: Maybe (UTxOType tx)
$sel:lastSeenSc:SideLoadInitialSnapshotMismatch :: Maybe (UTxOType tx)
lastSeenSc}
    -- The pending commit is L1-relevant state, and since the binding change it is
    -- the deposit that identifies it, not the committed content.
    | Maybe (TxIdType tx)
requestedDeposit Maybe (TxIdType tx) -> Maybe (TxIdType tx) -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe (TxIdType tx)
lastSeenDeposit = SideLoadRequirementFailure tx -> Outcome tx
sideLoadFailed SideLoadDepositTxIdInvalid{Maybe (TxIdType tx)
requestedDeposit :: Maybe (TxIdType tx)
$sel:requestedDeposit:SideLoadInitialSnapshotMismatch :: Maybe (TxIdType tx)
requestedDeposit, Maybe (TxIdType tx)
lastSeenDeposit :: Maybe (TxIdType tx)
$sel:lastSeenDeposit:SideLoadInitialSnapshotMismatch :: Maybe (TxIdType tx)
lastSeenDeposit}
    | Maybe (UTxOType tx)
requestedSd Maybe (UTxOType tx) -> Maybe (UTxOType tx) -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe (UTxOType tx)
lastSeenSd = SideLoadRequirementFailure tx -> Outcome tx
sideLoadFailed SideLoadUTxOToDecommitInvalid{Maybe (UTxOType tx)
requestedSd :: Maybe (UTxOType tx)
$sel:requestedSd:SideLoadInitialSnapshotMismatch :: Maybe (UTxOType tx)
requestedSd, Maybe (UTxOType tx)
lastSeenSd :: Maybe (UTxOType tx)
$sel:lastSeenSd:SideLoadInitialSnapshotMismatch :: Maybe (UTxOType tx)
lastSeenSd}
    | Bool
otherwise = Outcome tx
cont

  requireVerifiedMultisignature :: Snapshot tx
-> MultiSignature (Snapshot tx) -> Outcome tx -> Outcome tx
requireVerifiedMultisignature Snapshot tx
snapshot MultiSignature (Snapshot tx)
signatories Outcome tx
cont =
    case [VerificationKey HydraKey]
-> MultiSignature (Snapshot tx) -> Snapshot tx -> Verified
forall a.
SignableRepresentation a =>
[VerificationKey HydraKey] -> MultiSignature a -> a -> Verified
verifyMultiSignature [VerificationKey HydraKey]
vkeys MultiSignature (Snapshot tx)
signatories Snapshot tx
snapshot of
      Verified
Verified -> Outcome tx
cont
      FailedKeys [VerificationKey HydraKey]
failures ->
        SideLoadRequirementFailure tx -> Outcome tx
sideLoadFailed SideLoadInvalidMultisignature{$sel:multisig:SideLoadInitialSnapshotMismatch :: Text
multisig = MultiSignature (Snapshot tx) -> Text
forall b a. (Show a, IsString b) => a -> b
show MultiSignature (Snapshot tx)
signatories, $sel:vkeys:SideLoadInitialSnapshotMismatch :: [VerificationKey HydraKey]
vkeys = [VerificationKey HydraKey]
failures}
      Verified
KeyNumberMismatch ->
        SideLoadRequirementFailure tx -> Outcome tx
sideLoadFailed SideLoadInvalidMultisignature{$sel:multisig:SideLoadInitialSnapshotMismatch :: Text
multisig = MultiSignature (Snapshot tx) -> Text
forall b a. (Show a, IsString b) => a -> b
show MultiSignature (Snapshot tx)
signatories, [VerificationKey HydraKey]
vkeys :: [VerificationKey HydraKey]
$sel:vkeys:SideLoadInitialSnapshotMismatch :: [VerificationKey HydraKey]
vkeys}

-- | Observe a contest transaction. If the contested snapshot number is smaller
-- than our last confirmed snapshot, we post a contest transaction.
--
-- __Transition__: 'ClosedState' → 'ClosedState'
onClosedChainContestTx ::
  IsTx tx =>
  ClosedState tx ->
  -- | New chain state.
  ChainStateType tx ->
  SnapshotNumber ->
  -- | Contestation deadline.
  UTCTime ->
  Outcome tx
onClosedChainContestTx :: forall tx.
IsTx tx =>
ClosedState tx
-> ChainStateType tx -> SnapshotNumber -> UTCTime -> Outcome tx
onClosedChainContestTx ClosedState tx
closedState ChainStateType tx
newChainState SnapshotNumber
snapshotNumber UTCTime
contestationDeadline =
  if
    | -- Spec: if ̅S.s > sc
      Snapshot tx -> SnapshotNumber
forall tx. Snapshot tx -> SnapshotNumber
number (ConfirmedSnapshot tx -> Snapshot tx
forall tx. IsTx tx => ConfirmedSnapshot tx -> Snapshot tx
getSnapshot ConfirmedSnapshot tx
confirmedSnapshot) SnapshotNumber -> SnapshotNumber -> Bool
forall a. Ord a => a -> a -> Bool
> SnapshotNumber
snapshotNumber ->
        -- Spec: η# ← ̅S.(η')#  (the confirmed snapshot's stored accumulator hash; not recomputed at close/contest)
        --       ξ ← ̅S.σ
        --       postTx (contest, ̅S.v, ̅S.s, η, ξ)
        StateChanged tx -> Outcome tx
forall tx. StateChanged tx -> Outcome tx
newState HeadContested{HeadId
$sel:headId:NetworkConnected :: HeadId
headId :: HeadId
headId, $sel:chainState:NetworkConnected :: ChainStateType tx
chainState = ChainStateType tx
newChainState, UTCTime
$sel:contestationDeadline:NetworkConnected :: UTCTime
contestationDeadline :: UTCTime
contestationDeadline, SnapshotNumber
$sel:snapshotNumber:NetworkConnected :: SnapshotNumber
snapshotNumber :: SnapshotNumber
snapshotNumber}
          Outcome tx -> Outcome tx -> Outcome tx
forall a. Semigroup a => a -> a -> a
<> Effect tx -> Outcome tx
forall tx. Effect tx -> Outcome tx
cause
            OnChainEffect
              { $sel:postChainTx:ClientEffect :: PostChainTx tx
postChainTx =
                  ContestTx
                    { HeadId
$sel:headId:InitTx :: HeadId
headId :: HeadId
headId
                    , HeadParameters
$sel:headParameters:InitTx :: HeadParameters
headParameters :: HeadParameters
headParameters
                    , $sel:openVersion:InitTx :: SnapshotVersion
openVersion = SnapshotVersion
version
                    , $sel:contestingSnapshot:InitTx :: ConfirmedSnapshot tx
contestingSnapshot = ConfirmedSnapshot tx
confirmedSnapshot
                    }
              }
    | SnapshotNumber
snapshotNumber SnapshotNumber -> SnapshotNumber -> Bool
forall a. Ord a => a -> a -> Bool
> Snapshot tx -> SnapshotNumber
forall tx. Snapshot tx -> SnapshotNumber
number (ConfirmedSnapshot tx -> Snapshot tx
forall tx. IsTx tx => ConfirmedSnapshot tx -> Snapshot tx
getSnapshot ConfirmedSnapshot tx
confirmedSnapshot) ->
        -- TODO: A more recent snapshot number was successfully contested, we will
        -- not be able to fanout! We might want to communicate that to the client!
        StateChanged tx -> Outcome tx
forall tx. StateChanged tx -> Outcome tx
newState HeadContested{HeadId
$sel:headId:NetworkConnected :: HeadId
headId :: HeadId
headId, $sel:chainState:NetworkConnected :: ChainStateType tx
chainState = ChainStateType tx
newChainState, UTCTime
$sel:contestationDeadline:NetworkConnected :: UTCTime
contestationDeadline :: UTCTime
contestationDeadline, SnapshotNumber
$sel:snapshotNumber:NetworkConnected :: SnapshotNumber
snapshotNumber :: SnapshotNumber
snapshotNumber}
    | Bool
otherwise ->
        StateChanged tx -> Outcome tx
forall tx. StateChanged tx -> Outcome tx
newState HeadContested{HeadId
$sel:headId:NetworkConnected :: HeadId
headId :: HeadId
headId, $sel:chainState:NetworkConnected :: ChainStateType tx
chainState = ChainStateType tx
newChainState, UTCTime
$sel:contestationDeadline:NetworkConnected :: UTCTime
contestationDeadline :: UTCTime
contestationDeadline, SnapshotNumber
$sel:snapshotNumber:NetworkConnected :: SnapshotNumber
snapshotNumber :: SnapshotNumber
snapshotNumber}
 where
  ClosedState{$sel:parameters:ClosedState :: forall tx. ClosedState tx -> HeadParameters
parameters = HeadParameters
headParameters, ConfirmedSnapshot tx
confirmedSnapshot :: ConfirmedSnapshot tx
$sel:confirmedSnapshot:ClosedState :: forall tx. ClosedState tx -> ConfirmedSnapshot tx
confirmedSnapshot, HeadId
headId :: HeadId
$sel:headId:ClosedState :: forall tx. ClosedState tx -> HeadId
headId, SnapshotVersion
version :: SnapshotVersion
$sel:version:ClosedState :: forall tx. ClosedState tx -> SnapshotVersion
version} = ClosedState tx
closedState

-- | Client request to fanout the whole closed head automatically. Emits a
-- 'FanoutTx'; the chain layer either lands a single full fanout (→ 'IdleState')
-- or falls back to dynamically-chunked partial fanouts. The first observed
-- partial fanout transitions the head to 'PartialFanout' in 'AutoDrain' mode,
-- which keeps draining the rest automatically until the final (burning) step.
--
-- This node becomes the fanout /driver/: it transitions into 'PartialFanout' in
-- 'AutoDrain' mode so that, as the chain layer chunks the fanout, /this/ node
-- auto-continues to completion. Other parties that merely observe the resulting
-- partial fanout do not auto-drive (see 'onClosedChainPartialFanoutTx').
--
-- __Transition__: 'ClosedState' → 'PartialFanoutState' (then → 'IdleState' once
-- the final fanout is observed).
onClosedClientFanout ::
  IsTx tx =>
  ClosedState tx ->
  Outcome tx
onClosedClientFanout :: forall tx. IsTx tx => ClosedState tx -> Outcome tx
onClosedClientFanout ClosedState tx
closedState =
  StateChanged tx -> Outcome tx
forall tx. StateChanged tx -> Outcome tx
newState HeadFanoutInitiated{HeadId
$sel:headId:NetworkConnected :: HeadId
headId :: HeadId
headId, $sel:remainingOutputs:NetworkConnected :: UTxOType tx
remainingOutputs = ClosedState tx -> UTxOType tx
forall tx. IsTx tx => ClosedState tx -> UTxOType tx
computeFullFanoutUTxO ClosedState tx
closedState}
    Outcome tx -> Outcome tx -> Outcome tx
forall a. Semigroup a => a -> a -> a
<> Effect tx -> Outcome tx
forall tx. Effect tx -> Outcome tx
cause OnChainEffect{$sel:postChainTx:ClientEffect :: PostChainTx tx
postChainTx = ConfirmedSnapshot tx
-> SnapshotVersion -> HeadSeed -> UTCTime -> PostChainTx tx
forall tx.
IsTx tx =>
ConfirmedSnapshot tx
-> SnapshotVersion -> HeadSeed -> UTCTime -> PostChainTx tx
mkFullFanoutTx ConfirmedSnapshot tx
confirmedSnapshot SnapshotVersion
version HeadSeed
headSeed UTCTime
contestationDeadline}
 where
  ClosedState{HeadId
$sel:headId:ClosedState :: forall tx. ClosedState tx -> HeadId
headId :: HeadId
headId, ConfirmedSnapshot tx
$sel:confirmedSnapshot:ClosedState :: forall tx. ClosedState tx -> ConfirmedSnapshot tx
confirmedSnapshot :: ConfirmedSnapshot tx
confirmedSnapshot, SnapshotVersion
$sel:version:ClosedState :: forall tx. ClosedState tx -> SnapshotVersion
version :: SnapshotVersion
version, HeadSeed
headSeed :: HeadSeed
$sel:headSeed:ClosedState :: forall tx. ClosedState tx -> HeadSeed
headSeed, UTCTime
contestationDeadline :: UTCTime
$sel:contestationDeadline:ClosedState :: forall tx. ClosedState tx -> UTCTime
contestationDeadline} = ClosedState tx
closedState

-- | Given the on-chain @version@ and a snapshot's own version, decide which of a
-- pending commit / decommit is still to be distributed on fanout. When the
-- increment has landed on chain (versions match) the commit was already applied
-- (drop it) while a pending decommit still applies; otherwise the commit still
-- applies and the decommit was already paid out. Centralises the version check
-- shared by 'mkFullFanoutTx' and 'fanoutUTxOFromSnapshot'.
effectiveCommitDecommit ::
  -- | On-chain version
  SnapshotVersion ->
  -- | Snapshot version
  SnapshotVersion ->
  -- | Pending commit
  Maybe (UTxOType tx) ->
  -- | Pending decommit
  Maybe (UTxOType tx) ->
  (Maybe (UTxOType tx), Maybe (UTxOType tx))
effectiveCommitDecommit :: forall tx.
SnapshotVersion
-> SnapshotVersion
-> Maybe (UTxOType tx)
-> Maybe (UTxOType tx)
-> (Maybe (UTxOType tx), Maybe (UTxOType tx))
effectiveCommitDecommit SnapshotVersion
onChainVersion SnapshotVersion
snapshotVersion Maybe (UTxOType tx)
utxoToCommit Maybe (UTxOType tx)
utxoToDecommit
  | SnapshotVersion
snapshotVersion SnapshotVersion -> SnapshotVersion -> Bool
forall a. Eq a => a -> a -> Bool
== SnapshotVersion
onChainVersion = (Maybe (UTxOType tx)
forall a. Maybe a
Nothing, Maybe (UTxOType tx)
utxoToDecommit)
  | Bool
otherwise = (Maybe (UTxOType tx)
utxoToCommit, Maybe (UTxOType tx)
forall a. Maybe a
Nothing)

-- | Build the full automatic 'FanoutTx' from a confirmed snapshot at the given
-- on-chain version. Shared by 'onClosedClientFanout' and the rollback re-post in
-- 'FanoutProgress' ('repostFanoutStep').
mkFullFanoutTx ::
  IsTx tx =>
  ConfirmedSnapshot tx ->
  SnapshotVersion ->
  HeadSeed ->
  UTCTime ->
  PostChainTx tx
mkFullFanoutTx :: forall tx.
IsTx tx =>
ConfirmedSnapshot tx
-> SnapshotVersion -> HeadSeed -> UTCTime -> PostChainTx tx
mkFullFanoutTx ConfirmedSnapshot tx
confirmedSnapshot SnapshotVersion
version HeadSeed
headSeed UTCTime
contestationDeadline =
  FanoutTx
    { UTxOType tx
utxo :: UTxOType tx
$sel:utxo:InitTx :: UTxOType tx
utxo
    , $sel:utxoToCommit:InitTx :: Maybe (UTxOType tx)
utxoToCommit = Maybe (UTxOType tx)
effectiveCommit
    , $sel:utxoToDecommit:InitTx :: Maybe (UTxOType tx)
utxoToDecommit = Maybe (UTxOType tx)
effectiveDecommit
    , -- Always use the snapshot's original (unfiltered) full UTxO set to rebuild
      -- the accumulator that matches the closed datum.
      $sel:utxoForProof:InitTx :: UTxOType tx
utxoForProof = Snapshot tx -> UTxOType tx
forall tx. IsTx tx => Snapshot tx -> UTxOType tx
snapshotUTxO Snapshot tx
snapshot
    , HeadSeed
$sel:headSeed:InitTx :: HeadSeed
headSeed :: HeadSeed
headSeed
    , UTCTime
contestationDeadline :: UTCTime
$sel:contestationDeadline:InitTx :: UTCTime
contestationDeadline
    }
 where
  (Maybe (UTxOType tx)
effectiveCommit, Maybe (UTxOType tx)
effectiveDecommit) = SnapshotVersion
-> SnapshotVersion
-> Maybe (UTxOType tx)
-> Maybe (UTxOType tx)
-> (Maybe (UTxOType tx), Maybe (UTxOType tx))
forall tx.
SnapshotVersion
-> SnapshotVersion
-> Maybe (UTxOType tx)
-> Maybe (UTxOType tx)
-> (Maybe (UTxOType tx), Maybe (UTxOType tx))
effectiveCommitDecommit SnapshotVersion
version SnapshotVersion
snapshotVersion Maybe (UTxOType tx)
utxoToCommit Maybe (UTxOType tx)
utxoToDecommit
  snapshot :: Snapshot tx
snapshot = ConfirmedSnapshot tx -> Snapshot tx
forall tx. IsTx tx => ConfirmedSnapshot tx -> Snapshot tx
getSnapshot ConfirmedSnapshot tx
confirmedSnapshot
  Snapshot{UTxOType tx
$sel:utxo:Snapshot :: forall tx. Snapshot tx -> UTxOType tx
utxo :: UTxOType tx
utxo, Maybe (UTxOType tx)
$sel:utxoToCommit:Snapshot :: forall tx. Snapshot tx -> Maybe (UTxOType tx)
utxoToCommit :: Maybe (UTxOType tx)
utxoToCommit, Maybe (UTxOType tx)
$sel:utxoToDecommit:Snapshot :: forall tx. Snapshot tx -> Maybe (UTxOType tx)
utxoToDecommit :: Maybe (UTxOType tx)
utxoToDecommit, $sel:version:Snapshot :: forall tx. Snapshot tx -> SnapshotVersion
version = SnapshotVersion
snapshotVersion} = Snapshot tx
snapshot

-- | Client request to fan out a user-selected subset of a freshly closed head.
-- Validates the selection is a non-empty sub-multiset (by content) of the
-- fan-out-able UTxO, transitions the head into 'PartialFanout' (in
-- 'DistributingSelection' mode) and emits the first 'PartialFanoutTx'.
--
-- __Transition__: 'ClosedState' → 'PartialFanoutState'
onClosedClientPartialFanout ::
  IsTx tx =>
  ClosedState tx ->
  UTxOType tx ->
  Outcome tx
onClosedClientPartialFanout :: forall tx. IsTx tx => ClosedState tx -> UTxOType tx -> Outcome tx
onClosedClientPartialFanout ClosedState tx
closedState UTxOType tx
selection
  | UTxOType tx -> Bool
forall tx. IsTx tx => UTxOType tx -> Bool
nullOutputs UTxOType tx
selection Bool -> Bool -> Bool
|| Bool -> Bool
not (UTxOType tx
selection UTxOType tx -> UTxOType tx -> Bool
forall tx. IsTx tx => UTxOType tx -> UTxOType tx -> Bool
`isSubMultisetOf` UTxOType tx
fullUTxO) =
      Effect tx -> Outcome tx
forall tx. Effect tx -> Outcome tx
cause (Effect tx -> Outcome tx)
-> (ClientMessage tx -> Effect tx)
-> ClientMessage tx
-> Outcome tx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClientMessage tx -> Effect tx
forall tx. ClientMessage tx -> Effect tx
ClientEffect (ClientMessage tx -> Outcome tx) -> ClientMessage tx -> Outcome tx
forall a b. (a -> b) -> a -> b
$ ClientInput tx -> HeadState tx -> ClientMessage tx
forall tx. ClientInput tx -> HeadState tx -> ClientMessage tx
ServerOutput.CommandFailed (UTxOType tx -> ClientInput tx
forall tx. UTxOType tx -> ClientInput tx
PartialFanout UTxOType tx
selection) (ClosedState tx -> HeadState tx
forall tx. ClosedState tx -> HeadState tx
Closed ClosedState tx
closedState)
  -- Selecting the whole head is just a full fanout: delegate to the automatic
  -- drain. This is both what the user means ("fan out everything") and avoids an
  -- impossible non-final partial fanout — a non-final batch must leave ≥1 UTxO, so
  -- a fresh head with a single UTxO could not be drained selectively otherwise.
  | UTxOType tx
selection UTxOType tx -> UTxOType tx -> Bool
forall tx. IsTx tx => UTxOType tx -> UTxOType tx -> Bool
`sameOutputs` UTxOType tx
fullUTxO = ClosedState tx -> Outcome tx
forall tx. IsTx tx => ClosedState tx -> Outcome tx
onClosedClientFanout ClosedState tx
closedState
  | Bool
otherwise =
      StateChanged tx -> Outcome tx
forall tx. StateChanged tx -> Outcome tx
newState HeadPartialFanoutSelected{HeadId
$sel:headId:NetworkConnected :: HeadId
headId :: HeadId
headId, $sel:remainingOutputs:NetworkConnected :: UTxOType tx
remainingOutputs = UTxOType tx
fullUTxO, UTxOType tx
selection :: UTxOType tx
$sel:selection:NetworkConnected :: UTxOType tx
selection}
        -- Fresh head: on-chain datum is still @Closed@, so the first step is a
        -- non-final 'PartialFanoutTx'.
        Outcome tx -> Outcome tx -> Outcome tx
forall a. Semigroup a => a -> a -> a
<> UTxOType tx
-> UTxOType tx
-> OnChainFanoutDatum
-> ConfirmedSnapshot tx
-> SnapshotVersion
-> HeadSeed
-> UTCTime
-> Outcome tx
forall tx.
IsTx tx =>
UTxOType tx
-> UTxOType tx
-> OnChainFanoutDatum
-> ConfirmedSnapshot tx
-> SnapshotVersion
-> HeadSeed
-> UTCTime
-> Outcome tx
emitPartialFanoutStep UTxOType tx
selection UTxOType tx
fullUTxO OnChainFanoutDatum
DatumClosed ConfirmedSnapshot tx
confirmedSnapshot SnapshotVersion
version HeadSeed
headSeed UTCTime
contestationDeadline
 where
  fullUTxO :: UTxOType tx
fullUTxO = ClosedState tx -> UTxOType tx
forall tx. IsTx tx => ClosedState tx -> UTxOType tx
computeFullFanoutUTxO ClosedState tx
closedState
  ClosedState{HeadId
$sel:headId:ClosedState :: forall tx. ClosedState tx -> HeadId
headId :: HeadId
headId, ConfirmedSnapshot tx
$sel:confirmedSnapshot:ClosedState :: forall tx. ClosedState tx -> ConfirmedSnapshot tx
confirmedSnapshot :: ConfirmedSnapshot tx
confirmedSnapshot, SnapshotVersion
$sel:version:ClosedState :: forall tx. ClosedState tx -> SnapshotVersion
version :: SnapshotVersion
version, HeadSeed
$sel:headSeed:ClosedState :: forall tx. ClosedState tx -> HeadSeed
headSeed :: HeadSeed
headSeed, UTCTime
$sel:contestationDeadline:ClosedState :: forall tx. ClosedState tx -> UTCTime
contestationDeadline :: UTCTime
contestationDeadline} = ClosedState tx
closedState

-- | Client request to continue a selective partial fanout. Validates the
-- selection against the current 'remainingOutputs', records it as the active
-- selection and emits the next step.
--
-- __Transition__: 'PartialFanoutState' → 'PartialFanoutState'
onPartialFanoutClientPartialFanout ::
  IsTx tx =>
  PartialFanoutState tx ->
  UTxOType tx ->
  Outcome tx
onPartialFanoutClientPartialFanout :: forall tx.
IsTx tx =>
PartialFanoutState tx -> UTxOType tx -> Outcome tx
onPartialFanoutClientPartialFanout PartialFanoutState tx
pfs UTxOType tx
selection
  | UTxOType tx -> Bool
forall tx. IsTx tx => UTxOType tx -> Bool
nullOutputs UTxOType tx
selection Bool -> Bool -> Bool
|| Bool -> Bool
not (UTxOType tx
selection UTxOType tx -> UTxOType tx -> Bool
forall tx. IsTx tx => UTxOType tx -> UTxOType tx -> Bool
`isSubMultisetOf` UTxOType tx
remainingOutputs) =
      Effect tx -> Outcome tx
forall tx. Effect tx -> Outcome tx
cause (Effect tx -> Outcome tx)
-> (ClientMessage tx -> Effect tx)
-> ClientMessage tx
-> Outcome tx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClientMessage tx -> Effect tx
forall tx. ClientMessage tx -> Effect tx
ClientEffect (ClientMessage tx -> Outcome tx) -> ClientMessage tx -> Outcome tx
forall a b. (a -> b) -> a -> b
$ ClientInput tx -> HeadState tx -> ClientMessage tx
forall tx. ClientInput tx -> HeadState tx -> ClientMessage tx
ServerOutput.CommandFailed (UTxOType tx -> ClientInput tx
forall tx. UTxOType tx -> ClientInput tx
PartialFanout UTxOType tx
selection) (PartialFanoutState tx -> HeadState tx
forall tx. PartialFanoutState tx -> HeadState tx
FanoutProgress PartialFanoutState tx
pfs)
  | Bool
otherwise =
      StateChanged tx -> Outcome tx
forall tx. StateChanged tx -> Outcome tx
newState HeadPartialFanoutSelected{HeadId
$sel:headId:NetworkConnected :: HeadId
headId :: HeadId
headId, UTxOType tx
$sel:remainingOutputs:NetworkConnected :: UTxOType tx
remainingOutputs :: UTxOType tx
remainingOutputs, UTxOType tx
$sel:selection:NetworkConnected :: UTxOType tx
selection :: UTxOType tx
selection}
        -- The on-chain datum is only @FanoutProgress@ once a partial fanout has
        -- actually landed (some outputs distributed); until then it is still
        -- @Closed@ and a 'FinalPartialFanoutTx' is not yet valid. Compute this
        -- the same way as 'repostFanoutStep' rather than assuming 'True'.
        Outcome tx -> Outcome tx -> Outcome tx
forall a. Semigroup a => a -> a -> a
<> UTxOType tx
-> UTxOType tx
-> OnChainFanoutDatum
-> ConfirmedSnapshot tx
-> SnapshotVersion
-> HeadSeed
-> UTCTime
-> Outcome tx
forall tx.
IsTx tx =>
UTxOType tx
-> UTxOType tx
-> OnChainFanoutDatum
-> ConfirmedSnapshot tx
-> SnapshotVersion
-> HeadSeed
-> UTCTime
-> Outcome tx
emitPartialFanoutStep UTxOType tx
selection UTxOType tx
remainingOutputs (UTxOType tx -> OnChainFanoutDatum
forall tx. IsTx tx => UTxOType tx -> OnChainFanoutDatum
onChainFanoutDatum UTxOType tx
distributedOutputs) ConfirmedSnapshot tx
confirmedSnapshot SnapshotVersion
version HeadSeed
headSeed UTCTime
contestationDeadline
 where
  PartialFanoutState{HeadId
headId :: HeadId
$sel:headId:PartialFanoutState :: forall tx. PartialFanoutState tx -> HeadId
headId, ConfirmedSnapshot tx
confirmedSnapshot :: ConfirmedSnapshot tx
$sel:confirmedSnapshot:PartialFanoutState :: forall tx. PartialFanoutState tx -> ConfirmedSnapshot tx
confirmedSnapshot, SnapshotVersion
version :: SnapshotVersion
$sel:version:PartialFanoutState :: forall tx. PartialFanoutState tx -> SnapshotVersion
version, HeadSeed
headSeed :: HeadSeed
$sel:headSeed:PartialFanoutState :: forall tx. PartialFanoutState tx -> HeadSeed
headSeed, UTCTime
contestationDeadline :: UTCTime
$sel:contestationDeadline:PartialFanoutState :: forall tx. PartialFanoutState tx -> UTCTime
contestationDeadline, UTxOType tx
remainingOutputs :: forall tx. PartialFanoutState tx -> UTxOType tx
remainingOutputs :: UTxOType tx
remainingOutputs, UTxOType tx
distributedOutputs :: UTxOType tx
$sel:distributedOutputs:PartialFanoutState :: forall tx. PartialFanoutState tx -> UTxOType tx
distributedOutputs} = PartialFanoutState tx
pfs

-- | Observe a (full or final) fanout transaction, finalizing the head.
--
-- __Transition__: 'ClosedState' → 'IdleState'
onClosedChainFanoutTx ::
  ClosedState tx ->
  -- | New chain state
  ChainStateType tx ->
  UTxOType tx ->
  Outcome tx
onClosedChainFanoutTx :: forall tx.
ClosedState tx -> ChainStateType tx -> UTxOType tx -> Outcome tx
onClosedChainFanoutTx ClosedState tx
closedState ChainStateType tx
newChainState UTxOType tx
fanoutUTxO =
  StateChanged tx -> Outcome tx
forall tx. StateChanged tx -> Outcome tx
newState HeadFannedOut{HeadId
$sel:headId:NetworkConnected :: HeadId
headId :: HeadId
headId, $sel:finalizedOutputs:NetworkConnected :: UTxOType tx
finalizedOutputs = UTxOType tx
fanoutUTxO, $sel:chainState:NetworkConnected :: ChainStateType tx
chainState = ChainStateType tx
newChainState}
 where
  ClosedState{HeadId
$sel:headId:ClosedState :: forall tx. ClosedState tx -> HeadId
headId :: HeadId
headId} = ClosedState tx
closedState

-- | Observe a partial fanout while this node is still 'Closed' — i.e. a partial
-- fanout this node did NOT initiate (another party did). The fanout driver moved
-- to 'PartialFanout' when it issued its 'Fanout'/'PartialFanout' command, so this
-- handler is only reached by passive observers.
--
-- The observer transitions into 'PartialFanout' in 'AwaitingSelection' mode and
-- does __not__ auto-drive the rest: only the driver advances the fanout. This is
-- what makes selective partial fanout work in a multi-party head — observers must
-- not steamroll the remaining UTxO the driver deliberately left.
--
-- __Transition__: 'ClosedState' → 'PartialFanoutState'
onClosedChainPartialFanoutTx ::
  IsTx tx =>
  ClosedState tx ->
  -- | New chain state
  ChainStateType tx ->
  -- | UTxO distributed in this partial fanout (keyed by new TxIn; values preserve duplicates)
  UTxOType tx ->
  Outcome tx
onClosedChainPartialFanoutTx :: forall tx.
IsTx tx =>
ClosedState tx -> ChainStateType tx -> UTxOType tx -> Outcome tx
onClosedChainPartialFanoutTx ClosedState tx
closedState ChainStateType tx
newChainState UTxOType tx
observedDistributed =
  let fullUTxO :: UTxOType tx
fullUTxO = ClosedState tx -> UTxOType tx
forall tx. IsTx tx => ClosedState tx -> UTxOType tx
computeFullFanoutUTxO ClosedState tx
closedState
      remaining :: UTxOType tx
remaining = [TxOutType tx] -> UTxOType tx -> UTxOType tx
forall tx. IsTx tx => [TxOutType tx] -> UTxOType tx -> UTxOType tx
removeDistributedOutputs (UTxOType tx -> [TxOutType tx]
forall tx. IsTx tx => UTxOType tx -> [TxOutType tx]
outputsOfUTxO UTxOType tx
observedDistributed) UTxOType tx
fullUTxO
      distributedUTxO :: UTxOType tx
distributedUTxO = UTxOType tx -> UTxOType tx -> UTxOType tx
forall tx. IsTx tx => UTxOType tx -> UTxOType tx -> UTxOType tx
withoutUTxO UTxOType tx
fullUTxO UTxOType tx
remaining
   in StateChanged tx -> Outcome tx
forall tx. StateChanged tx -> Outcome tx
newState
        HeadPartialFannedOut
          { HeadId
$sel:headId:NetworkConnected :: HeadId
headId :: HeadId
headId
          , $sel:distributedOutputs:NetworkConnected :: UTxOType tx
distributedOutputs = UTxOType tx
distributedUTxO
          , $sel:remainingOutputs:NetworkConnected :: UTxOType tx
remainingOutputs = UTxOType tx
remaining
          , $sel:chainState:NetworkConnected :: ChainStateType tx
chainState = ChainStateType tx
newChainState
          , $sel:mode:NetworkConnected :: FanoutMode tx
mode = FanoutMode tx
forall tx. FanoutMode tx
AwaitingSelection
          }
 where
  ClosedState{HeadId
$sel:headId:ClosedState :: forall tx. ClosedState tx -> HeadId
headId :: HeadId
headId} = ClosedState tx
closedState

-- | Observe a partial fanout while in 'PartialFanout'. Updates the remaining and
-- distributed sets and, depending on the current 'FanoutMode', either continues
-- draining automatically (or within the active selection) or waits for the next
-- 'PartialFanout' command.
--
-- __Transition__: 'PartialFanoutState' → 'PartialFanoutState'
onPartialFanoutChainPartialFanoutTx ::
  IsTx tx =>
  PartialFanoutState tx ->
  -- | New chain state
  ChainStateType tx ->
  -- | UTxO distributed in this partial fanout
  UTxOType tx ->
  Outcome tx
onPartialFanoutChainPartialFanoutTx :: forall tx.
IsTx tx =>
PartialFanoutState tx
-> ChainStateType tx -> UTxOType tx -> Outcome tx
onPartialFanoutChainPartialFanoutTx PartialFanoutState tx
pfs ChainStateType tx
newChainState UTxOType tx
observedDistributed =
  let observedOutputs :: [TxOutType tx]
observedOutputs = UTxOType tx -> [TxOutType tx]
forall tx. IsTx tx => UTxOType tx -> [TxOutType tx]
outputsOfUTxO UTxOType tx
observedDistributed
      remaining :: UTxOType tx
remaining = [TxOutType tx] -> UTxOType tx -> UTxOType tx
forall tx. IsTx tx => [TxOutType tx] -> UTxOType tx -> UTxOType tx
removeDistributedOutputs [TxOutType tx]
observedOutputs UTxOType tx
remainingOutputs
      distributedUTxO :: UTxOType tx
distributedUTxO = UTxOType tx -> UTxOType tx -> UTxOType tx
forall tx. IsTx tx => UTxOType tx -> UTxOType tx -> UTxOType tx
withoutUTxO UTxOType tx
remainingOutputs UTxOType tx
remaining
      newMode :: FanoutMode tx
newMode = case FanoutMode tx
mode of
        FanoutMode tx
AutoDrain -> FanoutMode tx
forall tx. FanoutMode tx
AutoDrain
        FanoutMode tx
AwaitingSelection -> FanoutMode tx
forall tx. FanoutMode tx
AwaitingSelection
        DistributingSelection UTxOType tx
sel ->
          let sel' :: UTxOType tx
sel' = [TxOutType tx] -> UTxOType tx -> UTxOType tx
forall tx. IsTx tx => [TxOutType tx] -> UTxOType tx -> UTxOType tx
removeDistributedOutputs [TxOutType tx]
observedOutputs UTxOType tx
sel
           in if UTxOType tx -> Bool
forall tx. IsTx tx => UTxOType tx -> Bool
nullOutputs UTxOType tx
sel' then FanoutMode tx
forall tx. FanoutMode tx
AwaitingSelection else UTxOType tx -> FanoutMode tx
forall tx. UTxOType tx -> FanoutMode tx
DistributingSelection UTxOType tx
sel'
      record :: Outcome tx
record =
        StateChanged tx -> Outcome tx
forall tx. StateChanged tx -> Outcome tx
newState
          HeadPartialFannedOut
            { HeadId
$sel:headId:NetworkConnected :: HeadId
headId :: HeadId
headId
            , $sel:distributedOutputs:NetworkConnected :: UTxOType tx
distributedOutputs = UTxOType tx
distributedUTxO
            , $sel:remainingOutputs:NetworkConnected :: UTxOType tx
remainingOutputs = UTxOType tx
remaining
            , $sel:chainState:NetworkConnected :: ChainStateType tx
chainState = ChainStateType tx
newChainState
            , $sel:mode:NetworkConnected :: FanoutMode tx
mode = FanoutMode tx
newMode
            }
      -- Already in 'FanoutProgress' on chain, so any continuation may finalize.
      finalize :: Outcome tx
finalize = UTxOType tx
-> UTxOType tx
-> OnChainFanoutDatum
-> ConfirmedSnapshot tx
-> SnapshotVersion
-> HeadSeed
-> UTCTime
-> Outcome tx
forall tx.
IsTx tx =>
UTxOType tx
-> UTxOType tx
-> OnChainFanoutDatum
-> ConfirmedSnapshot tx
-> SnapshotVersion
-> HeadSeed
-> UTCTime
-> Outcome tx
emitPartialFanoutStep UTxOType tx
remaining UTxOType tx
remaining OnChainFanoutDatum
DatumFanoutProgress ConfirmedSnapshot tx
confirmedSnapshot SnapshotVersion
version HeadSeed
headSeed UTCTime
contestationDeadline
      continue :: Outcome tx
continue
        -- The head's remaining set is now empty: emit the final (burning) step,
        -- which also distributes any pre-settled UTxO. This must happen regardless
        -- of mode — otherwise a selection that drains everything (e.g. when a
        -- pre-settled decommit UTxO keeps the on-chain accumulator non-empty) would
        -- stop at 'AwaitingSelection' and wedge the head, never burning the tokens.
        | UTxOType tx -> Bool
forall tx. IsTx tx => UTxOType tx -> Bool
nullOutputs UTxOType tx
remaining = Outcome tx
finalize
        | Bool
otherwise = case FanoutMode tx
newMode of
            FanoutMode tx
AutoDrain -> Outcome tx
finalize
            DistributingSelection UTxOType tx
sel' -> UTxOType tx
-> UTxOType tx
-> OnChainFanoutDatum
-> ConfirmedSnapshot tx
-> SnapshotVersion
-> HeadSeed
-> UTCTime
-> Outcome tx
forall tx.
IsTx tx =>
UTxOType tx
-> UTxOType tx
-> OnChainFanoutDatum
-> ConfirmedSnapshot tx
-> SnapshotVersion
-> HeadSeed
-> UTCTime
-> Outcome tx
emitPartialFanoutStep UTxOType tx
sel' UTxOType tx
remaining OnChainFanoutDatum
DatumFanoutProgress ConfirmedSnapshot tx
confirmedSnapshot SnapshotVersion
version HeadSeed
headSeed UTCTime
contestationDeadline
            FanoutMode tx
AwaitingSelection -> Outcome tx
forall tx. Outcome tx
noop
   in Outcome tx
record Outcome tx -> Outcome tx -> Outcome tx
forall a. Semigroup a => a -> a -> a
<> Outcome tx
continue
 where
  PartialFanoutState{HeadId
$sel:headId:PartialFanoutState :: forall tx. PartialFanoutState tx -> HeadId
headId :: HeadId
headId, ConfirmedSnapshot tx
$sel:confirmedSnapshot:PartialFanoutState :: forall tx. PartialFanoutState tx -> ConfirmedSnapshot tx
confirmedSnapshot :: ConfirmedSnapshot tx
confirmedSnapshot, SnapshotVersion
$sel:version:PartialFanoutState :: forall tx. PartialFanoutState tx -> SnapshotVersion
version :: SnapshotVersion
version, HeadSeed
$sel:headSeed:PartialFanoutState :: forall tx. PartialFanoutState tx -> HeadSeed
headSeed :: HeadSeed
headSeed, UTCTime
$sel:contestationDeadline:PartialFanoutState :: forall tx. PartialFanoutState tx -> UTCTime
contestationDeadline :: UTCTime
contestationDeadline, UTxOType tx
remainingOutputs :: forall tx. PartialFanoutState tx -> UTxOType tx
remainingOutputs :: UTxOType tx
remainingOutputs, FanoutMode tx
mode :: FanoutMode tx
$sel:mode:PartialFanoutState :: forall tx. PartialFanoutState tx -> FanoutMode tx
mode} = PartialFanoutState tx
pfs

-- | Observe the final fanout while in 'PartialFanout', finalizing the head with
-- the accumulated distributed outputs plus this final batch.
--
-- __Transition__: 'PartialFanoutState' → 'IdleState'
onPartialFanoutChainFanoutTx ::
  IsTx tx =>
  PartialFanoutState tx ->
  -- | New chain state
  ChainStateType tx ->
  UTxOType tx ->
  Outcome tx
onPartialFanoutChainFanoutTx :: forall tx.
IsTx tx =>
PartialFanoutState tx
-> ChainStateType tx -> UTxOType tx -> Outcome tx
onPartialFanoutChainFanoutTx PartialFanoutState tx
pfs ChainStateType tx
newChainState UTxOType tx
fanoutUTxO =
  StateChanged tx -> Outcome tx
forall tx. StateChanged tx -> Outcome tx
newState HeadFannedOut{HeadId
$sel:headId:NetworkConnected :: HeadId
headId :: HeadId
headId, $sel:finalizedOutputs:NetworkConnected :: UTxOType tx
finalizedOutputs = UTxOType tx
distributedOutputs UTxOType tx -> UTxOType tx -> UTxOType tx
forall a. Semigroup a => a -> a -> a
<> UTxOType tx
fanoutUTxO, $sel:chainState:NetworkConnected :: ChainStateType tx
chainState = ChainStateType tx
newChainState}
 where
  PartialFanoutState{HeadId
$sel:headId:PartialFanoutState :: forall tx. PartialFanoutState tx -> HeadId
headId :: HeadId
headId, UTxOType tx
$sel:distributedOutputs:PartialFanoutState :: forall tx. PartialFanoutState tx -> UTxOType tx
distributedOutputs :: UTxOType tx
distributedOutputs} = PartialFanoutState tx
pfs

-- | Compute the full UTxO set to be fanned out, combining snapshot utxo
-- with utxoToCommit/utxoToDecommit based on version.
computeFullFanoutUTxO ::
  IsTx tx =>
  ClosedState tx ->
  UTxOType tx
computeFullFanoutUTxO :: forall tx. IsTx tx => ClosedState tx -> UTxOType tx
computeFullFanoutUTxO ClosedState{ConfirmedSnapshot tx
$sel:confirmedSnapshot:ClosedState :: forall tx. ClosedState tx -> ConfirmedSnapshot tx
confirmedSnapshot :: ConfirmedSnapshot tx
confirmedSnapshot, SnapshotVersion
$sel:version:ClosedState :: forall tx. ClosedState tx -> SnapshotVersion
version :: SnapshotVersion
version} =
  ConfirmedSnapshot tx -> SnapshotVersion -> UTxOType tx
forall tx.
IsTx tx =>
ConfirmedSnapshot tx -> SnapshotVersion -> UTxOType tx
fanoutUTxOFromSnapshot ConfirmedSnapshot tx
confirmedSnapshot SnapshotVersion
version

-- | The fan-out-able UTxO of a confirmed snapshot at the given on-chain version:
-- the snapshot UTxO plus a pending commit (if the increment landed on chain) or a
-- pending decommit (if the decrement has not landed yet).
fanoutUTxOFromSnapshot ::
  IsTx tx =>
  ConfirmedSnapshot tx ->
  SnapshotVersion ->
  UTxOType tx
fanoutUTxOFromSnapshot :: forall tx.
IsTx tx =>
ConfirmedSnapshot tx -> SnapshotVersion -> UTxOType tx
fanoutUTxOFromSnapshot ConfirmedSnapshot tx
confirmedSnapshot SnapshotVersion
version =
  UTxOType tx
utxo
    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 Maybe (UTxOType tx)
effectiveCommit
    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 Maybe (UTxOType tx)
effectiveDecommit
 where
  Snapshot{UTxOType tx
$sel:utxo:Snapshot :: forall tx. Snapshot tx -> UTxOType tx
utxo :: UTxOType tx
utxo, Maybe (UTxOType tx)
$sel:utxoToCommit:Snapshot :: forall tx. Snapshot tx -> Maybe (UTxOType tx)
utxoToCommit :: Maybe (UTxOType tx)
utxoToCommit, Maybe (UTxOType tx)
$sel:utxoToDecommit:Snapshot :: forall tx. Snapshot tx -> Maybe (UTxOType tx)
utxoToDecommit :: Maybe (UTxOType tx)
utxoToDecommit, $sel:version:Snapshot :: forall tx. Snapshot tx -> SnapshotVersion
version = SnapshotVersion
snapshotVersion} = ConfirmedSnapshot tx -> Snapshot tx
forall tx. IsTx tx => ConfirmedSnapshot tx -> Snapshot tx
getSnapshot ConfirmedSnapshot tx
confirmedSnapshot
  (Maybe (UTxOType tx)
effectiveCommit, Maybe (UTxOType tx)
effectiveDecommit) = SnapshotVersion
-> SnapshotVersion
-> Maybe (UTxOType tx)
-> Maybe (UTxOType tx)
-> (Maybe (UTxOType tx), Maybe (UTxOType tx))
forall tx.
SnapshotVersion
-> SnapshotVersion
-> Maybe (UTxOType tx)
-> Maybe (UTxOType tx)
-> (Maybe (UTxOType tx), Maybe (UTxOType tx))
effectiveCommitDecommit SnapshotVersion
version SnapshotVersion
snapshotVersion Maybe (UTxOType tx)
utxoToCommit Maybe (UTxOType tx)
utxoToDecommit

-- | Build the 'PartialFanout' ('FanoutProgress') head state from a closed head,
-- carrying over the snapshot/parameters and using the given chain state, remaining
-- and distributed UTxO and fanout 'mode'. Shared by the three @Closed →
-- FanoutProgress@ transitions in 'aggregateNodeState'.
closedToFanoutProgress ::
  ClosedState tx ->
  ChainStateType tx ->
  UTxOType tx ->
  UTxOType tx ->
  FanoutMode tx ->
  HeadState tx
closedToFanoutProgress :: forall tx.
ClosedState tx
-> ChainStateType tx
-> UTxOType tx
-> UTxOType tx
-> FanoutMode tx
-> HeadState tx
closedToFanoutProgress ClosedState tx
closedState ChainStateType tx
chainState UTxOType tx
remaining UTxOType tx
distributed FanoutMode tx
mode =
  PartialFanoutState tx -> HeadState tx
forall tx. PartialFanoutState tx -> HeadState tx
FanoutProgress
    PartialFanoutState
      { HeadParameters
parameters :: HeadParameters
$sel:parameters:PartialFanoutState :: HeadParameters
parameters
      , ConfirmedSnapshot tx
$sel:confirmedSnapshot:PartialFanoutState :: ConfirmedSnapshot tx
confirmedSnapshot :: ConfirmedSnapshot tx
confirmedSnapshot
      , UTCTime
$sel:contestationDeadline:PartialFanoutState :: UTCTime
contestationDeadline :: UTCTime
contestationDeadline
      , ChainStateType tx
chainState :: ChainStateType tx
$sel:chainState:PartialFanoutState :: ChainStateType tx
chainState
      , HeadId
$sel:headId:PartialFanoutState :: HeadId
headId :: HeadId
headId
      , HeadSeed
$sel:headSeed:PartialFanoutState :: HeadSeed
headSeed :: HeadSeed
headSeed
      , SnapshotVersion
$sel:version:PartialFanoutState :: SnapshotVersion
version :: SnapshotVersion
version
      , remainingOutputs :: UTxOType tx
remainingOutputs = UTxOType tx
remaining
      , $sel:distributedOutputs:PartialFanoutState :: UTxOType tx
distributedOutputs = UTxOType tx
distributed
      , FanoutMode tx
$sel:mode:PartialFanoutState :: FanoutMode tx
mode :: FanoutMode tx
mode
      }
 where
  ClosedState{HeadParameters
$sel:parameters:ClosedState :: forall tx. ClosedState tx -> HeadParameters
parameters :: HeadParameters
parameters, ConfirmedSnapshot tx
$sel:confirmedSnapshot:ClosedState :: forall tx. ClosedState tx -> ConfirmedSnapshot tx
confirmedSnapshot :: ConfirmedSnapshot tx
confirmedSnapshot, UTCTime
$sel:contestationDeadline:ClosedState :: forall tx. ClosedState tx -> UTCTime
contestationDeadline :: UTCTime
contestationDeadline, HeadId
$sel:headId:ClosedState :: forall tx. ClosedState tx -> HeadId
headId :: HeadId
headId, HeadSeed
$sel:headSeed:ClosedState :: forall tx. ClosedState tx -> HeadSeed
headSeed :: HeadSeed
headSeed, SnapshotVersion
$sel:version:ClosedState :: forall tx. ClosedState tx -> SnapshotVersion
version :: SnapshotVersion
version} = ClosedState tx
closedState

-- | Rebuild the 'ClosedState' from a 'PartialFanoutState' when reverting an
-- optimistic 'Closed' → 'PartialFanout' transition (see 'HeadFanoutReverted').
-- 'readyToFanoutSent' is restored to 'True' because a fanout is only reachable
-- after the head was announced 'ReadyToFanout'.
fanoutProgressToClosed :: PartialFanoutState tx -> ClosedState tx
fanoutProgressToClosed :: forall tx. PartialFanoutState tx -> ClosedState tx
fanoutProgressToClosed PartialFanoutState tx
pfs =
  ClosedState
    { HeadParameters
$sel:parameters:ClosedState :: HeadParameters
parameters :: HeadParameters
parameters
    , ConfirmedSnapshot tx
$sel:confirmedSnapshot:ClosedState :: ConfirmedSnapshot tx
confirmedSnapshot :: ConfirmedSnapshot tx
confirmedSnapshot
    , UTCTime
$sel:contestationDeadline:ClosedState :: UTCTime
contestationDeadline :: UTCTime
contestationDeadline
    , readyToFanoutSent :: Bool
readyToFanoutSent = Bool
True
    , ChainStateType tx
chainState :: ChainStateType tx
$sel:chainState:ClosedState :: ChainStateType tx
chainState
    , HeadId
$sel:headId:ClosedState :: HeadId
headId :: HeadId
headId
    , HeadSeed
$sel:headSeed:ClosedState :: HeadSeed
headSeed :: HeadSeed
headSeed
    , SnapshotVersion
$sel:version:ClosedState :: SnapshotVersion
version :: SnapshotVersion
version
    }
 where
  PartialFanoutState{HeadParameters
$sel:parameters:PartialFanoutState :: forall tx. PartialFanoutState tx -> HeadParameters
parameters :: HeadParameters
parameters, ConfirmedSnapshot tx
$sel:confirmedSnapshot:PartialFanoutState :: forall tx. PartialFanoutState tx -> ConfirmedSnapshot tx
confirmedSnapshot :: ConfirmedSnapshot tx
confirmedSnapshot, UTCTime
$sel:contestationDeadline:PartialFanoutState :: forall tx. PartialFanoutState tx -> UTCTime
contestationDeadline :: UTCTime
contestationDeadline, ChainStateType tx
$sel:chainState:PartialFanoutState :: forall tx. PartialFanoutState tx -> ChainStateType tx
chainState :: ChainStateType tx
chainState, HeadId
$sel:headId:PartialFanoutState :: forall tx. PartialFanoutState tx -> HeadId
headId :: HeadId
headId, HeadSeed
$sel:headSeed:PartialFanoutState :: forall tx. PartialFanoutState tx -> HeadSeed
headSeed :: HeadSeed
headSeed, SnapshotVersion
$sel:version:PartialFanoutState :: forall tx. PartialFanoutState tx -> SnapshotVersion
version :: SnapshotVersion
version} = PartialFanoutState tx
pfs

-- | Whether a 'PostChainTx' is one of the fanout-posting transactions (used to
-- scope the optimistic-fanout revert to genuine fanout post failures).
isFanoutPostChainTx :: PostChainTx tx -> Bool
isFanoutPostChainTx :: forall tx. PostChainTx tx -> Bool
isFanoutPostChainTx = \case
  FanoutTx{} -> Bool
True
  PartialFanoutTx{} -> Bool
True
  FinalPartialFanoutTx{} -> Bool
True
  PostChainTx tx
_ -> Bool
False

removeDistributedOutputs :: IsTx tx => [TxOutType tx] -> UTxOType tx -> UTxOType tx
removeDistributedOutputs :: forall tx. IsTx tx => [TxOutType tx] -> UTxOType tx -> UTxOType tx
removeDistributedOutputs = (UTxOType tx -> [TxOutType tx] -> UTxOType tx)
-> [TxOutType tx] -> UTxOType tx -> UTxOType tx
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((UTxOType tx -> TxOutType tx -> UTxOType tx)
-> UTxOType tx -> [TxOutType tx] -> UTxOType tx
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ((TxOutType tx -> UTxOType tx -> UTxOType tx)
-> UTxOType tx -> TxOutType tx -> UTxOType tx
forall a b c. (a -> b -> c) -> b -> a -> c
flip TxOutType tx -> UTxOType tx -> UTxOType tx
forall tx. IsTx tx => TxOutType tx -> UTxOType tx -> UTxOType tx
removeOneOutputFromUTxO))

-- | Whether a UTxO has no outputs.
nullOutputs :: IsTx tx => UTxOType tx -> Bool
nullOutputs :: forall tx. IsTx tx => UTxOType tx -> Bool
nullOutputs = [TxOutType tx] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([TxOutType tx] -> Bool)
-> (UTxOType tx -> [TxOutType tx]) -> UTxOType tx -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTxOType tx -> [TxOutType tx]
forall tx. IsTx tx => UTxOType tx -> [TxOutType tx]
outputsOfUTxO

-- | Whether the outputs of @sub@ are a sub-multiset (by content) of @sup@. This
-- mirrors how partial fanout tracks distributed UTxO by content rather than by
-- 'TxIn', so a user-provided selection is validated against what is actually
-- still in the head.
isSubMultisetOf :: IsTx tx => UTxOType tx -> UTxOType tx -> Bool
isSubMultisetOf :: forall tx. IsTx tx => UTxOType tx -> UTxOType tx -> Bool
isSubMultisetOf UTxOType tx
sub UTxOType tx
sup =
  [TxOutType tx] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (UTxOType tx -> [TxOutType tx]
forall tx. IsTx tx => UTxOType tx -> [TxOutType tx]
outputsOfUTxO ([TxOutType tx] -> UTxOType tx -> UTxOType tx
forall tx. IsTx tx => [TxOutType tx] -> UTxOType tx -> UTxOType tx
removeDistributedOutputs (UTxOType tx -> [TxOutType tx]
forall tx. IsTx tx => UTxOType tx -> [TxOutType tx]
outputsOfUTxO UTxOType tx
sub) UTxOType tx
sup))
    Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [TxOutType tx] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (UTxOType tx -> [TxOutType tx]
forall tx. IsTx tx => UTxOType tx -> [TxOutType tx]
outputsOfUTxO UTxOType tx
sup)
    Int -> Int -> Int
forall a. Num a => a -> a -> a
- [TxOutType tx] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (UTxOType tx -> [TxOutType tx]
forall tx. IsTx tx => UTxOType tx -> [TxOutType tx]
outputsOfUTxO UTxOType tx
sub)

-- | Whether two UTxO sets have the same outputs (by content, as a multiset).
-- The @a == b@ short-circuit avoids the O(n²) multiset comparison in the common
-- case where both arguments are the same tracked set (e.g. the auto-drain
-- @sameOutputs remaining remaining@ check on every observed chunk), which is
-- exactly the large-UTxO heads partial fanout targets.
sameOutputs :: IsTx tx => UTxOType tx -> UTxOType tx -> Bool
sameOutputs :: forall tx. IsTx tx => UTxOType tx -> UTxOType tx -> Bool
sameOutputs UTxOType tx
a UTxOType tx
b =
  UTxOType tx
a UTxOType tx -> UTxOType tx -> Bool
forall a. Eq a => a -> a -> Bool
== UTxOType tx
b Bool -> Bool -> Bool
|| ([TxOutType tx] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (UTxOType tx -> [TxOutType tx]
forall tx. IsTx tx => UTxOType tx -> [TxOutType tx]
outputsOfUTxO UTxOType tx
a) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [TxOutType tx] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (UTxOType tx -> [TxOutType tx]
forall tx. IsTx tx => UTxOType tx -> [TxOutType tx]
outputsOfUTxO UTxOType tx
b) Bool -> Bool -> Bool
&& UTxOType tx
a UTxOType tx -> UTxOType tx -> Bool
forall tx. IsTx tx => UTxOType tx -> UTxOType tx -> Bool
`isSubMultisetOf` UTxOType tx
b)

-- | Which on-chain head datum the next fanout step will be posted against:
-- still @Closed@ (no partial fanout has landed yet) or already @FanoutProgress@.
-- A 'FinalPartialFanoutTx' (which burns the head tokens) is only valid once the
-- datum is 'DatumFanoutProgress'.
data OnChainFanoutDatum = DatumClosed | DatumFanoutProgress
  deriving stock (OnChainFanoutDatum -> OnChainFanoutDatum -> Bool
(OnChainFanoutDatum -> OnChainFanoutDatum -> Bool)
-> (OnChainFanoutDatum -> OnChainFanoutDatum -> Bool)
-> Eq OnChainFanoutDatum
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: OnChainFanoutDatum -> OnChainFanoutDatum -> Bool
== :: OnChainFanoutDatum -> OnChainFanoutDatum -> Bool
$c/= :: OnChainFanoutDatum -> OnChainFanoutDatum -> Bool
/= :: OnChainFanoutDatum -> OnChainFanoutDatum -> Bool
Eq)

-- | The on-chain datum implied by how much has been distributed so far: still
-- @Closed@ while nothing has landed, @FanoutProgress@ once some has.
onChainFanoutDatum :: IsTx tx => UTxOType tx -> OnChainFanoutDatum
onChainFanoutDatum :: forall tx. IsTx tx => UTxOType tx -> OnChainFanoutDatum
onChainFanoutDatum UTxOType tx
distributed
  | UTxOType tx -> Bool
forall tx. IsTx tx => UTxOType tx -> Bool
nullOutputs UTxOType tx
distributed = OnChainFanoutDatum
DatumClosed
  | Bool
otherwise = OnChainFanoutDatum
DatumFanoutProgress

-- | Emit the next partial fanout on-chain effect.
--
--  * When the chunk source @target@ covers the entire remaining set and the head
--    is already in @FanoutProgress@ on chain, emit the final 'FinalPartialFanoutTx'
--    that distributes the rest and burns the head tokens.
--  * Otherwise emit a non-final 'PartialFanoutTx' drawing from @target@. The
--    chain layer sizes the actual on-chain chunk dynamically.
emitPartialFanoutStep ::
  IsTx tx =>
  -- | Chunk source for the next step (the user selection remainder, or the whole
  --   remaining set when auto-draining)
  UTxOType tx ->
  -- | The head's full remaining set
  UTxOType tx ->
  -- | The on-chain datum the step is posted against. 'DatumClosed' only for the
  --   very first step from a @Closed@ head, where 'FinalPartialFanoutTx' is not
  --   yet possible.
  OnChainFanoutDatum ->
  ConfirmedSnapshot tx ->
  SnapshotVersion ->
  HeadSeed ->
  UTCTime ->
  Outcome tx
emitPartialFanoutStep :: forall tx.
IsTx tx =>
UTxOType tx
-> UTxOType tx
-> OnChainFanoutDatum
-> ConfirmedSnapshot tx
-> SnapshotVersion
-> HeadSeed
-> UTCTime
-> Outcome tx
emitPartialFanoutStep UTxOType tx
target UTxOType tx
remaining OnChainFanoutDatum
onChainDatum ConfirmedSnapshot tx
confirmedSnapshot SnapshotVersion
version HeadSeed
headSeed UTCTime
contestationDeadline
  | UTxOType tx
target UTxOType tx -> UTxOType tx -> Bool
forall tx. IsTx tx => UTxOType tx -> UTxOType tx -> Bool
`sameOutputs` UTxOType tx
remaining Bool -> Bool -> Bool
&& OnChainFanoutDatum
onChainDatum OnChainFanoutDatum -> OnChainFanoutDatum -> Bool
forall a. Eq a => a -> a -> Bool
== OnChainFanoutDatum
DatumFanoutProgress =
      Effect tx -> Outcome tx
forall tx. Effect tx -> Outcome tx
cause
        OnChainEffect
          { $sel:postChainTx:ClientEffect :: PostChainTx tx
postChainTx =
              FinalPartialFanoutTx
                { $sel:utxoToDistribute:InitTx :: UTxOType tx
utxoToDistribute = UTxOType tx
remaining
                , $sel:presettledUTxO:InitTx :: UTxOType tx
presettledUTxO = UTxOType tx
presettled
                , HeadSeed
$sel:headSeed:InitTx :: HeadSeed
headSeed :: HeadSeed
headSeed
                , UTCTime
$sel:contestationDeadline:InitTx :: UTCTime
contestationDeadline :: UTCTime
contestationDeadline
                }
          }
  | Bool
otherwise =
      Effect tx -> Outcome tx
forall tx. Effect tx -> Outcome tx
cause
        OnChainEffect
          { $sel:postChainTx:ClientEffect :: PostChainTx tx
postChainTx =
              PartialFanoutTx
                { $sel:utxoToDistribute:InitTx :: UTxOType tx
utxoToDistribute = UTxOType tx
target
                , UTxOType tx
$sel:utxoForProof:InitTx :: UTxOType tx
utxoForProof :: UTxOType tx
utxoForProof
                , HeadSeed
$sel:headSeed:InitTx :: HeadSeed
headSeed :: HeadSeed
headSeed
                , UTCTime
$sel:contestationDeadline:InitTx :: UTCTime
contestationDeadline :: UTCTime
contestationDeadline
                }
          }
 where
  fullUTxO :: UTxOType tx
fullUTxO = ConfirmedSnapshot tx -> SnapshotVersion -> UTxOType tx
forall tx.
IsTx tx =>
ConfirmedSnapshot tx -> SnapshotVersion -> UTxOType tx
fanoutUTxOFromSnapshot ConfirmedSnapshot tx
confirmedSnapshot SnapshotVersion
version
  -- Pre-settled elements: in the snapshot accumulator but never distributed
  -- (e.g. a decommit UTxO already paid out before close). mempty in normal case.
  presettled :: UTxOType tx
presettled = UTxOType tx -> UTxOType tx -> UTxOType tx
forall tx. IsTx tx => UTxOType tx -> UTxOType tx -> UTxOType tx
withoutUTxO (Snapshot tx -> UTxOType tx
forall tx. IsTx tx => Snapshot tx -> UTxOType tx
snapshotUTxO (ConfirmedSnapshot tx -> Snapshot tx
forall tx. IsTx tx => ConfirmedSnapshot tx -> Snapshot tx
getSnapshot ConfirmedSnapshot tx
confirmedSnapshot)) UTxOType tx
fullUTxO
  utxoForProof :: UTxOType tx
utxoForProof
    -- First step from a @Closed@ head: the datum's accumulator commits to the
    -- full snapshot UTxO.
    | OnChainFanoutDatum
onChainDatum OnChainFanoutDatum -> OnChainFanoutDatum -> Bool
forall a. Eq a => a -> a -> Bool
== OnChainFanoutDatum
DatumClosed = Snapshot tx -> UTxOType tx
forall tx. IsTx tx => Snapshot tx -> UTxOType tx
snapshotUTxO (ConfirmedSnapshot tx -> Snapshot tx
forall tx. IsTx tx => ConfirmedSnapshot tx -> Snapshot tx
getSnapshot ConfirmedSnapshot tx
confirmedSnapshot)
    -- Otherwise the head is in @FanoutProgress@, whose accumulator commits to the
    -- not-yet-distributed set plus any pre-settled elements.
    | Bool
otherwise = UTxOType tx
remaining UTxOType tx -> UTxOType tx -> UTxOType tx
forall a. Semigroup a => a -> a -> a
<> UTxOType tx
presettled

-- | Re-post the next fanout step after a chain rollback while in
-- 'FanoutProgress', so the fanout resumes instead of stalling with the
-- rolled-back transaction gone and nothing re-posted. This mirrors the
-- Increment/Decrement re-post on rollback ('maybeRepostIncrementTx' /
-- 'maybeRepostDecrementTx'): it uses the current best-effort bookkeeping and,
-- like those re-posts, assumes the rolled-back transactions re-appear — it does
-- not attempt to reconstruct fanout progress across a divergent rollback (the
-- same limitation the general rollback handling has).
--
-- @distributedOutputs@ being empty means no partial fanout has landed on chain
-- yet (the head datum is still @Closed@); otherwise the datum is
-- @FanoutProgress@ and a 'FinalPartialFanoutTx' is possible.
repostFanoutStep :: IsTx tx => PartialFanoutState tx -> Outcome tx
repostFanoutStep :: forall tx. IsTx tx => PartialFanoutState tx -> Outcome tx
repostFanoutStep PartialFanoutState tx
pfs =
  case FanoutMode tx
mode of
    -- Manual mode paused on the user: nothing to re-post, wait for the next
    -- 'PartialFanout' command.
    FanoutMode tx
AwaitingSelection -> Outcome tx
forall tx. Outcome tx
noop
    FanoutMode tx
AutoDrain
      -- Nothing distributed yet: re-post the full automatic fanout, exactly as
      -- the original 'Fanout' command did.
      | OnChainFanoutDatum
onChainDatum OnChainFanoutDatum -> OnChainFanoutDatum -> Bool
forall a. Eq a => a -> a -> Bool
== OnChainFanoutDatum
DatumClosed ->
          Effect tx -> Outcome tx
forall tx. Effect tx -> Outcome tx
cause OnChainEffect{$sel:postChainTx:ClientEffect :: PostChainTx tx
postChainTx = ConfirmedSnapshot tx
-> SnapshotVersion -> HeadSeed -> UTCTime -> PostChainTx tx
forall tx.
IsTx tx =>
ConfirmedSnapshot tx
-> SnapshotVersion -> HeadSeed -> UTCTime -> PostChainTx tx
mkFullFanoutTx ConfirmedSnapshot tx
confirmedSnapshot SnapshotVersion
version HeadSeed
headSeed UTCTime
contestationDeadline}
      | Bool
otherwise ->
          UTxOType tx
-> UTxOType tx
-> OnChainFanoutDatum
-> ConfirmedSnapshot tx
-> SnapshotVersion
-> HeadSeed
-> UTCTime
-> Outcome tx
forall tx.
IsTx tx =>
UTxOType tx
-> UTxOType tx
-> OnChainFanoutDatum
-> ConfirmedSnapshot tx
-> SnapshotVersion
-> HeadSeed
-> UTCTime
-> Outcome tx
emitPartialFanoutStep UTxOType tx
remainingOutputs UTxOType tx
remainingOutputs OnChainFanoutDatum
DatumFanoutProgress ConfirmedSnapshot tx
confirmedSnapshot SnapshotVersion
version HeadSeed
headSeed UTCTime
contestationDeadline
    DistributingSelection UTxOType tx
selection ->
      UTxOType tx
-> UTxOType tx
-> OnChainFanoutDatum
-> ConfirmedSnapshot tx
-> SnapshotVersion
-> HeadSeed
-> UTCTime
-> Outcome tx
forall tx.
IsTx tx =>
UTxOType tx
-> UTxOType tx
-> OnChainFanoutDatum
-> ConfirmedSnapshot tx
-> SnapshotVersion
-> HeadSeed
-> UTCTime
-> Outcome tx
emitPartialFanoutStep UTxOType tx
selection UTxOType tx
remainingOutputs OnChainFanoutDatum
onChainDatum ConfirmedSnapshot tx
confirmedSnapshot SnapshotVersion
version HeadSeed
headSeed UTCTime
contestationDeadline
 where
  onChainDatum :: OnChainFanoutDatum
onChainDatum = UTxOType tx -> OnChainFanoutDatum
forall tx. IsTx tx => UTxOType tx -> OnChainFanoutDatum
onChainFanoutDatum UTxOType tx
distributedOutputs
  PartialFanoutState{ConfirmedSnapshot tx
$sel:confirmedSnapshot:PartialFanoutState :: forall tx. PartialFanoutState tx -> ConfirmedSnapshot tx
confirmedSnapshot :: ConfirmedSnapshot tx
confirmedSnapshot, SnapshotVersion
$sel:version:PartialFanoutState :: forall tx. PartialFanoutState tx -> SnapshotVersion
version :: SnapshotVersion
version, HeadSeed
$sel:headSeed:PartialFanoutState :: forall tx. PartialFanoutState tx -> HeadSeed
headSeed :: HeadSeed
headSeed, UTCTime
$sel:contestationDeadline:PartialFanoutState :: forall tx. PartialFanoutState tx -> UTCTime
contestationDeadline :: UTCTime
contestationDeadline, UTxOType tx
remainingOutputs :: forall tx. PartialFanoutState tx -> UTxOType tx
remainingOutputs :: UTxOType tx
remainingOutputs, UTxOType tx
$sel:distributedOutputs:PartialFanoutState :: forall tx. PartialFanoutState tx -> UTxOType tx
distributedOutputs :: UTxOType tx
distributedOutputs, FanoutMode tx
$sel:mode:PartialFanoutState :: forall tx. PartialFanoutState tx -> FanoutMode tx
mode :: FanoutMode tx
mode} = PartialFanoutState tx
pfs

-- | Detect our view of the chain going out of sync and issue a 'NodeUnsynced'
-- event when this is the case.
handleOutOfSync ::
  IsChainState tx =>
  Environment ->
  -- | Current system time
  UTCTime ->
  -- | Latest Chain point observed
  ChainPointType tx ->
  -- | Latest Chain point time representation observed
  UTCTime ->
  SyncedStatus ->
  Outcome tx
handleOutOfSync :: forall tx.
IsChainState tx =>
Environment
-> UTCTime
-> ChainPointType tx
-> UTCTime
-> SyncedStatus
-> Outcome tx
handleOutOfSync Environment{UnsyncedPeriod
unsyncedPeriod :: UnsyncedPeriod
$sel:unsyncedPeriod:Environment :: Environment -> UnsyncedPeriod
unsyncedPeriod} UTCTime
now ChainPointType tx
chainPoint UTCTime
chainTime SyncedStatus
syncStatus =
  -- Emit only on an actual sync-status transition, rather than on every tick, so
  -- clients are not flooded (see issue #2749). The continuous drift value is
  -- exposed as a metric ('hydra_chain_drift_seconds') instead.
  case (SyncedStatus
syncStatus, SyncedStatus
newSyncStatus) of
    (SyncedStatus
InSync, SyncedStatus
CatchingUp) -> StateChanged tx -> Outcome tx
forall tx. StateChanged tx -> Outcome tx
newState NodeUnsynced{ChainSlot
chainSlot :: ChainSlot
$sel:chainSlot:NetworkConnected :: ChainSlot
chainSlot, UTCTime
$sel:chainTime:NetworkConnected :: UTCTime
chainTime :: UTCTime
chainTime, NominalDiffTime
drift :: NominalDiffTime
$sel:drift:NetworkConnected :: NominalDiffTime
drift}
    (SyncedStatus
CatchingUp, SyncedStatus
InSync) -> StateChanged tx -> Outcome tx
forall tx. StateChanged tx -> Outcome tx
newState NodeSynced{ChainSlot
chainSlot :: ChainSlot
$sel:chainSlot:NetworkConnected :: ChainSlot
chainSlot, UTCTime
$sel:chainTime:NetworkConnected :: UTCTime
chainTime :: UTCTime
chainTime, NominalDiffTime
drift :: NominalDiffTime
$sel:drift:NetworkConnected :: NominalDiffTime
drift}
    (SyncedStatus, SyncedStatus)
_ -> Outcome tx
forall tx. Outcome tx
noop
 where
  plus :: UTCTime -> NominalDiffTime -> UTCTime
plus = (NominalDiffTime -> UTCTime -> UTCTime)
-> UTCTime -> NominalDiffTime -> UTCTime
forall a b c. (a -> b -> c) -> b -> a -> c
flip NominalDiffTime -> UTCTime -> UTCTime
addUTCTime
  chainSlot :: ChainSlot
chainSlot = ChainPointType tx -> ChainSlot
forall tx. IsChainState tx => ChainPointType tx -> ChainSlot
chainPointSlot ChainPointType tx
chainPoint

  threshold :: NominalDiffTime
threshold = UnsyncedPeriod -> NominalDiffTime
unsyncedPeriodToNominalDiffTime UnsyncedPeriod
unsyncedPeriod
  drift :: NominalDiffTime
drift = UTCTime
now UTCTime -> UTCTime -> NominalDiffTime
`diffUTCTime` UTCTime
chainTime

  -- We consider the node out of sync when:
  -- the last observed chainTime plus the delta allowed by the unsyncedPeriod (threshold)
  -- falls behind the current system time (now).
  -- NOTE: this is the same as drift > threshold
  nodeOutOfSync :: Bool
nodeOutOfSync = UTCTime
chainTime UTCTime -> NominalDiffTime -> UTCTime
`plus` NominalDiffTime
threshold UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
< UTCTime
now
  newSyncStatus :: SyncedStatus
newSyncStatus = if Bool
nodeOutOfSync then SyncedStatus
CatchingUp else SyncedStatus
InSync

-- | The pending deposit that a local 'currentDepositTxId' still refers to, if any: the deposit must
--   be registered in 'pendingDeposits' and not 'Expired'.
--
--   Being registered and unexpired is what makes a recorded deposit id something the head may still
--   act on, and nothing else should be treated as a commit in flight. Neither of the two ways a
--   deposit stops being pending clears 'currentDepositTxId': 'DepositExpired' deliberately keeps the
--   deposit in the map so it can still be recovered, and 'DepositRecovered' only deletes the map
--   entry. So a caller that reads 'currentDepositTxId' on its own can end up waiting on a deposit
--   that is unclaimable, or already gone, and that wait never resolves.
existingDeposit :: IsTx tx => PendingDeposits tx -> Maybe (TxIdType tx) -> Maybe (TxIdType tx, Deposit tx)
existingDeposit :: forall tx.
IsTx tx =>
PendingDeposits tx
-> Maybe (TxIdType tx) -> Maybe (TxIdType tx, Deposit tx)
existingDeposit PendingDeposits tx
pendingDeposits Maybe (TxIdType tx)
currentDeposit =
  case Maybe (TxIdType tx)
currentDeposit of
    Maybe (TxIdType tx)
Nothing -> Maybe (TxIdType tx, Deposit tx)
forall a. Maybe a
Nothing
    Just TxIdType tx
depositTxId ->
      case TxIdType tx -> PendingDeposits tx -> Maybe (Deposit tx)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TxIdType tx
depositTxId PendingDeposits tx
pendingDeposits of
        Maybe (Deposit tx)
Nothing -> Maybe (TxIdType tx, Deposit tx)
forall a. Maybe a
Nothing
        Just Deposit tx
deposit
          | Deposit tx
deposit.status DepositStatus -> DepositStatus -> Bool
forall a. Eq a => a -> a -> Bool
== DepositStatus
Expired -> Maybe (TxIdType tx, Deposit tx)
forall a. Maybe a
Nothing
          | Bool
otherwise -> (TxIdType tx, Deposit tx) -> Maybe (TxIdType tx, Deposit tx)
forall a. a -> Maybe a
Just (TxIdType tx
depositTxId, Deposit tx
deposit)

-- | Validate whether a current deposit in the local state actually exists
--   in the map of pending deposits.
--
--   * If 'currentDeposit' is 'Nothing', returns 'Nothing'.
--   * If 'currentDeposit' is @'Just' txId@ and @txId@ is present in 'pendingDeposits'
--     and not 'Expired', returns the original 'currentDeposit'.
--   * Otherwise, returns 'Nothing'.
--
--   This is typically used to confirm that a local deposit that is to be
--   requested in 'ReqSn' is indeed still pending and has not been processed or
--   removed.
--
--   Expired deposits are dropped rather than carried: requesting one makes every
--   receiving party hard-error with 'RequestedDepositExpired', so a deposit that
--   somehow became unclaimable would stall snapshots for the whole head instead of
--   just being abandoned by its depositor.
setExistingDeposit :: IsTx tx => PendingDeposits tx -> Maybe (TxIdType tx) -> Maybe (TxIdType tx)
setExistingDeposit :: forall tx.
IsTx tx =>
PendingDeposits tx -> Maybe (TxIdType tx) -> Maybe (TxIdType tx)
setExistingDeposit PendingDeposits tx
pendingDeposits = ((TxIdType tx, Deposit tx) -> TxIdType tx)
-> Maybe (TxIdType tx, Deposit tx) -> Maybe (TxIdType tx)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (TxIdType tx, Deposit tx) -> TxIdType tx
forall a b. (a, b) -> a
fst (Maybe (TxIdType tx, Deposit tx) -> Maybe (TxIdType tx))
-> (Maybe (TxIdType tx) -> Maybe (TxIdType tx, Deposit tx))
-> Maybe (TxIdType tx)
-> Maybe (TxIdType tx)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PendingDeposits tx
-> Maybe (TxIdType tx) -> Maybe (TxIdType tx, Deposit tx)
forall tx.
IsTx tx =>
PendingDeposits tx
-> Maybe (TxIdType tx) -> Maybe (TxIdType tx, Deposit tx)
existingDeposit PendingDeposits tx
pendingDeposits

-- | Find the oldest non-empty active deposit, if any. Deposits are selected
-- in FIFO order by their 'created' timestamp. This mirrors the selection
-- logic in 'withNextActive' used by 'onOpenChainTick'.
nextActiveDepositId :: IsTx tx => PendingDeposits tx -> Maybe (TxIdType tx)
nextActiveDepositId :: forall tx. IsTx tx => PendingDeposits tx -> Maybe (TxIdType tx)
nextActiveDepositId PendingDeposits tx
deposits =
  case ((TxIdType tx, Deposit tx) -> Bool)
-> [(TxIdType tx, Deposit tx)] -> [(TxIdType tx, Deposit tx)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(TxIdType tx
_, Deposit{UTxOType tx
$sel:deposited:Deposit :: forall tx. Deposit tx -> UTxOType tx
deposited :: UTxOType tx
deposited, DepositStatus
$sel:status:Deposit :: forall tx. Deposit tx -> DepositStatus
status :: DepositStatus
status}) -> UTxOType tx
deposited UTxOType tx -> UTxOType tx -> Bool
forall a. Eq a => a -> a -> Bool
/= UTxOType tx
forall a. Monoid a => a
mempty Bool -> Bool -> Bool
&& DepositStatus
status DepositStatus -> DepositStatus -> Bool
forall a. Eq a => a -> a -> Bool
== DepositStatus
Active) (PendingDeposits tx -> [(TxIdType tx, Deposit tx)]
forall k a. Map k a -> [(k, a)]
Map.toList PendingDeposits tx
deposits) of
    [] -> Maybe (TxIdType tx)
forall a. Maybe a
Nothing
    [(TxIdType tx, Deposit tx)]
xs -> TxIdType tx -> Maybe (TxIdType tx)
forall a. a -> Maybe a
Just ((TxIdType tx, Deposit tx) -> TxIdType tx
forall a b. (a, b) -> a
fst (((TxIdType tx, Deposit tx)
 -> (TxIdType tx, Deposit tx) -> Ordering)
-> [(TxIdType tx, Deposit tx)] -> (TxIdType tx, Deposit tx)
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
minimumBy (((TxIdType tx, Deposit tx) -> UTCTime)
-> (TxIdType tx, Deposit tx)
-> (TxIdType tx, Deposit tx)
-> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing ((.created) (Deposit tx -> UTCTime)
-> ((TxIdType tx, Deposit tx) -> Deposit tx)
-> (TxIdType tx, Deposit tx)
-> UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxIdType tx, Deposit tx) -> Deposit tx
forall a b. (a, b) -> b
snd)) [(TxIdType tx, Deposit tx)]
xs))

-- | Select the deposit to include in the next snapshot.
--
-- Prefers a deposit already tracked in 'currentDepositTxId' (if still pending).
-- Falls back to the oldest active deposit from 'pendingDeposits', but only
-- when neither a decommit is pending nor the last confirmed snapshot already
-- included a deposit (to avoid double-posting 'IncrementTx' before
-- 'CommitFinalized' removes the deposit).
selectNextDeposit ::
  IsTx tx =>
  PendingDeposits tx ->
  Maybe (TxIdType tx) ->
  -- | Pending decommit tx
  Maybe tx ->
  -- | utxoToCommit of the last relevant confirmed snapshot
  Maybe (UTxOType tx) ->
  Maybe (TxIdType tx)
selectNextDeposit :: forall tx.
IsTx tx =>
PendingDeposits tx
-> Maybe (TxIdType tx)
-> Maybe tx
-> Maybe (UTxOType tx)
-> Maybe (TxIdType tx)
selectNextDeposit PendingDeposits tx
pendingDeposits Maybe (TxIdType tx)
currentDepositTxId Maybe tx
mDecommitTx Maybe (UTxOType tx)
mConfirmedUtxoToCommit =
  PendingDeposits tx -> Maybe (TxIdType tx) -> Maybe (TxIdType tx)
forall tx.
IsTx tx =>
PendingDeposits tx -> Maybe (TxIdType tx) -> Maybe (TxIdType tx)
setExistingDeposit PendingDeposits tx
pendingDeposits Maybe (TxIdType tx)
currentDepositTxId
    Maybe (TxIdType tx) -> Maybe (TxIdType tx) -> Maybe (TxIdType tx)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> case (Maybe tx
mDecommitTx, Maybe (UTxOType tx)
mConfirmedUtxoToCommit) of
      (Maybe tx
Nothing, Maybe (UTxOType tx)
Nothing) -> PendingDeposits tx -> Maybe (TxIdType tx)
forall tx. IsTx tx => PendingDeposits tx -> Maybe (TxIdType tx)
nextActiveDepositId PendingDeposits tx
pendingDeposits
      (Maybe tx, Maybe (UTxOType tx))
_ -> Maybe (TxIdType tx)
forall a. Maybe a
Nothing

-- | Reject a decommit that materializes no output.
-- 'Hydra.Contract.Head.checkDecrement' requires at least one, so such a decommit
-- can never settle on-chain, and recording it would block every later snapshot
-- (which cannot carry a different one).
--
-- Belongs after the applicability check at every call site: a transaction that
-- does not apply is reported with the ledger's own, more precise reason.
requireDecommitOutputs ::
  IsTx tx =>
  HeadId ->
  UTxOType tx ->
  tx ->
  Outcome tx ->
  Outcome tx
requireDecommitOutputs :: forall tx.
IsTx tx =>
HeadId -> UTxOType tx -> tx -> Outcome tx -> Outcome tx
requireDecommitOutputs HeadId
headId UTxOType tx
localUTxO tx
decommitTx Outcome tx
continue
  | tx -> UTxOType tx
forall tx. IsTx tx => tx -> UTxOType tx
utxoFromTx tx
decommitTx UTxOType tx -> UTxOType tx -> Bool
forall a. Eq a => a -> a -> Bool
== UTxOType tx
forall a. Monoid a => a
mempty =
      StateChanged tx -> Outcome tx
forall tx. StateChanged tx -> Outcome tx
newState
        DecommitInvalid
          { HeadId
$sel:headId:NetworkConnected :: HeadId
headId :: HeadId
headId
          , tx
$sel:decommitTx:NetworkConnected :: tx
decommitTx :: tx
decommitTx
          , $sel:decommitInvalidReason:NetworkConnected :: DecommitInvalidReason tx
decommitInvalidReason =
              ServerOutput.DecommitTxInvalid
                { UTxOType tx
$sel:localUTxO:DecommitTxInvalid :: UTxOType tx
localUTxO :: UTxOType tx
localUTxO
                , $sel:validationError:DecommitTxInvalid :: ValidationError
validationError = Text -> ValidationError
ValidationError Text
"decommit transaction has no outputs"
                }
          }
  | Bool
otherwise = Outcome tx
continue

-- | The incremental action to put in the next 'ReqSn': a commit or a decommit,
-- never both. A snapshot carrying both cannot be closed, since close and fanout
-- express a single incremental action ('setIncrementalActionMaybe').
--
-- A commit wins: its deposit expires on-chain, while a decommit only waits. This
-- cannot starve the decommit, because 'selectNextDeposit' refuses to start a
-- *new* commit while a decommit is pending — only one already in flight can win,
-- and that one stops being selected once it settles and leaves 'pendingDeposits'.
selectNextIncrementalAction ::
  IsTx tx =>
  PendingDeposits tx ->
  Maybe (TxIdType tx) ->
  -- | Pending decommit tx
  Maybe tx ->
  -- | utxoToCommit of the last relevant confirmed snapshot
  Maybe (UTxOType tx) ->
  (Maybe tx, Maybe (TxIdType tx))
selectNextIncrementalAction :: forall tx.
IsTx tx =>
PendingDeposits tx
-> Maybe (TxIdType tx)
-> Maybe tx
-> Maybe (UTxOType tx)
-> (Maybe tx, Maybe (TxIdType tx))
selectNextIncrementalAction PendingDeposits tx
pendingDeposits Maybe (TxIdType tx)
currentDepositTxId Maybe tx
mDecommitTx Maybe (UTxOType tx)
mConfirmedUtxoToCommit =
  case PendingDeposits tx
-> Maybe (TxIdType tx)
-> Maybe tx
-> Maybe (UTxOType tx)
-> Maybe (TxIdType tx)
forall tx.
IsTx tx =>
PendingDeposits tx
-> Maybe (TxIdType tx)
-> Maybe tx
-> Maybe (UTxOType tx)
-> Maybe (TxIdType tx)
selectNextDeposit PendingDeposits tx
pendingDeposits Maybe (TxIdType tx)
currentDepositTxId Maybe tx
mDecommitTx Maybe (UTxOType tx)
mConfirmedUtxoToCommit of
    Just TxIdType tx
depositTxId -> (Maybe tx
forall a. Maybe a
Nothing, TxIdType tx -> Maybe (TxIdType tx)
forall a. a -> Maybe a
Just TxIdType tx
depositTxId)
    Maybe (TxIdType tx)
Nothing -> (Maybe tx
mDecommitTx, Maybe (TxIdType tx)
forall a. Maybe a
Nothing)

-- | Handles inputs and converts them into 'StateChanged' events along with
-- 'Effect's, in case it is processed successfully. Later, the Node will
-- apply the events via 'aggregateNodeState', resulting in a new 'NodeState'.
update ::
  IsChainState tx =>
  Environment ->
  Ledger tx ->
  -- | Current system time.
  UTCTime ->
  -- | Current NodeState to validate the command against.
  NodeState tx ->
  -- | Input to be processed.
  Input tx ->
  Outcome tx
update :: forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
env Ledger tx
ledger UTCTime
now NodeState tx
nodeState Input tx
ev =
  case NodeState tx
nodeState of
    NodeCatchingUp{HeadState tx
headState :: HeadState tx
$sel:headState:NodeInSync :: forall tx. NodeState tx -> HeadState tx
headState, PendingDeposits tx
pendingDeposits :: forall tx. NodeState tx -> PendingDeposits tx
pendingDeposits :: PendingDeposits tx
pendingDeposits, ChainPointTime
chainPointTime :: ChainPointTime
$sel:chainPointTime:NodeInSync :: forall tx. NodeState tx -> ChainPointTime
chainPointTime} ->
      Environment
-> Ledger tx
-> UTCTime
-> ChainPointTime
-> PendingDeposits tx
-> HeadState tx
-> Input tx
-> SyncedStatus
-> Outcome tx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx
-> UTCTime
-> ChainPointTime
-> PendingDeposits tx
-> HeadState tx
-> Input tx
-> SyncedStatus
-> Outcome tx
updateCatchingUpHead Environment
env Ledger tx
ledger UTCTime
now ChainPointTime
chainPointTime PendingDeposits tx
pendingDeposits HeadState tx
headState Input tx
ev (NodeState tx -> SyncedStatus
forall tx. NodeState tx -> SyncedStatus
syncedStatus NodeState tx
nodeState)
    NodeInSync{HeadState tx
$sel:headState:NodeInSync :: forall tx. NodeState tx -> HeadState tx
headState :: HeadState tx
headState, PendingDeposits tx
pendingDeposits :: forall tx. NodeState tx -> PendingDeposits tx
pendingDeposits :: PendingDeposits tx
pendingDeposits, ChainPointTime
$sel:chainPointTime:NodeInSync :: forall tx. NodeState tx -> ChainPointTime
chainPointTime :: ChainPointTime
chainPointTime} ->
      Environment
-> Ledger tx
-> UTCTime
-> ChainPointTime
-> PendingDeposits tx
-> HeadState tx
-> Input tx
-> SyncedStatus
-> Outcome tx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx
-> UTCTime
-> ChainPointTime
-> PendingDeposits tx
-> HeadState tx
-> Input tx
-> SyncedStatus
-> Outcome tx
updateInSyncHead Environment
env Ledger tx
ledger UTCTime
now ChainPointTime
chainPointTime PendingDeposits tx
pendingDeposits HeadState tx
headState Input tx
ev (NodeState tx -> SyncedStatus
forall tx. NodeState tx -> SyncedStatus
syncedStatus NodeState tx
nodeState)

updateCatchingUpHead ::
  IsChainState tx =>
  Environment ->
  Ledger tx ->
  -- | Current system time.
  UTCTime ->
  -- | Last known chain point time
  ChainPointTime ->
  PendingDeposits tx ->
  -- | Current HeadState to validate the command against.
  HeadState tx ->
  -- | Input to be processed.
  Input tx ->
  SyncedStatus ->
  Outcome tx
updateCatchingUpHead :: forall tx.
IsChainState tx =>
Environment
-> Ledger tx
-> UTCTime
-> ChainPointTime
-> PendingDeposits tx
-> HeadState tx
-> Input tx
-> SyncedStatus
-> Outcome tx
updateCatchingUpHead Environment
env Ledger tx
ledger UTCTime
now ChainPointTime
chainPointTime PendingDeposits tx
pendingDeposits HeadState tx
st Input tx
ev SyncedStatus
syncStatus =
  case Input tx
ev of
    ChainInput{} ->
      Environment
-> Ledger tx
-> UTCTime
-> ChainPointTime
-> PendingDeposits tx
-> HeadState tx
-> Input tx
-> SyncedStatus
-> Outcome tx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx
-> UTCTime
-> ChainPointTime
-> PendingDeposits tx
-> HeadState tx
-> Input tx
-> SyncedStatus
-> Outcome tx
handleChainInput Environment
env Ledger tx
ledger UTCTime
now ChainPointTime
chainPointTime PendingDeposits tx
pendingDeposits HeadState tx
st Input tx
ev SyncedStatus
syncStatus
    ClientInput{ClientInput tx
clientInput :: ClientInput tx
$sel:clientInput:ClientInput :: forall tx. Input tx -> ClientInput tx
clientInput} ->
      Effect tx -> Outcome tx
forall tx. Effect tx -> Outcome tx
cause (Effect tx -> Outcome tx)
-> (ClientMessage tx -> Effect tx)
-> ClientMessage tx
-> Outcome tx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClientMessage tx -> Effect tx
forall tx. ClientMessage tx -> Effect tx
ClientEffect (ClientMessage tx -> Outcome tx) -> ClientMessage tx -> Outcome tx
forall a b. (a -> b) -> a -> b
$ ClientInput tx -> NominalDiffTime -> ClientMessage tx
forall tx. ClientInput tx -> NominalDiffTime -> ClientMessage tx
ServerOutput.RejectedInputBecauseUnsynced ClientInput tx
clientInput NominalDiffTime
drift
    NetworkInput{} ->
      WaitReason tx -> Outcome tx
forall tx. WaitReason tx -> Outcome tx
wait WaitOnNodeInSync{ChainSlot
currentSlot :: ChainSlot
$sel:currentSlot:WaitOnNotApplicableTx :: ChainSlot
currentSlot}
 where
  ChainPointTime{ChainSlot
currentSlot :: ChainSlot
$sel:currentSlot:ChainPointTime :: ChainPointTime -> ChainSlot
currentSlot, NominalDiffTime
drift :: NominalDiffTime
$sel:drift:ChainPointTime :: ChainPointTime -> NominalDiffTime
drift} = ChainPointTime
chainPointTime

updateInSyncHead ::
  IsChainState tx =>
  Environment ->
  Ledger tx ->
  -- | Current system time.
  UTCTime ->
  -- | Last known chain point time
  ChainPointTime ->
  PendingDeposits tx ->
  -- | Current HeadState to validate the command against.
  HeadState tx ->
  -- | Input to be processed.
  Input tx ->
  SyncedStatus ->
  Outcome tx
updateInSyncHead :: forall tx.
IsChainState tx =>
Environment
-> Ledger tx
-> UTCTime
-> ChainPointTime
-> PendingDeposits tx
-> HeadState tx
-> Input tx
-> SyncedStatus
-> Outcome tx
updateInSyncHead Environment
env Ledger tx
ledger UTCTime
now ChainPointTime
chainPointTime PendingDeposits tx
pendingDeposits HeadState tx
st Input tx
ev SyncedStatus
syncStatus =
  case Input tx
ev of
    ChainInput{} ->
      Environment
-> Ledger tx
-> UTCTime
-> ChainPointTime
-> PendingDeposits tx
-> HeadState tx
-> Input tx
-> SyncedStatus
-> Outcome tx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx
-> UTCTime
-> ChainPointTime
-> PendingDeposits tx
-> HeadState tx
-> Input tx
-> SyncedStatus
-> Outcome tx
handleChainInput Environment
env Ledger tx
ledger UTCTime
now ChainPointTime
chainPointTime PendingDeposits tx
pendingDeposits HeadState tx
st Input tx
ev SyncedStatus
syncStatus
    ClientInput{} ->
      Environment
-> Ledger tx
-> ChainPointTime
-> PendingDeposits tx
-> HeadState tx
-> Input tx
-> Outcome tx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx
-> ChainPointTime
-> PendingDeposits tx
-> HeadState tx
-> Input tx
-> Outcome tx
handleClientInput Environment
env Ledger tx
ledger ChainPointTime
chainPointTime PendingDeposits tx
pendingDeposits HeadState tx
st Input tx
ev
    NetworkInput{} ->
      Environment
-> Ledger tx
-> ChainPointTime
-> PendingDeposits tx
-> HeadState tx
-> Input tx
-> Outcome tx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx
-> ChainPointTime
-> PendingDeposits tx
-> HeadState tx
-> Input tx
-> Outcome tx
handleNetworkInput Environment
env Ledger tx
ledger ChainPointTime
chainPointTime PendingDeposits tx
pendingDeposits HeadState tx
st Input tx
ev

-- * Input Handlers

handleChainInput ::
  IsChainState tx =>
  Environment ->
  Ledger tx ->
  -- | Current system time.
  UTCTime ->
  -- | Last known chain point time
  ChainPointTime ->
  PendingDeposits tx ->
  -- | Current HeadState to validate the command against.
  HeadState tx ->
  -- | Input to be processed.
  Input tx ->
  SyncedStatus ->
  Outcome tx
handleChainInput :: forall tx.
IsChainState tx =>
Environment
-> Ledger tx
-> UTCTime
-> ChainPointTime
-> PendingDeposits tx
-> HeadState tx
-> Input tx
-> SyncedStatus
-> Outcome tx
handleChainInput Environment
env Ledger tx
_ledger UTCTime
now ChainPointTime
_chainPointTime PendingDeposits tx
pendingDeposits HeadState tx
st Input tx
ev SyncedStatus
syncStatus = case (HeadState tx
st, Input tx
ev) of
  (Idle IdleState tx
_, ChainInput Observation{$sel:observedTx:Observation :: forall tx. ChainEvent tx -> OnChainTx tx
observedTx = OnInitTx{HeadId
headId :: HeadId
$sel:headId:OnInitTx :: forall tx. OnChainTx tx -> HeadId
headId, HeadSeed
headSeed :: HeadSeed
$sel:headSeed:OnInitTx :: forall tx. OnChainTx tx -> HeadSeed
headSeed, HeadParameters
headParameters :: HeadParameters
$sel:headParameters:OnInitTx :: forall tx. OnChainTx tx -> HeadParameters
headParameters, [OnChainId]
participants :: [OnChainId]
$sel:participants:OnInitTx :: forall tx. OnChainTx tx -> [OnChainId]
participants}, ChainStateType tx
newChainState :: ChainStateType tx
$sel:newChainState:Observation :: forall tx. ChainEvent tx -> ChainStateType tx
newChainState}) ->
    Environment
-> ChainStateType tx
-> HeadId
-> HeadSeed
-> HeadParameters
-> [OnChainId]
-> Outcome tx
forall tx.
Environment
-> ChainStateType tx
-> HeadId
-> HeadSeed
-> HeadParameters
-> [OnChainId]
-> Outcome tx
onIdleChainInitTx Environment
env ChainStateType tx
newChainState HeadId
headId HeadSeed
headSeed HeadParameters
headParameters [OnChainId]
participants
  -- Open
  ( Open openState :: OpenState tx
openState@OpenState{$sel:headId:OpenState :: forall tx. OpenState tx -> HeadId
headId = HeadId
ourHeadId}
    , ChainInput Observation{$sel:observedTx:Observation :: forall tx. ChainEvent tx -> OnChainTx tx
observedTx = OnCloseTx{HeadId
$sel:headId:OnInitTx :: forall tx. OnChainTx tx -> HeadId
headId :: HeadId
headId, $sel:snapshotNumber:OnInitTx :: forall tx. OnChainTx tx -> SnapshotNumber
snapshotNumber = SnapshotNumber
closedSnapshotNumber, UTCTime
contestationDeadline :: UTCTime
$sel:contestationDeadline:OnInitTx :: forall tx. OnChainTx tx -> UTCTime
contestationDeadline}, ChainStateType tx
$sel:newChainState:Observation :: forall tx. ChainEvent tx -> ChainStateType tx
newChainState :: ChainStateType tx
newChainState}
    )
      | HeadId
ourHeadId HeadId -> HeadId -> Bool
forall a. Eq a => a -> a -> Bool
== HeadId
headId ->
          OpenState tx
-> ChainStateType tx -> SnapshotNumber -> UTCTime -> Outcome tx
forall tx.
IsTx tx =>
OpenState tx
-> ChainStateType tx -> SnapshotNumber -> UTCTime -> Outcome tx
onOpenChainCloseTx OpenState tx
openState ChainStateType tx
newChainState SnapshotNumber
closedSnapshotNumber UTCTime
contestationDeadline
      | Bool
otherwise ->
          LogicError tx -> Outcome tx
forall tx. LogicError tx -> Outcome tx
Error NotOurHead{HeadId
ourHeadId :: HeadId
$sel:ourHeadId:UnhandledInput :: HeadId
ourHeadId, $sel:otherHeadId:UnhandledInput :: HeadId
otherHeadId = HeadId
headId}
  (Open openState :: OpenState tx
openState@OpenState{$sel:headId:OpenState :: forall tx. OpenState tx -> HeadId
headId = HeadId
ourHeadId}, ChainInput Tick{UTCTime
chainTime :: UTCTime
$sel:chainTime:Observation :: forall tx. ChainEvent tx -> UTCTime
chainTime, ChainPointType tx
chainPoint :: ChainPointType tx
$sel:chainPoint:Observation :: forall tx. ChainEvent tx -> ChainPointType tx
chainPoint}) ->
    -- XXX: We originally forgot the normal TickObserved state event here and so
    -- time did not advance in an open head anymore. This is a hint that we
    -- should compose event handling better.
    StateChanged tx -> Outcome tx
forall tx. StateChanged tx -> Outcome tx
newState TickObserved{ChainPointType tx
chainPoint :: ChainPointType tx
$sel:chainPoint:NetworkConnected :: ChainPointType tx
chainPoint, UTCTime
$sel:chainTime:NetworkConnected :: UTCTime
chainTime :: UTCTime
chainTime}
      Outcome tx -> Outcome tx -> Outcome tx
forall a. Semigroup a => a -> a -> a
<> Environment
-> UTCTime
-> ChainPointType tx
-> UTCTime
-> SyncedStatus
-> Outcome tx
forall tx.
IsChainState tx =>
Environment
-> UTCTime
-> ChainPointType tx
-> UTCTime
-> SyncedStatus
-> Outcome tx
handleOutOfSync Environment
env UTCTime
now ChainPointType tx
chainPoint UTCTime
chainTime SyncedStatus
syncStatus
      Outcome tx -> Outcome tx -> Outcome tx
forall a. Semigroup a => a -> a -> a
<> Environment -> PendingDeposits tx -> UTCTime -> Outcome tx
forall tx.
IsTx tx =>
Environment -> PendingDeposits tx -> UTCTime -> Outcome tx
onChainTick Environment
env PendingDeposits tx
pendingDeposits UTCTime
chainTime
      Outcome tx -> Outcome tx -> Outcome tx
forall a. Semigroup a => a -> a -> a
<> Environment
-> UTCTime -> PendingDeposits tx -> OpenState tx -> Outcome tx
forall tx.
IsTx tx =>
Environment
-> UTCTime -> PendingDeposits tx -> OpenState tx -> Outcome tx
onOpenChainTick Environment
env UTCTime
chainTime (HeadId -> PendingDeposits tx -> PendingDeposits tx
forall tx. HeadId -> PendingDeposits tx -> PendingDeposits tx
depositsForHead HeadId
ourHeadId PendingDeposits tx
pendingDeposits) OpenState tx
openState
  (Open openState :: OpenState tx
openState@OpenState{$sel:headId:OpenState :: forall tx. OpenState tx -> HeadId
headId = HeadId
ourHeadId}, ChainInput Observation{$sel:observedTx:Observation :: forall tx. ChainEvent tx -> OnChainTx tx
observedTx = OnIncrementTx{HeadId
$sel:headId:OnInitTx :: forall tx. OnChainTx tx -> HeadId
headId :: HeadId
headId, SnapshotVersion
newVersion :: SnapshotVersion
$sel:newVersion:OnInitTx :: forall tx. OnChainTx tx -> SnapshotVersion
newVersion, TxIdType tx
depositTxId :: forall tx. OnChainTx tx -> TxIdType tx
depositTxId :: TxIdType tx
depositTxId}, ChainStateType tx
$sel:newChainState:Observation :: forall tx. ChainEvent tx -> ChainStateType tx
newChainState :: ChainStateType tx
newChainState})
    | HeadId
ourHeadId HeadId -> HeadId -> Bool
forall a. Eq a => a -> a -> Bool
== HeadId
headId ->
        Environment
-> OpenState tx
-> ChainStateType tx
-> SnapshotVersion
-> TxIdType tx
-> Outcome tx
forall tx.
IsTx tx =>
Environment
-> OpenState tx
-> ChainStateType tx
-> SnapshotVersion
-> TxIdType tx
-> Outcome tx
onOpenChainIncrementTx Environment
env OpenState tx
openState ChainStateType tx
newChainState SnapshotVersion
newVersion TxIdType tx
depositTxId
    | Bool
otherwise ->
        LogicError tx -> Outcome tx
forall tx. LogicError tx -> Outcome tx
Error NotOurHead{HeadId
$sel:ourHeadId:UnhandledInput :: HeadId
ourHeadId :: HeadId
ourHeadId, $sel:otherHeadId:UnhandledInput :: HeadId
otherHeadId = HeadId
headId}
  (Open openState :: OpenState tx
openState@OpenState{$sel:headId:OpenState :: forall tx. OpenState tx -> HeadId
headId = HeadId
ourHeadId}, ChainInput Observation{$sel:observedTx:Observation :: forall tx. ChainEvent tx -> OnChainTx tx
observedTx = OnDecrementTx{HeadId
$sel:headId:OnInitTx :: forall tx. OnChainTx tx -> HeadId
headId :: HeadId
headId, SnapshotVersion
$sel:newVersion:OnInitTx :: forall tx. OnChainTx tx -> SnapshotVersion
newVersion :: SnapshotVersion
newVersion, UTxOType tx
distributedUTxO :: UTxOType tx
$sel:distributedUTxO:OnInitTx :: forall tx. OnChainTx tx -> UTxOType tx
distributedUTxO}, ChainStateType tx
$sel:newChainState:Observation :: forall tx. ChainEvent tx -> ChainStateType tx
newChainState :: ChainStateType tx
newChainState})
    -- TODO: What happens if observed decrement tx get's rolled back?
    | HeadId
ourHeadId HeadId -> HeadId -> Bool
forall a. Eq a => a -> a -> Bool
== HeadId
headId ->
        Environment
-> PendingDeposits tx
-> OpenState tx
-> ChainStateType tx
-> SnapshotVersion
-> UTxOType tx
-> Outcome tx
forall tx.
IsTx tx =>
Environment
-> PendingDeposits tx
-> OpenState tx
-> ChainStateType tx
-> SnapshotVersion
-> UTxOType tx
-> Outcome tx
onOpenChainDecrementTx Environment
env (HeadId -> PendingDeposits tx -> PendingDeposits tx
forall tx. HeadId -> PendingDeposits tx -> PendingDeposits tx
depositsForHead HeadId
ourHeadId PendingDeposits tx
pendingDeposits) OpenState tx
openState ChainStateType tx
newChainState SnapshotVersion
newVersion UTxOType tx
distributedUTxO
    | Bool
otherwise ->
        LogicError tx -> Outcome tx
forall tx. LogicError tx -> Outcome tx
Error NotOurHead{HeadId
$sel:ourHeadId:UnhandledInput :: HeadId
ourHeadId :: HeadId
ourHeadId, $sel:otherHeadId:UnhandledInput :: HeadId
otherHeadId = HeadId
headId}
  -- Closed
  (Closed closedState :: ClosedState tx
closedState@ClosedState{$sel:headId:ClosedState :: forall tx. ClosedState tx -> HeadId
headId = HeadId
ourHeadId}, ChainInput Observation{$sel:observedTx:Observation :: forall tx. ChainEvent tx -> OnChainTx tx
observedTx = OnContestTx{HeadId
$sel:headId:OnInitTx :: forall tx. OnChainTx tx -> HeadId
headId :: HeadId
headId, SnapshotNumber
$sel:snapshotNumber:OnInitTx :: forall tx. OnChainTx tx -> SnapshotNumber
snapshotNumber :: SnapshotNumber
snapshotNumber, UTCTime
$sel:contestationDeadline:OnInitTx :: forall tx. OnChainTx tx -> UTCTime
contestationDeadline :: UTCTime
contestationDeadline}, ChainStateType tx
$sel:newChainState:Observation :: forall tx. ChainEvent tx -> ChainStateType tx
newChainState :: ChainStateType tx
newChainState})
    | HeadId
ourHeadId HeadId -> HeadId -> Bool
forall a. Eq a => a -> a -> Bool
== HeadId
headId ->
        ClosedState tx
-> ChainStateType tx -> SnapshotNumber -> UTCTime -> Outcome tx
forall tx.
IsTx tx =>
ClosedState tx
-> ChainStateType tx -> SnapshotNumber -> UTCTime -> Outcome tx
onClosedChainContestTx ClosedState tx
closedState ChainStateType tx
newChainState SnapshotNumber
snapshotNumber UTCTime
contestationDeadline
    | Bool
otherwise ->
        LogicError tx -> Outcome tx
forall tx. LogicError tx -> Outcome tx
Error NotOurHead{HeadId
$sel:ourHeadId:UnhandledInput :: HeadId
ourHeadId :: HeadId
ourHeadId, $sel:otherHeadId:UnhandledInput :: HeadId
otherHeadId = HeadId
headId}
  (Closed ClosedState{UTCTime
$sel:contestationDeadline:ClosedState :: forall tx. ClosedState tx -> UTCTime
contestationDeadline :: UTCTime
contestationDeadline, Bool
readyToFanoutSent :: forall tx. ClosedState tx -> Bool
readyToFanoutSent :: Bool
readyToFanoutSent, HeadId
$sel:headId:ClosedState :: forall tx. ClosedState tx -> HeadId
headId :: HeadId
headId}, ChainInput Tick{UTCTime
$sel:chainTime:Observation :: forall tx. ChainEvent tx -> UTCTime
chainTime :: UTCTime
chainTime, ChainPointType tx
$sel:chainPoint:Observation :: forall tx. ChainEvent tx -> ChainPointType tx
chainPoint :: ChainPointType tx
chainPoint})
    | UTCTime
chainTime UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
> UTCTime
contestationDeadline Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
readyToFanoutSent ->
        StateChanged tx -> Outcome tx
forall tx. StateChanged tx -> Outcome tx
newState TickObserved{ChainPointType tx
$sel:chainPoint:NetworkConnected :: ChainPointType tx
chainPoint :: ChainPointType tx
chainPoint, UTCTime
$sel:chainTime:NetworkConnected :: UTCTime
chainTime :: UTCTime
chainTime}
          Outcome tx -> Outcome tx -> Outcome tx
forall a. Semigroup a => a -> a -> a
<> Environment
-> UTCTime
-> ChainPointType tx
-> UTCTime
-> SyncedStatus
-> Outcome tx
forall tx.
IsChainState tx =>
Environment
-> UTCTime
-> ChainPointType tx
-> UTCTime
-> SyncedStatus
-> Outcome tx
handleOutOfSync Environment
env UTCTime
now ChainPointType tx
chainPoint UTCTime
chainTime SyncedStatus
syncStatus
          Outcome tx -> Outcome tx -> Outcome tx
forall a. Semigroup a => a -> a -> a
<> Environment -> PendingDeposits tx -> UTCTime -> Outcome tx
forall tx.
IsTx tx =>
Environment -> PendingDeposits tx -> UTCTime -> Outcome tx
onChainTick Environment
env PendingDeposits tx
pendingDeposits UTCTime
chainTime
          Outcome tx -> Outcome tx -> Outcome tx
forall a. Semigroup a => a -> a -> a
<> StateChanged tx -> Outcome tx
forall tx. StateChanged tx -> Outcome tx
newState HeadIsReadyToFanout{HeadId
$sel:headId:NetworkConnected :: HeadId
headId :: HeadId
headId}
  (Closed closedState :: ClosedState tx
closedState@ClosedState{$sel:headId:ClosedState :: forall tx. ClosedState tx -> HeadId
headId = HeadId
ourHeadId}, ChainInput Observation{$sel:observedTx:Observation :: forall tx. ChainEvent tx -> OnChainTx tx
observedTx = OnFanoutTx{HeadId
$sel:headId:OnInitTx :: forall tx. OnChainTx tx -> HeadId
headId :: HeadId
headId, UTxOType tx
fanoutUTxO :: UTxOType tx
$sel:fanoutUTxO:OnInitTx :: forall tx. OnChainTx tx -> UTxOType tx
fanoutUTxO}, ChainStateType tx
$sel:newChainState:Observation :: forall tx. ChainEvent tx -> ChainStateType tx
newChainState :: ChainStateType tx
newChainState})
    | HeadId
ourHeadId HeadId -> HeadId -> Bool
forall a. Eq a => a -> a -> Bool
== HeadId
headId ->
        ClosedState tx -> ChainStateType tx -> UTxOType tx -> Outcome tx
forall tx.
ClosedState tx -> ChainStateType tx -> UTxOType tx -> Outcome tx
onClosedChainFanoutTx ClosedState tx
closedState ChainStateType tx
newChainState UTxOType tx
fanoutUTxO
    | Bool
otherwise ->
        LogicError tx -> Outcome tx
forall tx. LogicError tx -> Outcome tx
Error NotOurHead{HeadId
$sel:ourHeadId:UnhandledInput :: HeadId
ourHeadId :: HeadId
ourHeadId, $sel:otherHeadId:UnhandledInput :: HeadId
otherHeadId = HeadId
headId}
  (Closed closedState :: ClosedState tx
closedState@ClosedState{$sel:headId:ClosedState :: forall tx. ClosedState tx -> HeadId
headId = HeadId
ourHeadId}, ChainInput Observation{$sel:observedTx:Observation :: forall tx. ChainEvent tx -> OnChainTx tx
observedTx = OnPartialFanoutTx{HeadId
$sel:headId:OnInitTx :: forall tx. OnChainTx tx -> HeadId
headId :: HeadId
headId, UTxOType tx
distributedOutputs :: UTxOType tx
$sel:distributedOutputs:OnInitTx :: forall tx. OnChainTx tx -> UTxOType tx
distributedOutputs}, ChainStateType tx
$sel:newChainState:Observation :: forall tx. ChainEvent tx -> ChainStateType tx
newChainState :: ChainStateType tx
newChainState})
    | HeadId
ourHeadId HeadId -> HeadId -> Bool
forall a. Eq a => a -> a -> Bool
== HeadId
headId ->
        ClosedState tx -> ChainStateType tx -> UTxOType tx -> Outcome tx
forall tx.
IsTx tx =>
ClosedState tx -> ChainStateType tx -> UTxOType tx -> Outcome tx
onClosedChainPartialFanoutTx ClosedState tx
closedState ChainStateType tx
newChainState UTxOType tx
distributedOutputs
    | Bool
otherwise ->
        LogicError tx -> Outcome tx
forall tx. LogicError tx -> Outcome tx
Error NotOurHead{HeadId
$sel:ourHeadId:UnhandledInput :: HeadId
ourHeadId :: HeadId
ourHeadId, $sel:otherHeadId:UnhandledInput :: HeadId
otherHeadId = HeadId
headId}
  (FanoutProgress partialFanoutState :: PartialFanoutState tx
partialFanoutState@PartialFanoutState{$sel:headId:PartialFanoutState :: forall tx. PartialFanoutState tx -> HeadId
headId = HeadId
ourHeadId}, ChainInput Observation{$sel:observedTx:Observation :: forall tx. ChainEvent tx -> OnChainTx tx
observedTx = OnPartialFanoutTx{HeadId
$sel:headId:OnInitTx :: forall tx. OnChainTx tx -> HeadId
headId :: HeadId
headId, UTxOType tx
$sel:distributedOutputs:OnInitTx :: forall tx. OnChainTx tx -> UTxOType tx
distributedOutputs :: UTxOType tx
distributedOutputs}, ChainStateType tx
$sel:newChainState:Observation :: forall tx. ChainEvent tx -> ChainStateType tx
newChainState :: ChainStateType tx
newChainState})
    | HeadId
ourHeadId HeadId -> HeadId -> Bool
forall a. Eq a => a -> a -> Bool
== HeadId
headId ->
        PartialFanoutState tx
-> ChainStateType tx -> UTxOType tx -> Outcome tx
forall tx.
IsTx tx =>
PartialFanoutState tx
-> ChainStateType tx -> UTxOType tx -> Outcome tx
onPartialFanoutChainPartialFanoutTx PartialFanoutState tx
partialFanoutState ChainStateType tx
newChainState UTxOType tx
distributedOutputs
    | Bool
otherwise ->
        LogicError tx -> Outcome tx
forall tx. LogicError tx -> Outcome tx
Error NotOurHead{HeadId
$sel:ourHeadId:UnhandledInput :: HeadId
ourHeadId :: HeadId
ourHeadId, $sel:otherHeadId:UnhandledInput :: HeadId
otherHeadId = HeadId
headId}
  (FanoutProgress partialFanoutState :: PartialFanoutState tx
partialFanoutState@PartialFanoutState{$sel:headId:PartialFanoutState :: forall tx. PartialFanoutState tx -> HeadId
headId = HeadId
ourHeadId}, ChainInput Observation{$sel:observedTx:Observation :: forall tx. ChainEvent tx -> OnChainTx tx
observedTx = OnFanoutTx{HeadId
$sel:headId:OnInitTx :: forall tx. OnChainTx tx -> HeadId
headId :: HeadId
headId, UTxOType tx
$sel:fanoutUTxO:OnInitTx :: forall tx. OnChainTx tx -> UTxOType tx
fanoutUTxO :: UTxOType tx
fanoutUTxO}, ChainStateType tx
$sel:newChainState:Observation :: forall tx. ChainEvent tx -> ChainStateType tx
newChainState :: ChainStateType tx
newChainState})
    | HeadId
ourHeadId HeadId -> HeadId -> Bool
forall a. Eq a => a -> a -> Bool
== HeadId
headId ->
        PartialFanoutState tx
-> ChainStateType tx -> UTxOType tx -> Outcome tx
forall tx.
IsTx tx =>
PartialFanoutState tx
-> ChainStateType tx -> UTxOType tx -> Outcome tx
onPartialFanoutChainFanoutTx PartialFanoutState tx
partialFanoutState ChainStateType tx
newChainState UTxOType tx
fanoutUTxO
    | Bool
otherwise ->
        LogicError tx -> Outcome tx
forall tx. LogicError tx -> Outcome tx
Error NotOurHead{HeadId
$sel:ourHeadId:UnhandledInput :: HeadId
ourHeadId :: HeadId
ourHeadId, $sel:otherHeadId:UnhandledInput :: HeadId
otherHeadId = HeadId
headId}
  -- Node-level: deposit/recover observations scoped to our head
  (Open OpenState{$sel:headId:OpenState :: forall tx. OpenState tx -> HeadId
headId = HeadId
ourHeadId}, ChainInput Observation{$sel:observedTx:Observation :: forall tx. ChainEvent tx -> OnChainTx tx
observedTx = OnDepositTx{HeadId
$sel:headId:OnInitTx :: forall tx. OnChainTx tx -> HeadId
headId :: HeadId
headId, TxIdType tx
depositTxId :: forall tx. OnChainTx tx -> TxIdType tx
depositTxId :: TxIdType tx
depositTxId, UTxOType tx
deposited :: UTxOType tx
$sel:deposited:OnInitTx :: forall tx. OnChainTx tx -> UTxOType tx
deposited, UTCTime
created :: forall tx. OnChainTx tx -> UTCTime
created :: UTCTime
created, UTCTime
deadline :: UTCTime
$sel:deadline:OnInitTx :: forall tx. OnChainTx tx -> UTCTime
deadline}, ChainStateType tx
$sel:newChainState:Observation :: forall tx. ChainEvent tx -> ChainStateType tx
newChainState :: ChainStateType tx
newChainState})
    | HeadId
ourHeadId HeadId -> HeadId -> Bool
forall a. Eq a => a -> a -> Bool
== HeadId
headId ->
        StateChanged tx -> Outcome tx
forall tx. StateChanged tx -> Outcome tx
newState DepositRecorded{$sel:chainState:NetworkConnected :: ChainStateType tx
chainState = ChainStateType tx
newChainState, HeadId
$sel:headId:NetworkConnected :: HeadId
headId :: HeadId
headId, TxIdType tx
$sel:depositTxId:NetworkConnected :: TxIdType tx
depositTxId :: TxIdType tx
depositTxId, UTxOType tx
deposited :: UTxOType tx
$sel:deposited:NetworkConnected :: UTxOType tx
deposited, UTCTime
created :: UTCTime
created :: UTCTime
created, UTCTime
deadline :: UTCTime
$sel:deadline:NetworkConnected :: UTCTime
deadline}
    | Bool
otherwise ->
        [StateChanged tx] -> [Effect tx] -> Outcome tx
forall tx. [StateChanged tx] -> [Effect tx] -> Outcome tx
Continue [] []
  (Closed ClosedState{$sel:headId:ClosedState :: forall tx. ClosedState tx -> HeadId
headId = HeadId
ourHeadId}, ChainInput Observation{$sel:observedTx:Observation :: forall tx. ChainEvent tx -> OnChainTx tx
observedTx = OnDepositTx{HeadId
$sel:headId:OnInitTx :: forall tx. OnChainTx tx -> HeadId
headId :: HeadId
headId, TxIdType tx
depositTxId :: forall tx. OnChainTx tx -> TxIdType tx
depositTxId :: TxIdType tx
depositTxId, UTxOType tx
$sel:deposited:OnInitTx :: forall tx. OnChainTx tx -> UTxOType tx
deposited :: UTxOType tx
deposited, UTCTime
created :: forall tx. OnChainTx tx -> UTCTime
created :: UTCTime
created, UTCTime
$sel:deadline:OnInitTx :: forall tx. OnChainTx tx -> UTCTime
deadline :: UTCTime
deadline}, ChainStateType tx
$sel:newChainState:Observation :: forall tx. ChainEvent tx -> ChainStateType tx
newChainState :: ChainStateType tx
newChainState})
    | HeadId
ourHeadId HeadId -> HeadId -> Bool
forall a. Eq a => a -> a -> Bool
== HeadId
headId ->
        StateChanged tx -> Outcome tx
forall tx. StateChanged tx -> Outcome tx
newState DepositRecorded{$sel:chainState:NetworkConnected :: ChainStateType tx
chainState = ChainStateType tx
newChainState, HeadId
$sel:headId:NetworkConnected :: HeadId
headId :: HeadId
headId, TxIdType tx
$sel:depositTxId:NetworkConnected :: TxIdType tx
depositTxId :: TxIdType tx
depositTxId, UTxOType tx
$sel:deposited:NetworkConnected :: UTxOType tx
deposited :: UTxOType tx
deposited, UTCTime
created :: UTCTime
created :: UTCTime
created, UTCTime
$sel:deadline:NetworkConnected :: UTCTime
deadline :: UTCTime
deadline}
    | Bool
otherwise ->
        [StateChanged tx] -> [Effect tx] -> Outcome tx
forall tx. [StateChanged tx] -> [Effect tx] -> Outcome tx
Continue [] []
  -- Mirror the 'Closed' case while mid-fanout: a deposit observed during a
  -- (partial) fanout must still be recorded so it remains recoverable via
  -- 'Recover'. Without this the input falls through to 'Error' and is dropped.
  (FanoutProgress PartialFanoutState{$sel:headId:PartialFanoutState :: forall tx. PartialFanoutState tx -> HeadId
headId = HeadId
ourHeadId}, ChainInput Observation{$sel:observedTx:Observation :: forall tx. ChainEvent tx -> OnChainTx tx
observedTx = OnDepositTx{HeadId
$sel:headId:OnInitTx :: forall tx. OnChainTx tx -> HeadId
headId :: HeadId
headId, TxIdType tx
depositTxId :: forall tx. OnChainTx tx -> TxIdType tx
depositTxId :: TxIdType tx
depositTxId, UTxOType tx
$sel:deposited:OnInitTx :: forall tx. OnChainTx tx -> UTxOType tx
deposited :: UTxOType tx
deposited, UTCTime
created :: forall tx. OnChainTx tx -> UTCTime
created :: UTCTime
created, UTCTime
$sel:deadline:OnInitTx :: forall tx. OnChainTx tx -> UTCTime
deadline :: UTCTime
deadline}, ChainStateType tx
$sel:newChainState:Observation :: forall tx. ChainEvent tx -> ChainStateType tx
newChainState :: ChainStateType tx
newChainState})
    | HeadId
ourHeadId HeadId -> HeadId -> Bool
forall a. Eq a => a -> a -> Bool
== HeadId
headId ->
        StateChanged tx -> Outcome tx
forall tx. StateChanged tx -> Outcome tx
newState DepositRecorded{$sel:chainState:NetworkConnected :: ChainStateType tx
chainState = ChainStateType tx
newChainState, HeadId
$sel:headId:NetworkConnected :: HeadId
headId :: HeadId
headId, TxIdType tx
$sel:depositTxId:NetworkConnected :: TxIdType tx
depositTxId :: TxIdType tx
depositTxId, UTxOType tx
$sel:deposited:NetworkConnected :: UTxOType tx
deposited :: UTxOType tx
deposited, UTCTime
created :: UTCTime
created :: UTCTime
created, UTCTime
$sel:deadline:NetworkConnected :: UTCTime
deadline :: UTCTime
deadline}
    | Bool
otherwise ->
        [StateChanged tx] -> [Effect tx] -> Outcome tx
forall tx. [StateChanged tx] -> [Effect tx] -> Outcome tx
Continue [] []
  (Idle IdleState tx
_, ChainInput Observation{$sel:observedTx:Observation :: forall tx. ChainEvent tx -> OnChainTx tx
observedTx = OnDepositTx{}}) ->
    [StateChanged tx] -> [Effect tx] -> Outcome tx
forall tx. [StateChanged tx] -> [Effect tx] -> Outcome tx
Continue [] []
  -- Deposit recovery is node-level: emit DepositRecovered for any tracked deposit
  -- regardless of which head is currently active. Previous-head deposits survive
  -- fanout in 'pendingDeposits', so recovery works even while a new head is Open.
  -- Unrelated deposits (never in pendingDeposits) are silently ignored.
  (HeadState tx
_, ChainInput Observation{$sel:observedTx:Observation :: forall tx. ChainEvent tx -> OnChainTx tx
observedTx = OnRecoverTx{HeadId
$sel:headId:OnInitTx :: forall tx. OnChainTx tx -> HeadId
headId :: HeadId
headId, TxIdType tx
recoveredTxId :: TxIdType tx
$sel:recoveredTxId:OnInitTx :: forall tx. OnChainTx tx -> TxIdType tx
recoveredTxId, UTxOType tx
recoveredUTxO :: UTxOType tx
$sel:recoveredUTxO:OnInitTx :: forall tx. OnChainTx tx -> UTxOType tx
recoveredUTxO}, ChainStateType tx
$sel:newChainState:Observation :: forall tx. ChainEvent tx -> ChainStateType tx
newChainState :: ChainStateType tx
newChainState})
    | TxIdType tx -> PendingDeposits tx -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member TxIdType tx
recoveredTxId PendingDeposits tx
pendingDeposits ->
        StateChanged tx -> Outcome tx
forall tx. StateChanged tx -> Outcome tx
newState DepositRecovered{$sel:chainState:NetworkConnected :: ChainStateType tx
chainState = ChainStateType tx
newChainState, HeadId
$sel:headId:NetworkConnected :: HeadId
headId :: HeadId
headId, $sel:depositTxId:NetworkConnected :: TxIdType tx
depositTxId = TxIdType tx
recoveredTxId, $sel:recovered:NetworkConnected :: UTxOType tx
recovered = UTxOType tx
recoveredUTxO}
    | Bool
otherwise ->
        [StateChanged tx] -> [Effect tx] -> Outcome tx
forall tx. [StateChanged tx] -> [Effect tx] -> Outcome tx
Continue [] []
  -- Open + Rollback: re-post IncrementTx/DecrementTx if they were in-flight
  ( Open
      OpenState
        { HeadSeed
$sel:headSeed:OpenState :: forall tx. OpenState tx -> HeadSeed
headSeed :: HeadSeed
headSeed
        , HeadId
$sel:headId:OpenState :: forall tx. OpenState tx -> HeadId
headId :: HeadId
headId
        , HeadParameters
$sel:parameters:OpenState :: forall tx. OpenState tx -> HeadParameters
parameters :: HeadParameters
parameters
        , $sel:coordinatedHeadState:OpenState :: forall tx. OpenState tx -> CoordinatedHeadState tx
coordinatedHeadState =
          CoordinatedHeadState
            { ConfirmedSnapshot tx
$sel:confirmedSnapshot:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> ConfirmedSnapshot tx
confirmedSnapshot :: ConfirmedSnapshot tx
confirmedSnapshot
            , Maybe tx
$sel:decommitTx:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> Maybe tx
decommitTx :: Maybe tx
decommitTx
            }
        }
    , ChainInput Rollback{ChainStateType tx
rolledBackChainState :: ChainStateType tx
$sel:rolledBackChainState:Observation :: forall tx. ChainEvent tx -> ChainStateType tx
rolledBackChainState, UTCTime
$sel:chainTime:Observation :: forall tx. ChainEvent tx -> UTCTime
chainTime :: UTCTime
chainTime}
    ) ->
      StateChanged tx -> Outcome tx
forall tx. StateChanged tx -> Outcome tx
newState ChainRolledBack{$sel:chainState:NetworkConnected :: ChainStateType tx
chainState = ChainStateType tx
rolledBackChainState}
        Outcome tx -> Outcome tx -> Outcome tx
forall a. Semigroup a => a -> a -> a
<> Environment
-> UTCTime
-> ChainPointType tx
-> UTCTime
-> SyncedStatus
-> Outcome tx
forall tx.
IsChainState tx =>
Environment
-> UTCTime
-> ChainPointType tx
-> UTCTime
-> SyncedStatus
-> Outcome tx
handleOutOfSync Environment
env UTCTime
now (ChainStateType tx -> ChainPointType tx
forall tx.
IsChainState tx =>
ChainStateType tx -> ChainPointType tx
chainStatePoint ChainStateType tx
rolledBackChainState) UTCTime
chainTime SyncedStatus
syncStatus
        Outcome tx -> Outcome tx -> Outcome tx
forall a. Semigroup a => a -> a -> a
<> HeadSeed
-> HeadId
-> HeadParameters
-> PendingDeposits tx
-> ConfirmedSnapshot tx
-> Outcome tx
forall tx.
IsTx tx =>
HeadSeed
-> HeadId
-> HeadParameters
-> PendingDeposits tx
-> ConfirmedSnapshot tx
-> Outcome tx
maybeRepostIncrementTx HeadSeed
headSeed HeadId
headId HeadParameters
parameters (HeadId -> PendingDeposits tx -> PendingDeposits tx
forall tx. HeadId -> PendingDeposits tx -> PendingDeposits tx
depositsForHead HeadId
headId PendingDeposits tx
pendingDeposits) ConfirmedSnapshot tx
confirmedSnapshot
        Outcome tx -> Outcome tx -> Outcome tx
forall a. Semigroup a => a -> a -> a
<> HeadSeed
-> HeadId
-> HeadParameters
-> Maybe tx
-> ConfirmedSnapshot tx
-> Outcome tx
forall tx.
HeadSeed
-> HeadId
-> HeadParameters
-> Maybe tx
-> ConfirmedSnapshot tx
-> Outcome tx
maybeRepostDecrementTx HeadSeed
headSeed HeadId
headId HeadParameters
parameters Maybe tx
decommitTx ConfirmedSnapshot tx
confirmedSnapshot
  -- FanoutProgress + Rollback: re-post the next fanout step so the fanout
  -- resumes rather than stalling (the in-flight fanout tx may have been rolled
  -- back). Mirrors the Open re-post above.
  (FanoutProgress PartialFanoutState tx
partialFanoutState, ChainInput Rollback{ChainStateType tx
$sel:rolledBackChainState:Observation :: forall tx. ChainEvent tx -> ChainStateType tx
rolledBackChainState :: ChainStateType tx
rolledBackChainState, UTCTime
$sel:chainTime:Observation :: forall tx. ChainEvent tx -> UTCTime
chainTime :: UTCTime
chainTime}) ->
    StateChanged tx -> Outcome tx
forall tx. StateChanged tx -> Outcome tx
newState ChainRolledBack{$sel:chainState:NetworkConnected :: ChainStateType tx
chainState = ChainStateType tx
rolledBackChainState}
      Outcome tx -> Outcome tx -> Outcome tx
forall a. Semigroup a => a -> a -> a
<> Environment
-> UTCTime
-> ChainPointType tx
-> UTCTime
-> SyncedStatus
-> Outcome tx
forall tx.
IsChainState tx =>
Environment
-> UTCTime
-> ChainPointType tx
-> UTCTime
-> SyncedStatus
-> Outcome tx
handleOutOfSync Environment
env UTCTime
now (ChainStateType tx -> ChainPointType tx
forall tx.
IsChainState tx =>
ChainStateType tx -> ChainPointType tx
chainStatePoint ChainStateType tx
rolledBackChainState) UTCTime
chainTime SyncedStatus
syncStatus
      Outcome tx -> Outcome tx -> Outcome tx
forall a. Semigroup a => a -> a -> a
<> PartialFanoutState tx -> Outcome tx
forall tx. IsTx tx => PartialFanoutState tx -> Outcome tx
repostFanoutStep PartialFanoutState tx
partialFanoutState
  -- General
  (HeadState tx
_, ChainInput Rollback{ChainStateType tx
$sel:rolledBackChainState:Observation :: forall tx. ChainEvent tx -> ChainStateType tx
rolledBackChainState :: ChainStateType tx
rolledBackChainState, UTCTime
$sel:chainTime:Observation :: forall tx. ChainEvent tx -> UTCTime
chainTime :: UTCTime
chainTime}) ->
    StateChanged tx -> Outcome tx
forall tx. StateChanged tx -> Outcome tx
newState ChainRolledBack{$sel:chainState:NetworkConnected :: ChainStateType tx
chainState = ChainStateType tx
rolledBackChainState}
      Outcome tx -> Outcome tx -> Outcome tx
forall a. Semigroup a => a -> a -> a
<> Environment
-> UTCTime
-> ChainPointType tx
-> UTCTime
-> SyncedStatus
-> Outcome tx
forall tx.
IsChainState tx =>
Environment
-> UTCTime
-> ChainPointType tx
-> UTCTime
-> SyncedStatus
-> Outcome tx
handleOutOfSync Environment
env UTCTime
now (ChainStateType tx -> ChainPointType tx
forall tx.
IsChainState tx =>
ChainStateType tx -> ChainPointType tx
chainStatePoint ChainStateType tx
rolledBackChainState) UTCTime
chainTime SyncedStatus
syncStatus
  (HeadState tx
_, ChainInput Tick{UTCTime
$sel:chainTime:Observation :: forall tx. ChainEvent tx -> UTCTime
chainTime :: UTCTime
chainTime, ChainPointType tx
$sel:chainPoint:Observation :: forall tx. ChainEvent tx -> ChainPointType tx
chainPoint :: ChainPointType tx
chainPoint}) ->
    StateChanged tx -> Outcome tx
forall tx. StateChanged tx -> Outcome tx
newState TickObserved{ChainPointType tx
$sel:chainPoint:NetworkConnected :: ChainPointType tx
chainPoint :: ChainPointType tx
chainPoint, UTCTime
$sel:chainTime:NetworkConnected :: UTCTime
chainTime :: UTCTime
chainTime}
      Outcome tx -> Outcome tx -> Outcome tx
forall a. Semigroup a => a -> a -> a
<> Environment
-> UTCTime
-> ChainPointType tx
-> UTCTime
-> SyncedStatus
-> Outcome tx
forall tx.
IsChainState tx =>
Environment
-> UTCTime
-> ChainPointType tx
-> UTCTime
-> SyncedStatus
-> Outcome tx
handleOutOfSync Environment
env UTCTime
now ChainPointType tx
chainPoint UTCTime
chainTime SyncedStatus
syncStatus
      Outcome tx -> Outcome tx -> Outcome tx
forall a. Semigroup a => a -> a -> a
<> Environment -> PendingDeposits tx -> UTCTime -> Outcome tx
forall tx.
IsTx tx =>
Environment -> PendingDeposits tx -> UTCTime -> Outcome tx
onChainTick Environment
env PendingDeposits tx
pendingDeposits UTCTime
chainTime
  (HeadState tx
_, ChainInput PostTxError{$sel:postTxError:Observation :: forall tx. ChainEvent tx -> PostTxError tx
postTxError = PostTxError tx
StalePartialFanoutTx}) ->
    -- The chain advanced past this step before we could post it (another node
    -- was faster). The chain observation loop already emitted the correct next
    -- step, so this is safe to ignore.
    Outcome tx
forall tx. Outcome tx
noop
  (FanoutProgress PartialFanoutState{HeadId
$sel:headId:PartialFanoutState :: forall tx. PartialFanoutState tx -> HeadId
headId :: HeadId
headId, UTxOType tx
$sel:distributedOutputs:PartialFanoutState :: forall tx. PartialFanoutState tx -> UTxOType tx
distributedOutputs :: UTxOType tx
distributedOutputs}, ChainInput PostTxError{PostChainTx tx
postChainTx :: PostChainTx tx
$sel:postChainTx:Observation :: forall tx. ChainEvent tx -> PostChainTx tx
postChainTx, PostTxError tx
$sel:postTxError:Observation :: forall tx. ChainEvent tx -> PostTxError tx
postTxError :: PostTxError tx
postTxError})
    -- We optimistically moved 'Closed' → 'PartialFanout' when the fanout was
    -- initiated. If posting the initiating fanout tx fails terminally before
    -- anything has been distributed on chain (so the on-chain datum is still
    -- 'Closed'), revert to 'Closed' rather than wedging the head — otherwise
    -- 'Fanout' stays rejected and there is no clean way to recover. Once any
    -- partial fanout has landed ('distributedOutputs' non-empty) the on-chain
    -- datum is genuinely 'FanoutProgress', so we must not revert.
    | PostChainTx tx -> Bool
forall tx. PostChainTx tx -> Bool
isFanoutPostChainTx PostChainTx tx
postChainTx Bool -> Bool -> Bool
&& UTxOType tx -> Bool
forall tx. IsTx tx => UTxOType tx -> Bool
nullOutputs UTxOType tx
distributedOutputs ->
        StateChanged tx -> Outcome tx
forall tx. StateChanged tx -> Outcome tx
newState HeadFanoutReverted{HeadId
$sel:headId:NetworkConnected :: HeadId
headId :: HeadId
headId}
          Outcome tx -> Outcome tx -> Outcome tx
forall a. Semigroup a => a -> a -> a
<> Effect tx -> Outcome tx
forall tx. Effect tx -> Outcome tx
cause (ClientMessage tx -> Effect tx
forall tx. ClientMessage tx -> Effect tx
ClientEffect ServerOutput.PostTxOnChainFailed{PostChainTx tx
postChainTx :: PostChainTx tx
$sel:postChainTx:CommandFailed :: PostChainTx tx
postChainTx, PostTxError tx
postTxError :: PostTxError tx
$sel:postTxError:CommandFailed :: PostTxError tx
postTxError})
  (HeadState tx
_, ChainInput PostTxError{PostChainTx tx
$sel:postChainTx:Observation :: forall tx. ChainEvent tx -> PostChainTx tx
postChainTx :: PostChainTx tx
postChainTx, PostTxError tx
$sel:postTxError:Observation :: forall tx. ChainEvent tx -> PostTxError tx
postTxError :: PostTxError tx
postTxError}) ->
    Effect tx -> Outcome tx
forall tx. Effect tx -> Outcome tx
cause (Effect tx -> Outcome tx)
-> (ClientMessage tx -> Effect tx)
-> ClientMessage tx
-> Outcome tx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClientMessage tx -> Effect tx
forall tx. ClientMessage tx -> Effect tx
ClientEffect (ClientMessage tx -> Outcome tx) -> ClientMessage tx -> Outcome tx
forall a b. (a -> b) -> a -> b
$ ServerOutput.PostTxOnChainFailed{PostChainTx tx
$sel:postChainTx:CommandFailed :: PostChainTx tx
postChainTx :: PostChainTx tx
postChainTx, PostTxError tx
$sel:postTxError:CommandFailed :: PostTxError tx
postTxError :: PostTxError tx
postTxError}
  (HeadState tx, Input tx)
_ ->
    LogicError tx -> Outcome tx
forall tx. LogicError tx -> Outcome tx
Error (LogicError tx -> Outcome tx) -> LogicError tx -> Outcome tx
forall a b. (a -> b) -> a -> b
$ Input tx -> HeadState tx -> LogicError tx
forall tx. Input tx -> HeadState tx -> LogicError tx
UnhandledInput Input tx
ev HeadState tx
st

handleNetworkInput ::
  IsChainState tx =>
  Environment ->
  Ledger tx ->
  -- | Last known chain point time
  ChainPointTime ->
  PendingDeposits tx ->
  -- | Current NodeState to validate the command against.
  HeadState tx ->
  -- | Input to be processed.
  Input tx ->
  Outcome tx
handleNetworkInput :: forall tx.
IsChainState tx =>
Environment
-> Ledger tx
-> ChainPointTime
-> PendingDeposits tx
-> HeadState tx
-> Input tx
-> Outcome tx
handleNetworkInput Environment
env Ledger tx
ledger ChainPointTime{ChainSlot
$sel:currentSlot:ChainPointTime :: ChainPointTime -> ChainSlot
currentSlot :: ChainSlot
currentSlot} PendingDeposits tx
pendingDeposits HeadState tx
st Input tx
ev = case (HeadState tx
st, Input tx
ev) of
  (HeadState tx
_, NetworkInput TTL
_ (ConnectivityEvent Connectivity
conn)) ->
    Text -> Connectivity -> Outcome tx
forall tx. Text -> Connectivity -> Outcome tx
onConnectionEvent Environment
env.configuredPeers Connectivity
conn
  -- Open
  (Open openState :: OpenState tx
openState@OpenState{$sel:headId:OpenState :: forall tx. OpenState tx -> HeadId
headId = HeadId
ourHeadId}, NetworkInput TTL
ttl (ReceivedMessage{$sel:msg:ConnectivityEvent :: forall msg. NetworkEvent msg -> msg
msg = ReqTx tx
tx})) ->
    Environment
-> Ledger tx
-> ChainSlot
-> OpenState tx
-> TTL
-> PendingDeposits tx
-> tx
-> Outcome tx
forall tx.
IsTx tx =>
Environment
-> Ledger tx
-> ChainSlot
-> OpenState tx
-> TTL
-> PendingDeposits tx
-> tx
-> Outcome tx
onOpenNetworkReqTx Environment
env Ledger tx
ledger ChainSlot
currentSlot OpenState tx
openState TTL
ttl (HeadId -> PendingDeposits tx -> PendingDeposits tx
forall tx. HeadId -> PendingDeposits tx -> PendingDeposits tx
depositsForHead HeadId
ourHeadId PendingDeposits tx
pendingDeposits) tx
tx
  (Open openState :: OpenState tx
openState@OpenState{$sel:headId:OpenState :: forall tx. OpenState tx -> HeadId
headId = HeadId
ourHeadId}, NetworkInput TTL
_ (ReceivedMessage{Party
sender :: Party
$sel:sender:ConnectivityEvent :: forall msg. NetworkEvent msg -> Party
sender, $sel:msg:ConnectivityEvent :: forall msg. NetworkEvent msg -> msg
msg = ReqSn SnapshotVersion
sv SnapshotNumber
sn [TxIdType tx]
txIds Maybe tx
decommitTx Maybe (TxIdType tx)
depositTxId})) ->
    Environment
-> Ledger tx
-> PendingDeposits tx
-> ChainSlot
-> OpenState tx
-> Party
-> SnapshotVersion
-> SnapshotNumber
-> [TxIdType tx]
-> Maybe tx
-> Maybe (TxIdType tx)
-> Outcome tx
forall tx.
IsTx tx =>
Environment
-> Ledger tx
-> PendingDeposits tx
-> ChainSlot
-> OpenState tx
-> Party
-> SnapshotVersion
-> SnapshotNumber
-> [TxIdType tx]
-> Maybe tx
-> Maybe (TxIdType tx)
-> Outcome tx
onOpenNetworkReqSn Environment
env Ledger tx
ledger (HeadId -> PendingDeposits tx -> PendingDeposits tx
forall tx. HeadId -> PendingDeposits tx -> PendingDeposits tx
depositsForHead HeadId
ourHeadId PendingDeposits tx
pendingDeposits) ChainSlot
currentSlot OpenState tx
openState Party
sender SnapshotVersion
sv SnapshotNumber
sn [TxIdType tx]
txIds Maybe tx
decommitTx Maybe (TxIdType tx)
depositTxId
  (Open openState :: OpenState tx
openState@OpenState{$sel:headId:OpenState :: forall tx. OpenState tx -> HeadId
headId = HeadId
ourHeadId}, NetworkInput TTL
_ (ReceivedMessage{Party
$sel:sender:ConnectivityEvent :: forall msg. NetworkEvent msg -> Party
sender :: Party
sender, $sel:msg:ConnectivityEvent :: forall msg. NetworkEvent msg -> msg
msg = AckSn Signature (Snapshot tx)
snapshotSignature SnapshotNumber
sn})) ->
    Environment
-> PendingDeposits tx
-> OpenState tx
-> Party
-> Signature (Snapshot tx)
-> SnapshotNumber
-> Outcome tx
forall tx.
IsTx tx =>
Environment
-> PendingDeposits tx
-> OpenState tx
-> Party
-> Signature (Snapshot tx)
-> SnapshotNumber
-> Outcome tx
onOpenNetworkAckSn Environment
env (HeadId -> PendingDeposits tx -> PendingDeposits tx
forall tx. HeadId -> PendingDeposits tx -> PendingDeposits tx
depositsForHead HeadId
ourHeadId PendingDeposits tx
pendingDeposits) OpenState tx
openState Party
sender Signature (Snapshot tx)
snapshotSignature SnapshotNumber
sn
  (Open openState :: OpenState tx
openState@OpenState{$sel:headId:OpenState :: forall tx. OpenState tx -> HeadId
headId = HeadId
ourHeadId}, NetworkInput TTL
ttl (ReceivedMessage{$sel:msg:ConnectivityEvent :: forall msg. NetworkEvent msg -> msg
msg = ReqDec{tx
$sel:transaction:ReqTx :: forall tx. Message tx -> tx
transaction :: tx
transaction}})) ->
    Environment
-> Ledger tx
-> TTL
-> ChainSlot
-> PendingDeposits tx
-> OpenState tx
-> tx
-> Outcome tx
forall tx.
IsTx tx =>
Environment
-> Ledger tx
-> TTL
-> ChainSlot
-> PendingDeposits tx
-> OpenState tx
-> tx
-> Outcome tx
onOpenNetworkReqDec Environment
env Ledger tx
ledger TTL
ttl ChainSlot
currentSlot (HeadId -> PendingDeposits tx -> PendingDeposits tx
forall tx. HeadId -> PendingDeposits tx -> PendingDeposits tx
depositsForHead HeadId
ourHeadId PendingDeposits tx
pendingDeposits) OpenState tx
openState tx
transaction
  (HeadState tx, Input tx)
_ ->
    LogicError tx -> Outcome tx
forall tx. LogicError tx -> Outcome tx
Error (LogicError tx -> Outcome tx) -> LogicError tx -> Outcome tx
forall a b. (a -> b) -> a -> b
$ Input tx -> HeadState tx -> LogicError tx
forall tx. Input tx -> HeadState tx -> LogicError tx
UnhandledInput Input tx
ev HeadState tx
st

onConnectionEvent :: Text -> Network.Connectivity -> Outcome tx
onConnectionEvent :: forall tx. Text -> Connectivity -> Outcome tx
onConnectionEvent Text
misconfiguredPeers = \case
  Connectivity
Network.NetworkConnected ->
    StateChanged tx -> Outcome tx
forall tx. StateChanged tx -> Outcome tx
newState StateChanged tx
forall tx. StateChanged tx
NetworkConnected
  Connectivity
Network.NetworkDisconnected ->
    StateChanged tx -> Outcome tx
forall tx. StateChanged tx -> Outcome tx
newState StateChanged tx
forall tx. StateChanged tx
NetworkDisconnected
  Network.VersionMismatch{ProtocolVersion
ourVersion :: ProtocolVersion
$sel:ourVersion:PeerConnected :: Connectivity -> ProtocolVersion
ourVersion, Maybe ProtocolVersion
theirVersion :: Maybe ProtocolVersion
$sel:theirVersion:PeerConnected :: Connectivity -> Maybe ProtocolVersion
theirVersion} ->
    StateChanged tx -> Outcome tx
forall tx. StateChanged tx -> Outcome tx
newState NetworkVersionMismatch{ProtocolVersion
ourVersion :: ProtocolVersion
$sel:ourVersion:NetworkConnected :: ProtocolVersion
ourVersion, Maybe ProtocolVersion
theirVersion :: Maybe ProtocolVersion
$sel:theirVersion:NetworkConnected :: Maybe ProtocolVersion
theirVersion}
  Network.ClusterIDMismatch{Text
clusterPeers :: Text
$sel:clusterPeers:PeerConnected :: Connectivity -> Text
clusterPeers} ->
    StateChanged tx -> Outcome tx
forall tx. StateChanged tx -> Outcome tx
newState NetworkClusterIDMismatch{Text
clusterPeers :: Text
$sel:clusterPeers:NetworkConnected :: Text
clusterPeers, Text
misconfiguredPeers :: Text
$sel:misconfiguredPeers:NetworkConnected :: Text
misconfiguredPeers}
  Network.PeerConnected{Host
peer :: Host
$sel:peer:PeerConnected :: Connectivity -> Host
peer} ->
    StateChanged tx -> Outcome tx
forall tx. StateChanged tx -> Outcome tx
newState PeerConnected{Host
peer :: Host
$sel:peer:NetworkConnected :: Host
peer}
  Network.PeerDisconnected{Host
$sel:peer:PeerConnected :: Connectivity -> Host
peer :: Host
peer} ->
    StateChanged tx -> Outcome tx
forall tx. StateChanged tx -> Outcome tx
newState PeerDisconnected{Host
$sel:peer:NetworkConnected :: Host
peer :: Host
peer}

handleClientInput ::
  IsChainState tx =>
  Environment ->
  Ledger tx ->
  -- | Last known chain point time
  ChainPointTime ->
  PendingDeposits tx ->
  -- | Current NodeState to validate the command against.
  HeadState tx ->
  -- | Input to be processed.
  Input tx ->
  Outcome tx
handleClientInput :: forall tx.
IsChainState tx =>
Environment
-> Ledger tx
-> ChainPointTime
-> PendingDeposits tx
-> HeadState tx
-> Input tx
-> Outcome tx
handleClientInput Environment
env Ledger tx
ledger ChainPointTime{ChainSlot
$sel:currentSlot:ChainPointTime :: ChainPointTime -> ChainSlot
currentSlot :: ChainSlot
currentSlot} PendingDeposits tx
pendingDeposits HeadState tx
st Input tx
ev = case (HeadState tx
st, Input tx
ev) of
  (Idle IdleState tx
_, ClientInput ClientInput tx
Init) ->
    Environment -> Outcome tx
forall tx. Environment -> Outcome tx
onIdleClientInit Environment
env
  -- Open
  (Open OpenState tx
openState, ClientInput ClientInput tx
Close) ->
    OpenState tx -> Outcome tx
forall tx. OpenState tx -> Outcome tx
onOpenClientClose OpenState tx
openState
  (Open OpenState tx
openState, ClientInput ClientInput tx
SafeClose) ->
    OpenState tx -> Outcome tx
forall tx. OpenState tx -> Outcome tx
onOpenClientClose OpenState tx
openState
  (Open{}, ClientInput (NewTx tx
tx)) ->
    tx -> Outcome tx
forall tx. tx -> Outcome tx
onOpenClientNewTx tx
tx
  (Open openState :: OpenState tx
openState@OpenState{$sel:headId:OpenState :: forall tx. OpenState tx -> HeadId
headId = HeadId
ourHeadId}, ClientInput (SideLoadSnapshot ConfirmedSnapshot tx
confirmedSnapshot)) ->
    let Snapshot{$sel:headId:Snapshot :: forall tx. Snapshot tx -> HeadId
headId = HeadId
otherHeadId} = ConfirmedSnapshot tx -> Snapshot tx
forall tx. IsTx tx => ConfirmedSnapshot tx -> Snapshot tx
getSnapshot ConfirmedSnapshot tx
confirmedSnapshot
     in if HeadId
ourHeadId HeadId -> HeadId -> Bool
forall a. Eq a => a -> a -> Bool
== HeadId
otherHeadId
          then OpenState tx -> ConfirmedSnapshot tx -> Outcome tx
forall tx.
IsTx tx =>
OpenState tx -> ConfirmedSnapshot tx -> Outcome tx
onOpenClientSideLoadSnapshot OpenState tx
openState ConfirmedSnapshot tx
confirmedSnapshot
          else LogicError tx -> Outcome tx
forall tx. LogicError tx -> Outcome tx
Error NotOurHead{HeadId
$sel:ourHeadId:UnhandledInput :: HeadId
ourHeadId :: HeadId
ourHeadId, HeadId
$sel:otherHeadId:UnhandledInput :: HeadId
otherHeadId :: HeadId
otherHeadId}
  (Open OpenState{HeadId
$sel:headId:OpenState :: forall tx. OpenState tx -> HeadId
headId :: HeadId
headId, CoordinatedHeadState tx
$sel:coordinatedHeadState:OpenState :: forall tx. OpenState tx -> CoordinatedHeadState tx
coordinatedHeadState :: CoordinatedHeadState tx
coordinatedHeadState}, ClientInput Decommit{tx
decommitTx :: tx
$sel:decommitTx:Init :: forall tx. ClientInput tx -> tx
decommitTx}) -> do
    HeadId
-> Ledger tx
-> ChainSlot
-> CoordinatedHeadState tx
-> tx
-> Outcome tx
forall tx.
IsTx tx =>
HeadId
-> Ledger tx
-> ChainSlot
-> CoordinatedHeadState tx
-> tx
-> Outcome tx
onOpenClientDecommit HeadId
headId Ledger tx
ledger ChainSlot
currentSlot CoordinatedHeadState tx
coordinatedHeadState tx
decommitTx
  -- Closed
  (Closed ClosedState tx
closedState, ClientInput ClientInput tx
Fanout) ->
    ClosedState tx -> Outcome tx
forall tx. IsTx tx => ClosedState tx -> Outcome tx
onClosedClientFanout ClosedState tx
closedState
  (Closed ClosedState tx
closedState, ClientInput PartialFanout{UTxOType tx
utxoToFanout :: UTxOType tx
$sel:utxoToFanout:Init :: forall tx. ClientInput tx -> UTxOType tx
utxoToFanout}) ->
    ClosedState tx -> UTxOType tx -> Outcome tx
forall tx. IsTx tx => ClosedState tx -> UTxOType tx -> Outcome tx
onClosedClientPartialFanout ClosedState tx
closedState UTxOType tx
utxoToFanout
  -- PartialFanout: once a partial fanout has started, only further
  -- 'PartialFanout' commands are accepted (a plain 'Fanout' falls through to the
  -- general 'CommandFailed' below).
  (FanoutProgress PartialFanoutState tx
partialFanoutState, ClientInput PartialFanout{UTxOType tx
$sel:utxoToFanout:Init :: forall tx. ClientInput tx -> UTxOType tx
utxoToFanout :: UTxOType tx
utxoToFanout}) ->
    PartialFanoutState tx -> UTxOType tx -> Outcome tx
forall tx.
IsTx tx =>
PartialFanoutState tx -> UTxOType tx -> Outcome tx
onPartialFanoutClientPartialFanout PartialFanoutState tx
partialFanoutState UTxOType tx
utxoToFanout
  -- Node-level
  (HeadState tx
_, ClientInput Recover{TxIdType tx
recoverTxId :: TxIdType tx
$sel:recoverTxId:Init :: forall tx. ClientInput tx -> TxIdType tx
recoverTxId}) -> do
    ChainSlot -> PendingDeposits tx -> TxIdType tx -> Outcome tx
forall tx.
IsTx tx =>
ChainSlot -> PendingDeposits tx -> TxIdType tx -> Outcome tx
onClientRecover ChainSlot
currentSlot PendingDeposits tx
pendingDeposits TxIdType tx
recoverTxId
  -- General
  (HeadState tx
_, ClientInput{ClientInput tx
$sel:clientInput:ClientInput :: forall tx. Input tx -> ClientInput tx
clientInput :: ClientInput tx
clientInput}) ->
    Effect tx -> Outcome tx
forall tx. Effect tx -> Outcome tx
cause (Effect tx -> Outcome tx)
-> (ClientMessage tx -> Effect tx)
-> ClientMessage tx
-> Outcome tx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClientMessage tx -> Effect tx
forall tx. ClientMessage tx -> Effect tx
ClientEffect (ClientMessage tx -> Outcome tx) -> ClientMessage tx -> Outcome tx
forall a b. (a -> b) -> a -> b
$ ClientInput tx -> HeadState tx -> ClientMessage tx
forall tx. ClientInput tx -> HeadState tx -> ClientMessage tx
ServerOutput.CommandFailed ClientInput tx
clientInput HeadState tx
st
  (HeadState tx, Input tx)
_ ->
    LogicError tx -> Outcome tx
forall tx. LogicError tx -> Outcome tx
Error (LogicError tx -> Outcome tx) -> LogicError tx -> Outcome tx
forall a b. (a -> b) -> a -> b
$ Input tx -> HeadState tx -> LogicError tx
forall tx. Input tx -> HeadState tx -> LogicError tx
UnhandledInput Input tx
ev HeadState tx
st

-- * NodeState aggregate

-- | Reflect 'StateChanged' events onto the 'NodeState' aggregateNodeState.
-- Events carrying a 'HeadId' that does not match the current state are silently
-- ignored, preventing cross-head state contamination during event replay.
-- Events without a 'HeadId' are always applied.
aggregateNodeState :: IsChainState tx => NodeState tx -> StateChanged tx -> NodeState tx
aggregateNodeState :: forall tx.
IsChainState tx =>
NodeState tx -> StateChanged tx -> NodeState tx
aggregateNodeState NodeState tx
nodeState StateChanged tx
sc =
  case (HeadState tx -> Maybe HeadId
forall tx. HeadState tx -> Maybe HeadId
headIdOf (NodeState tx -> HeadState tx
forall tx. NodeState tx -> HeadState tx
headState NodeState tx
nodeState), StateChanged tx -> Maybe HeadId
forall tx. StateChanged tx -> Maybe HeadId
eventHeadId StateChanged tx
sc) of
    (Just HeadId
sid, Just HeadId
eid) | HeadId
sid HeadId -> HeadId -> Bool
forall a. Eq a => a -> a -> Bool
/= HeadId
eid -> NodeState tx
nodeState
    (Maybe HeadId, Maybe HeadId)
_ ->
      let currentPendingDeposits :: PendingDeposits tx
currentPendingDeposits = NodeState tx -> PendingDeposits tx
forall tx. NodeState tx -> PendingDeposits tx
pendingDeposits NodeState tx
nodeState
          st :: HeadState tx
st = HeadState tx -> StateChanged tx -> HeadState tx
forall tx.
IsChainState tx =>
HeadState tx -> StateChanged tx -> HeadState tx
applyEvent (NodeState tx -> HeadState tx
forall tx. NodeState tx -> HeadState tx
headState NodeState tx
nodeState) StateChanged tx
sc
          chainPointTimeState :: ChainPointTime
chainPointTimeState = NodeState tx -> ChainPointTime
forall tx. NodeState tx -> ChainPointTime
chainPointTime NodeState tx
nodeState
       in case StateChanged tx
sc of
            HeadOpened{ChainStateType tx
$sel:chainState:NetworkConnected :: forall tx. StateChanged tx -> ChainStateType tx
chainState :: ChainStateType tx
chainState} ->
              NodeState tx
nodeState
                { headState = st
                , chainPointTime = chainPointTimeState{currentSlot = chainStateSlot chainState}
                }
            DepositRecorded{HeadId
$sel:headId:NetworkConnected :: forall tx. StateChanged tx -> HeadId
headId :: HeadId
headId, TxIdType tx
$sel:depositTxId:NetworkConnected :: forall tx. StateChanged tx -> TxIdType tx
depositTxId :: TxIdType tx
depositTxId, UTxOType tx
$sel:deposited:NetworkConnected :: forall tx. StateChanged tx -> UTxOType tx
deposited :: UTxOType tx
deposited, UTCTime
created :: forall tx. StateChanged tx -> UTCTime
created :: UTCTime
created, UTCTime
$sel:deadline:NetworkConnected :: forall tx. StateChanged tx -> UTCTime
deadline :: UTCTime
deadline} ->
              NodeState tx
nodeState
                { headState = st
                , pendingDeposits = Map.insert depositTxId Deposit{headId, deposited, created, deadline, status = Inactive} currentPendingDeposits
                }
            DepositActivated{TxIdType tx
$sel:depositTxId:NetworkConnected :: forall tx. StateChanged tx -> TxIdType tx
depositTxId :: TxIdType tx
depositTxId, Deposit tx
$sel:deposit:NetworkConnected :: forall tx. StateChanged tx -> Deposit tx
deposit :: Deposit tx
deposit} ->
              NodeState tx
nodeState
                { headState = st
                , pendingDeposits = Map.insert depositTxId deposit currentPendingDeposits
                }
            DepositExpired{TxIdType tx
$sel:depositTxId:NetworkConnected :: forall tx. StateChanged tx -> TxIdType tx
depositTxId :: TxIdType tx
depositTxId, Deposit tx
$sel:deposit:NetworkConnected :: forall tx. StateChanged tx -> Deposit tx
deposit :: Deposit tx
deposit} ->
              NodeState tx
nodeState
                { headState = st
                , -- NB: We keep expired deposits in a map since we actually need it when Recovering.
                  -- There is a corresponding error RequestedDepositExpired which gives users context on stale ReqSn.
                  pendingDeposits = Map.insert depositTxId deposit currentPendingDeposits
                }
            DepositRecovered{TxIdType tx
$sel:depositTxId:NetworkConnected :: forall tx. StateChanged tx -> TxIdType tx
depositTxId :: TxIdType tx
depositTxId} ->
              case HeadState tx
st of
                Open os :: OpenState tx
os@OpenState{CoordinatedHeadState tx
$sel:coordinatedHeadState:OpenState :: forall tx. OpenState tx -> CoordinatedHeadState tx
coordinatedHeadState :: CoordinatedHeadState tx
coordinatedHeadState} ->
                  NodeState tx
nodeState
                    { headState =
                        Open
                          os
                            { coordinatedHeadState =
                                coordinatedHeadState
                                  { currentDepositTxId =
                                      if coordinatedHeadState.currentDepositTxId == Just depositTxId
                                        then Nothing
                                        else coordinatedHeadState.currentDepositTxId
                                  }
                            }
                    , pendingDeposits = Map.delete depositTxId currentPendingDeposits
                    }
                HeadState tx
_ ->
                  NodeState tx
nodeState
                    { headState = st
                    , pendingDeposits = Map.delete depositTxId currentPendingDeposits
                    }
            CommitFinalized{ChainStateType tx
$sel:chainState:NetworkConnected :: forall tx. StateChanged tx -> ChainStateType tx
chainState :: ChainStateType tx
chainState, SnapshotVersion
$sel:newVersion:NetworkConnected :: forall tx. StateChanged tx -> SnapshotVersion
newVersion :: SnapshotVersion
newVersion, TxIdType tx
$sel:depositTxId:NetworkConnected :: forall tx. StateChanged tx -> TxIdType tx
depositTxId :: TxIdType tx
depositTxId} ->
              case HeadState tx
st of
                Open os :: OpenState tx
os@OpenState{CoordinatedHeadState tx
$sel:coordinatedHeadState:OpenState :: forall tx. OpenState tx -> CoordinatedHeadState tx
coordinatedHeadState :: CoordinatedHeadState tx
coordinatedHeadState} ->
                  let deposit :: Maybe (Deposit tx)
deposit = TxIdType tx -> PendingDeposits tx -> Maybe (Deposit tx)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TxIdType tx
depositTxId PendingDeposits tx
currentPendingDeposits
                      newUTxO :: UTxOType tx
newUTxO = UTxOType tx
-> (Deposit tx -> UTxOType tx) -> Maybe (Deposit tx) -> UTxOType tx
forall b a. b -> (a -> b) -> Maybe a -> b
maybe UTxOType tx
forall a. Monoid a => a
mempty (\Deposit{UTxOType tx
$sel:deposited:Deposit :: forall tx. Deposit tx -> UTxOType tx
deposited :: UTxOType tx
deposited} -> UTxOType tx
deposited) Maybe (Deposit tx)
deposit
                   in NodeState tx
nodeState
                        { headState =
                            Open
                              os
                                { chainState
                                , coordinatedHeadState =
                                    coordinatedHeadState
                                      { version = newVersion
                                      , -- NOTE: This must correspond to the just finalized
                                        -- depositTxId, but we should not verify this here.
                                        currentDepositTxId = Nothing
                                      , localUTxO = localUTxO <> newUTxO
                                      , -- If a snapshot is already in SeenSnapshot, all parties
                                        -- have processed the ReqSn and sent AckSns — preserve it
                                        -- so that snapshot can still complete and chain the next
                                        -- one with the bumped version. Only reset when nothing
                                        -- is in-flight.
                                        seenSnapshot = case seenSnapshot of
                                          SeenSnapshot{} -> SeenSnapshot tx
seenSnapshot
                                          SeenSnapshot tx
_ -> LastSeenSnapshot{$sel:lastSeen:NoSeenSnapshot :: SnapshotNumber
lastSeen = SnapshotNumber
confirmedSn}
                                      }
                                }
                        , pendingDeposits = Map.delete depositTxId currentPendingDeposits
                        }
                 where
                  CoordinatedHeadState{UTxOType tx
$sel:localUTxO:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> UTxOType tx
localUTxO :: UTxOType tx
localUTxO, ConfirmedSnapshot tx
$sel:confirmedSnapshot:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> ConfirmedSnapshot tx
confirmedSnapshot :: ConfirmedSnapshot tx
confirmedSnapshot, SeenSnapshot tx
$sel:seenSnapshot:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> SeenSnapshot tx
seenSnapshot :: SeenSnapshot tx
seenSnapshot} = CoordinatedHeadState tx
coordinatedHeadState
                  Snapshot{$sel:number:Snapshot :: forall tx. Snapshot tx -> SnapshotNumber
number = SnapshotNumber
confirmedSn} = ConfirmedSnapshot tx -> Snapshot tx
forall tx. IsTx tx => ConfirmedSnapshot tx -> Snapshot tx
getSnapshot ConfirmedSnapshot tx
confirmedSnapshot
                HeadState tx
_ ->
                  NodeState tx
nodeState
                    { headState = st
                    , pendingDeposits = Map.delete depositTxId currentPendingDeposits
                    }
            TickObserved{ChainPointType tx
$sel:chainPoint:NetworkConnected :: forall tx. StateChanged tx -> ChainPointType tx
chainPoint :: ChainPointType tx
chainPoint, UTCTime
$sel:chainTime:NetworkConnected :: forall tx. StateChanged tx -> UTCTime
chainTime :: UTCTime
chainTime} ->
              NodeState tx
nodeState{headState = st, chainPointTime = chainPointTimeState{currentSlot = chainPointSlot chainPoint, currentChainTime = chainTime}}
            ChainRolledBack{ChainStateType tx
$sel:chainState:NetworkConnected :: forall tx. StateChanged tx -> ChainStateType tx
chainState :: ChainStateType tx
chainState} ->
              NodeState tx
nodeState{headState = st, chainPointTime = chainPointTimeState{currentSlot = chainStateSlot chainState}}
            NodeUnsynced{ChainSlot
$sel:chainSlot:NetworkConnected :: forall tx. StateChanged tx -> ChainSlot
chainSlot :: ChainSlot
chainSlot, UTCTime
$sel:chainTime:NetworkConnected :: forall tx. StateChanged tx -> UTCTime
chainTime :: UTCTime
chainTime, NominalDiffTime
$sel:drift:NetworkConnected :: forall tx. StateChanged tx -> NominalDiffTime
drift :: NominalDiffTime
drift} ->
              NodeCatchingUp{$sel:headState:NodeInSync :: HeadState tx
headState = HeadState tx
st, pendingDeposits :: PendingDeposits tx
pendingDeposits = PendingDeposits tx
currentPendingDeposits, $sel:chainPointTime:NodeInSync :: ChainPointTime
chainPointTime = ChainSlot -> UTCTime -> NominalDiffTime -> ChainPointTime
ChainPointTime ChainSlot
chainSlot UTCTime
chainTime NominalDiffTime
drift}
            NodeSynced{ChainSlot
$sel:chainSlot:NetworkConnected :: forall tx. StateChanged tx -> ChainSlot
chainSlot :: ChainSlot
chainSlot, UTCTime
$sel:chainTime:NetworkConnected :: forall tx. StateChanged tx -> UTCTime
chainTime :: UTCTime
chainTime, NominalDiffTime
$sel:drift:NetworkConnected :: forall tx. StateChanged tx -> NominalDiffTime
drift :: NominalDiffTime
drift} ->
              NodeInSync{$sel:headState:NodeInSync :: HeadState tx
headState = HeadState tx
st, pendingDeposits :: PendingDeposits tx
pendingDeposits = PendingDeposits tx
currentPendingDeposits, $sel:chainPointTime:NodeInSync :: ChainPointTime
chainPointTime = ChainSlot -> UTCTime -> NominalDiffTime -> ChainPointTime
ChainPointTime ChainSlot
chainSlot UTCTime
chainTime NominalDiffTime
drift}
            -- Restore the full snapshot: a checkpoint carries the aggregated
            -- 'pendingDeposits' and 'chainPointTime' (and synced constructor),
            -- which the default arm below would otherwise drop on replay.
            Checkpoint NodeState tx
checkpointedNodeState ->
              NodeState tx
checkpointedNodeState
            StateChanged tx
_ ->
              NodeState tx
nodeState{headState = st}

-- * HeadState aggregate helpers

-- | Extract the 'HeadId' from a 'StateChanged' event, if the event carries one.
-- Events that do not carry a 'HeadId' always pass through 'aggregateNodeState' unchanged.
eventHeadId :: StateChanged tx -> Maybe HeadId
eventHeadId :: forall tx. StateChanged tx -> Maybe HeadId
eventHeadId = \case
  HeadOpened{HeadId
$sel:headId:NetworkConnected :: forall tx. StateChanged tx -> HeadId
headId :: HeadId
headId} -> HeadId -> Maybe HeadId
forall a. a -> Maybe a
Just HeadId
headId
  TransactionAppliedToLocalUTxO{HeadId
$sel:headId:NetworkConnected :: forall tx. StateChanged tx -> HeadId
headId :: HeadId
headId} -> HeadId -> Maybe HeadId
forall a. a -> Maybe a
Just HeadId
headId
  SnapshotConfirmed{HeadId
$sel:headId:NetworkConnected :: forall tx. StateChanged tx -> HeadId
headId :: HeadId
headId} -> HeadId -> Maybe HeadId
forall a. a -> Maybe a
Just HeadId
headId
  LocalStateCleared{HeadId
$sel:headId:NetworkConnected :: forall tx. StateChanged tx -> HeadId
headId :: HeadId
headId} -> HeadId -> Maybe HeadId
forall a. a -> Maybe a
Just HeadId
headId
  DepositRecorded{HeadId
$sel:headId:NetworkConnected :: forall tx. StateChanged tx -> HeadId
headId :: HeadId
headId} -> HeadId -> Maybe HeadId
forall a. a -> Maybe a
Just HeadId
headId
  DepositRecovered{} -> Maybe HeadId
forall a. Maybe a
Nothing
  CommitApproved{HeadId
$sel:headId:NetworkConnected :: forall tx. StateChanged tx -> HeadId
headId :: HeadId
headId} -> HeadId -> Maybe HeadId
forall a. a -> Maybe a
Just HeadId
headId
  CommitFinalized{HeadId
$sel:headId:NetworkConnected :: forall tx. StateChanged tx -> HeadId
headId :: HeadId
headId} -> HeadId -> Maybe HeadId
forall a. a -> Maybe a
Just HeadId
headId
  DecommitRecorded{HeadId
$sel:headId:NetworkConnected :: forall tx. StateChanged tx -> HeadId
headId :: HeadId
headId} -> HeadId -> Maybe HeadId
forall a. a -> Maybe a
Just HeadId
headId
  DecommitApproved{HeadId
$sel:headId:NetworkConnected :: forall tx. StateChanged tx -> HeadId
headId :: HeadId
headId} -> HeadId -> Maybe HeadId
forall a. a -> Maybe a
Just HeadId
headId
  DecommitInvalid{HeadId
$sel:headId:NetworkConnected :: forall tx. StateChanged tx -> HeadId
headId :: HeadId
headId} -> HeadId -> Maybe HeadId
forall a. a -> Maybe a
Just HeadId
headId
  DecommitFinalized{HeadId
$sel:headId:NetworkConnected :: forall tx. StateChanged tx -> HeadId
headId :: HeadId
headId} -> HeadId -> Maybe HeadId
forall a. a -> Maybe a
Just HeadId
headId
  HeadIsReadyToFanout{HeadId
$sel:headId:NetworkConnected :: forall tx. StateChanged tx -> HeadId
headId :: HeadId
headId} -> HeadId -> Maybe HeadId
forall a. a -> Maybe a
Just HeadId
headId
  HeadClosed{HeadId
$sel:headId:NetworkConnected :: forall tx. StateChanged tx -> HeadId
headId :: HeadId
headId} -> HeadId -> Maybe HeadId
forall a. a -> Maybe a
Just HeadId
headId
  HeadContested{HeadId
$sel:headId:NetworkConnected :: forall tx. StateChanged tx -> HeadId
headId :: HeadId
headId} -> HeadId -> Maybe HeadId
forall a. a -> Maybe a
Just HeadId
headId
  HeadFannedOut{HeadId
$sel:headId:NetworkConnected :: forall tx. StateChanged tx -> HeadId
headId :: HeadId
headId} -> HeadId -> Maybe HeadId
forall a. a -> Maybe a
Just HeadId
headId
  TxInvalid{HeadId
$sel:headId:NetworkConnected :: forall tx. StateChanged tx -> HeadId
headId :: HeadId
headId} -> HeadId -> Maybe HeadId
forall a. a -> Maybe a
Just HeadId
headId
  HeadPartialFannedOut{HeadId
$sel:headId:NetworkConnected :: forall tx. StateChanged tx -> HeadId
headId :: HeadId
headId} -> HeadId -> Maybe HeadId
forall a. a -> Maybe a
Just HeadId
headId
  HeadFanoutInitiated{HeadId
$sel:headId:NetworkConnected :: forall tx. StateChanged tx -> HeadId
headId :: HeadId
headId} -> HeadId -> Maybe HeadId
forall a. a -> Maybe a
Just HeadId
headId
  HeadPartialFanoutSelected{HeadId
$sel:headId:NetworkConnected :: forall tx. StateChanged tx -> HeadId
headId :: HeadId
headId} -> HeadId -> Maybe HeadId
forall a. a -> Maybe a
Just HeadId
headId
  HeadFanoutReverted{HeadId
$sel:headId:NetworkConnected :: forall tx. StateChanged tx -> HeadId
headId :: HeadId
headId} -> HeadId -> Maybe HeadId
forall a. a -> Maybe a
Just HeadId
headId
  -- The headId in IgnoredHeadInitializing is the OTHER head's id (not ours),
  -- so it must not be used to filter against the current head state.
  IgnoredHeadInitializing{} -> Maybe HeadId
forall a. Maybe a
Nothing
  TransactionReceived{} -> Maybe HeadId
forall a. Maybe a
Nothing
  SnapshotRequestDecided{} -> Maybe HeadId
forall a. Maybe a
Nothing
  SnapshotRequested{} -> Maybe HeadId
forall a. Maybe a
Nothing
  PartySignedSnapshot{} -> Maybe HeadId
forall a. Maybe a
Nothing
  DepositActivated{} -> Maybe HeadId
forall a. Maybe a
Nothing
  DepositExpired{} -> Maybe HeadId
forall a. Maybe a
Nothing
  ChainRolledBack{} -> Maybe HeadId
forall a. Maybe a
Nothing
  TickObserved{} -> Maybe HeadId
forall a. Maybe a
Nothing
  StateChanged tx
NetworkDisconnected -> Maybe HeadId
forall a. Maybe a
Nothing
  StateChanged tx
NetworkConnected -> Maybe HeadId
forall a. Maybe a
Nothing
  PeerConnected{} -> Maybe HeadId
forall a. Maybe a
Nothing
  PeerDisconnected{} -> Maybe HeadId
forall a. Maybe a
Nothing
  NetworkVersionMismatch{} -> Maybe HeadId
forall a. Maybe a
Nothing
  NetworkClusterIDMismatch{} -> Maybe HeadId
forall a. Maybe a
Nothing
  Checkpoint{} -> Maybe HeadId
forall a. Maybe a
Nothing
  NodeUnsynced{} -> Maybe HeadId
forall a. Maybe a
Nothing
  NodeSynced{} -> Maybe HeadId
forall a. Maybe a
Nothing

-- | Extract the 'HeadId' from the current 'HeadState', if any.
headIdOf :: HeadState tx -> Maybe HeadId
headIdOf :: forall tx. HeadState tx -> Maybe HeadId
headIdOf = \case
  Idle IdleState tx
_ -> Maybe HeadId
forall a. Maybe a
Nothing
  Open OpenState{HeadId
$sel:headId:OpenState :: forall tx. OpenState tx -> HeadId
headId :: HeadId
headId} -> HeadId -> Maybe HeadId
forall a. a -> Maybe a
Just HeadId
headId
  Closed ClosedState{HeadId
$sel:headId:ClosedState :: forall tx. ClosedState tx -> HeadId
headId :: HeadId
headId} -> HeadId -> Maybe HeadId
forall a. a -> Maybe a
Just HeadId
headId
  FanoutProgress PartialFanoutState{HeadId
$sel:headId:PartialFanoutState :: forall tx. PartialFanoutState tx -> HeadId
headId :: HeadId
headId} -> HeadId -> Maybe HeadId
forall a. a -> Maybe a
Just HeadId
headId

applyEvent :: IsChainState tx => HeadState tx -> StateChanged tx -> HeadState tx
applyEvent :: forall tx.
IsChainState tx =>
HeadState tx -> StateChanged tx -> HeadState tx
applyEvent HeadState tx
st = \case
  StateChanged tx
NetworkConnected -> HeadState tx
st
  StateChanged tx
NetworkDisconnected -> HeadState tx
st
  NetworkVersionMismatch{} -> HeadState tx
st
  NetworkClusterIDMismatch{} -> HeadState tx
st
  PeerConnected{} -> HeadState tx
st
  PeerDisconnected{} -> HeadState tx
st
  HeadOpened{HeadSeed
$sel:headSeed:NetworkConnected :: forall tx. StateChanged tx -> HeadSeed
headSeed :: HeadSeed
headSeed, HeadId
$sel:headId:NetworkConnected :: forall tx. StateChanged tx -> HeadId
headId :: HeadId
headId, HeadParameters
$sel:parameters:NetworkConnected :: forall tx. StateChanged tx -> HeadParameters
parameters :: HeadParameters
parameters, ChainStateType tx
$sel:chainState:NetworkConnected :: forall tx. StateChanged tx -> ChainStateType tx
chainState :: ChainStateType tx
chainState} ->
    OpenState tx -> HeadState tx
forall tx. OpenState tx -> HeadState tx
Open
      OpenState
        { HeadId
$sel:headId:OpenState :: HeadId
headId :: HeadId
headId
        , HeadSeed
$sel:headSeed:OpenState :: HeadSeed
headSeed :: HeadSeed
headSeed
        , HeadParameters
$sel:parameters:OpenState :: HeadParameters
parameters :: HeadParameters
parameters
        , $sel:coordinatedHeadState:OpenState :: CoordinatedHeadState tx
coordinatedHeadState =
            CoordinatedHeadState
              { $sel:localUTxO:CoordinatedHeadState :: UTxOType tx
localUTxO = UTxOType tx
forall a. Monoid a => a
mempty
              , $sel:allTxs:CoordinatedHeadState :: Map (TxIdType tx) tx
allTxs = Map (TxIdType tx) tx
forall a. Monoid a => a
mempty
              , $sel:localTxs:CoordinatedHeadState :: Seq tx
localTxs = Seq tx
forall a. Monoid a => a
mempty
              , $sel:confirmedSnapshot:CoordinatedHeadState :: ConfirmedSnapshot tx
confirmedSnapshot = InitialSnapshot{HeadId
headId :: HeadId
$sel:headId:InitialSnapshot :: HeadId
headId}
              , $sel:seenSnapshot:CoordinatedHeadState :: SeenSnapshot tx
seenSnapshot = SeenSnapshot tx
forall tx. SeenSnapshot tx
NoSeenSnapshot
              , $sel:currentDepositTxId:CoordinatedHeadState :: Maybe (TxIdType tx)
currentDepositTxId = Maybe (TxIdType tx)
forall a. Maybe a
Nothing
              , $sel:decommitTx:CoordinatedHeadState :: Maybe tx
decommitTx = Maybe tx
forall a. Maybe a
Nothing
              , $sel:version:CoordinatedHeadState :: SnapshotVersion
version = SnapshotVersion
0
              }
        , ChainStateType tx
chainState :: ChainStateType tx
$sel:chainState:OpenState :: ChainStateType tx
chainState
        }
  TransactionReceived{tx
$sel:tx:NetworkConnected :: forall tx. StateChanged tx -> tx
tx :: tx
tx} ->
    case HeadState tx
st of
      Open os :: OpenState tx
os@OpenState{CoordinatedHeadState tx
$sel:coordinatedHeadState:OpenState :: forall tx. OpenState tx -> CoordinatedHeadState tx
coordinatedHeadState :: CoordinatedHeadState tx
coordinatedHeadState} ->
        OpenState tx -> HeadState tx
forall tx. OpenState tx -> HeadState tx
Open
          OpenState tx
os
            { coordinatedHeadState =
                coordinatedHeadState
                  { allTxs = Map.insert (txId tx) tx allTxs
                  }
            }
       where
        CoordinatedHeadState{Map (TxIdType tx) tx
$sel:allTxs:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> Map (TxIdType tx) tx
allTxs :: Map (TxIdType tx) tx
allTxs} = CoordinatedHeadState tx
coordinatedHeadState
      HeadState tx
_otherState -> HeadState tx
st
  TransactionAppliedToLocalUTxO{tx
$sel:tx:NetworkConnected :: forall tx. StateChanged tx -> tx
tx :: tx
tx} ->
    case HeadState tx
st of
      Open os :: OpenState tx
os@OpenState{CoordinatedHeadState tx
$sel:coordinatedHeadState:OpenState :: forall tx. OpenState tx -> CoordinatedHeadState tx
coordinatedHeadState :: CoordinatedHeadState tx
coordinatedHeadState} ->
        OpenState tx -> HeadState tx
forall tx. OpenState tx -> HeadState tx
Open
          OpenState tx
os
            { coordinatedHeadState =
                coordinatedHeadState
                  { localUTxO =
                      -- NOTE: Safe to use localUTxO here because the tx was
                      -- ledger-validated before this event was emitted.
                      -- 'aggregate' folds events in order, so 'localUTxO'
                      -- here always reflects all previously applied transactions.
                      applyTxTo tx localUTxO
                  , -- NOTE: Order of transactions is important here. See also
                    -- 'pruneTransactions'.
                    localTxs = localTxs Seq.|> tx
                  }
            }
       where
        CoordinatedHeadState{UTxOType tx
$sel:localUTxO:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> UTxOType tx
localUTxO :: UTxOType tx
localUTxO, Seq tx
$sel:localTxs:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> Seq tx
localTxs :: Seq tx
localTxs} = CoordinatedHeadState tx
coordinatedHeadState
      HeadState tx
_otherState -> HeadState tx
st
  SnapshotRequestDecided{SnapshotNumber
$sel:snapshotNumber:NetworkConnected :: forall tx. StateChanged tx -> SnapshotNumber
snapshotNumber :: SnapshotNumber
snapshotNumber} ->
    case HeadState tx
st of
      Open os :: OpenState tx
os@OpenState{CoordinatedHeadState tx
$sel:coordinatedHeadState:OpenState :: forall tx. OpenState tx -> CoordinatedHeadState tx
coordinatedHeadState :: CoordinatedHeadState tx
coordinatedHeadState} ->
        OpenState tx -> HeadState tx
forall tx. OpenState tx -> HeadState tx
Open
          OpenState tx
os
            { coordinatedHeadState =
                coordinatedHeadState
                  { seenSnapshot =
                      RequestedSnapshot
                        { lastSeen = seenSnapshotNumber seenSnapshot
                        , requested = snapshotNumber
                        }
                  }
            }
       where
        CoordinatedHeadState{SeenSnapshot tx
$sel:seenSnapshot:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> SeenSnapshot tx
seenSnapshot :: SeenSnapshot tx
seenSnapshot} = CoordinatedHeadState tx
coordinatedHeadState
      HeadState tx
_otherState -> HeadState tx
st
  SnapshotRequested{$sel:requestedSnapshot:NetworkConnected :: forall tx. StateChanged tx -> Snapshot tx
requestedSnapshot = Snapshot tx
snapshot, Seq tx
$sel:newLocalTxs:NetworkConnected :: forall tx. StateChanged tx -> Seq tx
newLocalTxs :: Seq tx
newLocalTxs, Maybe (TxIdType tx)
$sel:newCurrentDepositTxId:NetworkConnected :: forall tx. StateChanged tx -> Maybe (TxIdType tx)
newCurrentDepositTxId :: Maybe (TxIdType tx)
newCurrentDepositTxId} ->
    case HeadState tx
st of
      Open os :: OpenState tx
os@OpenState{CoordinatedHeadState tx
$sel:coordinatedHeadState:OpenState :: forall tx. OpenState tx -> CoordinatedHeadState tx
coordinatedHeadState :: CoordinatedHeadState tx
coordinatedHeadState} ->
        OpenState tx -> HeadState tx
forall tx. OpenState tx -> HeadState tx
Open
          OpenState tx
os
            { coordinatedHeadState =
                coordinatedHeadState
                  { seenSnapshot = mkSeenSnapshot snapshot mempty
                  , localTxs = newLocalTxs
                  , -- NOTE: pure UTxO arithmetic. 'newLocalTxs' was pre-pruned
                    -- by 'pruneTransactions' in 'onOpenNetworkReqSn' (so each tx
                    -- is guaranteed to apply), making 'applyTxTo' safe to use
                    -- without ledger validation.
                    --
                    -- A pending commit ('utxoToCommit') is only spendable once its
                    -- on-chain increment has landed (chain 'version' ahead of the
                    -- snapshot's). Before then it must NOT be part of the spendable
                    -- localUTxO, otherwise the same deposit UTxO could be spent once
                    -- per snapshot round (it is re-injected here) and inflate the L2
                    -- balance. Mirrors 'confirmedUTxO'; the deposit enters localUTxO
                    -- at 'CommitFinalized'.
                    localUTxO =
                      let activeUTxO =
                            if SnapshotVersion
version SnapshotVersion -> SnapshotVersion -> Bool
forall a. Ord a => a -> a -> Bool
> Snapshot tx
snapshot.version
                              then Snapshot tx
snapshot.utxo 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
snapshot.utxoToCommit
                              else Snapshot tx
snapshot.utxo
                       in foldl' (flip applyTxTo) activeUTxO newLocalTxs
                  , allTxs = foldr (Map.delete . txId) allTxs snapshot.confirmed
                  , currentDepositTxId = newCurrentDepositTxId
                  }
            }
       where
        CoordinatedHeadState{Map (TxIdType tx) tx
$sel:allTxs:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> Map (TxIdType tx) tx
allTxs :: Map (TxIdType tx) tx
allTxs, SnapshotVersion
$sel:version:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> SnapshotVersion
version :: SnapshotVersion
version} = CoordinatedHeadState tx
coordinatedHeadState
      HeadState tx
_otherState -> HeadState tx
st
  PartySignedSnapshot{Party
$sel:party:NetworkConnected :: forall tx. StateChanged tx -> Party
party :: Party
party, Signature (Snapshot tx)
$sel:signature:NetworkConnected :: forall tx. StateChanged tx -> Signature (Snapshot tx)
signature :: Signature (Snapshot tx)
signature} ->
    case HeadState tx
st of
      Open
        os :: OpenState tx
os@OpenState
          { $sel:coordinatedHeadState:OpenState :: forall tx. OpenState tx -> CoordinatedHeadState tx
coordinatedHeadState =
            chs :: CoordinatedHeadState tx
chs@CoordinatedHeadState
              { $sel:seenSnapshot:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> SeenSnapshot tx
seenSnapshot = ss :: SeenSnapshot tx
ss@SeenSnapshot{Map Party (Signature (Snapshot tx))
$sel:signatories:NoSeenSnapshot :: forall tx. SeenSnapshot tx -> Map Party (Signature (Snapshot tx))
signatories :: Map Party (Signature (Snapshot tx))
signatories}
              }
          } ->
          OpenState tx -> HeadState tx
forall tx. OpenState tx -> HeadState tx
Open
            OpenState tx
os
              { coordinatedHeadState =
                  chs
                    { seenSnapshot =
                        ss
                          { signatories = Map.insert party signature signatories
                          }
                    }
              }
      HeadState tx
_otherState -> HeadState tx
st
  SnapshotConfirmed{$sel:snapshot:NetworkConnected :: forall tx. StateChanged tx -> Maybe (Snapshot tx)
snapshot = Maybe (Snapshot tx)
mSnapshot, MultiSignature (Snapshot tx)
$sel:signatures:NetworkConnected :: forall tx. StateChanged tx -> MultiSignature (Snapshot tx)
signatures :: MultiSignature (Snapshot tx)
signatures} ->
    case HeadState tx
st of
      Open os :: OpenState tx
os@OpenState{$sel:coordinatedHeadState:OpenState :: forall tx. OpenState tx -> CoordinatedHeadState tx
coordinatedHeadState = chs :: CoordinatedHeadState tx
chs@CoordinatedHeadState{SeenSnapshot tx
$sel:seenSnapshot:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> SeenSnapshot tx
seenSnapshot :: SeenSnapshot tx
seenSnapshot}} ->
        case Maybe (Snapshot tx)
mSnapshot Maybe (Snapshot tx) -> Maybe (Snapshot tx) -> Maybe (Snapshot tx)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> SeenSnapshot tx -> Maybe (Snapshot tx)
forall tx. SeenSnapshot tx -> Maybe (Snapshot tx)
snapshotFromSeen SeenSnapshot tx
seenSnapshot of
          Just Snapshot tx
snapshot ->
            OpenState tx -> HeadState tx
forall tx. OpenState tx -> HeadState tx
Open
              OpenState tx
os
                { coordinatedHeadState =
                    chs
                      { confirmedSnapshot = ConfirmedSnapshot{snapshot, signatures}
                      , seenSnapshot = LastSeenSnapshot snapshot.number
                      }
                }
          Maybe (Snapshot tx)
Nothing -> Text -> HeadState tx
forall a t. (HasCallStack, IsText t) => t -> a
Hydra.Prelude.error Text
"applyEvent: SnapshotConfirmed but no snapshot in event or seenSnapshot"
      HeadState tx
_otherState -> HeadState tx
st
   where
    snapshotFromSeen :: SeenSnapshot tx -> Maybe (Snapshot tx)
    snapshotFromSeen :: forall tx. SeenSnapshot tx -> Maybe (Snapshot tx)
snapshotFromSeen (SeenSnapshot Snapshot tx
sn Map Party (Signature (Snapshot tx))
_ ByteString
_) = Snapshot tx -> Maybe (Snapshot tx)
forall a. a -> Maybe a
Just Snapshot tx
sn
    snapshotFromSeen SeenSnapshot tx
_ = Maybe (Snapshot tx)
forall a. Maybe a
Nothing
  LocalStateCleared{SnapshotNumber
$sel:snapshotNumber:NetworkConnected :: forall tx. StateChanged tx -> SnapshotNumber
snapshotNumber :: SnapshotNumber
snapshotNumber} ->
    case HeadState tx
st of
      Open os :: OpenState tx
os@OpenState{$sel:coordinatedHeadState:OpenState :: forall tx. OpenState tx -> CoordinatedHeadState tx
coordinatedHeadState = coordinatedHeadState :: CoordinatedHeadState tx
coordinatedHeadState@CoordinatedHeadState{ConfirmedSnapshot tx
$sel:confirmedSnapshot:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> ConfirmedSnapshot tx
confirmedSnapshot :: ConfirmedSnapshot tx
confirmedSnapshot, $sel:version:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> SnapshotVersion
version = SnapshotVersion
currentVersion}} ->
        OpenState tx -> HeadState tx
forall tx. OpenState tx -> HeadState tx
Open
          OpenState tx
os
            { coordinatedHeadState =
                case confirmedSnapshot of
                  InitialSnapshot{} ->
                    CoordinatedHeadState tx
coordinatedHeadState
                      { localUTxO = mempty
                      , localTxs = mempty
                      , allTxs = mempty
                      , seenSnapshot = NoSeenSnapshot
                      }
                  ConfirmedSnapshot{$sel:snapshot:InitialSnapshot :: forall tx. ConfirmedSnapshot tx -> Snapshot tx
snapshot = Snapshot{UTxOType tx
$sel:utxo:Snapshot :: forall tx. Snapshot tx -> UTxOType tx
utxo :: UTxOType tx
utxo, Maybe (UTxOType tx)
$sel:utxoToCommit:Snapshot :: forall tx. Snapshot tx -> Maybe (UTxOType tx)
utxoToCommit :: Maybe (UTxOType tx)
utxoToCommit, $sel:version:Snapshot :: forall tx. Snapshot tx -> SnapshotVersion
version = SnapshotVersion
snapshotVersion}} ->
                    CoordinatedHeadState tx
coordinatedHeadState
                      { -- NOTE: Include utxoToCommit in localUTxO when the corresponding
                        -- increment has been finalized on-chain (i.e. the chain-observed
                        -- version has advanced past the snapshot's version). Without this,
                        -- a side-loaded deposit snapshot would leave the head unable to
                        -- spend the deposited UTxO.
                        localUTxO =
                          if currentVersion > snapshotVersion
                            then utxo <> fromMaybe mempty utxoToCommit
                            else utxo
                      , localTxs = mempty
                      , allTxs = mempty
                      , seenSnapshot = LastSeenSnapshot snapshotNumber
                      , decommitTx = Nothing
                      , currentDepositTxId = Nothing
                      }
            }
      HeadState tx
_otherState -> HeadState tx
st
  DepositRecorded{} -> HeadState tx
st
  DepositActivated{TxIdType tx
$sel:depositTxId:NetworkConnected :: forall tx. StateChanged tx -> TxIdType tx
depositTxId :: TxIdType tx
depositTxId, Deposit tx
$sel:deposit:NetworkConnected :: forall tx. StateChanged tx -> Deposit tx
deposit :: Deposit tx
deposit} -> case HeadState tx
st of
    Open os :: OpenState tx
os@OpenState{$sel:headId:OpenState :: forall tx. OpenState tx -> HeadId
headId = HeadId
ourHeadId, $sel:coordinatedHeadState:OpenState :: forall tx. OpenState tx -> CoordinatedHeadState tx
coordinatedHeadState = CoordinatedHeadState tx
chs}
      | Deposit tx
deposit.headId HeadId -> HeadId -> Bool
forall a. Eq a => a -> a -> Bool
== HeadId
ourHeadId ->
          -- Spec: txω = ⊥ ∨ txα = ⊥ — deposit and decommit are mutually exclusive.
          -- Only queue the deposit when no decommit is pending; otherwise the tick
          -- will pick it up once the decommit completes.
          case CoordinatedHeadState tx
chs.decommitTx of
            Just tx
_ -> HeadState tx
st
            Maybe tx
Nothing -> OpenState tx -> HeadState tx
forall tx. OpenState tx -> HeadState tx
Open OpenState tx
os{coordinatedHeadState = chs{currentDepositTxId = chs.currentDepositTxId <|> Just depositTxId}}
    HeadState tx
_ -> HeadState tx
st
  DepositExpired{} -> HeadState tx
st
  CommitApproved{} -> HeadState tx
st
  DepositRecovered{} -> HeadState tx
st
  CommitFinalized{} -> HeadState tx
st
  DecommitRecorded{tx
$sel:decommitTx:NetworkConnected :: forall tx. StateChanged tx -> tx
decommitTx :: tx
decommitTx} -> case HeadState tx
st of
    Open
      os :: OpenState tx
os@OpenState{CoordinatedHeadState tx
$sel:coordinatedHeadState:OpenState :: forall tx. OpenState tx -> CoordinatedHeadState tx
coordinatedHeadState :: CoordinatedHeadState tx
coordinatedHeadState} ->
        OpenState tx -> HeadState tx
forall tx. OpenState tx -> HeadState tx
Open
          OpenState tx
os
            { coordinatedHeadState =
                coordinatedHeadState
                  { -- Apply the decommit to localUTxO and remove its outputs:
                    -- decommit's outputs leave the head, so net effect is
                    -- removing the spent inputs from localUTxO.
                    localUTxO = applyTxTo decommitTx localUTxO `withoutUTxO` utxoFromTx decommitTx
                  , decommitTx = Just decommitTx
                  }
            }
       where
        CoordinatedHeadState{UTxOType tx
$sel:localUTxO:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> UTxOType tx
localUTxO :: UTxOType tx
localUTxO} = CoordinatedHeadState tx
coordinatedHeadState
    HeadState tx
_otherState -> HeadState tx
st
  DecommitApproved{} -> HeadState tx
st
  DecommitInvalid{} -> HeadState tx
st
  DecommitFinalized{ChainStateType tx
$sel:chainState:NetworkConnected :: forall tx. StateChanged tx -> ChainStateType tx
chainState :: ChainStateType tx
chainState, SnapshotVersion
$sel:newVersion:NetworkConnected :: forall tx. StateChanged tx -> SnapshotVersion
newVersion :: SnapshotVersion
newVersion} ->
    case HeadState tx
st of
      Open
        os :: OpenState tx
os@OpenState{$sel:coordinatedHeadState:OpenState :: forall tx. OpenState tx -> CoordinatedHeadState tx
coordinatedHeadState = coordinatedHeadState :: CoordinatedHeadState tx
coordinatedHeadState@CoordinatedHeadState{ConfirmedSnapshot tx
$sel:confirmedSnapshot:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> ConfirmedSnapshot tx
confirmedSnapshot :: ConfirmedSnapshot tx
confirmedSnapshot, SeenSnapshot tx
$sel:seenSnapshot:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> SeenSnapshot tx
seenSnapshot :: SeenSnapshot tx
seenSnapshot}} ->
          let Snapshot{$sel:number:Snapshot :: forall tx. Snapshot tx -> SnapshotNumber
number = SnapshotNumber
confirmedSn} = ConfirmedSnapshot tx -> Snapshot tx
forall tx. IsTx tx => ConfirmedSnapshot tx -> Snapshot tx
getSnapshot ConfirmedSnapshot tx
confirmedSnapshot
           in OpenState tx -> HeadState tx
forall tx. OpenState tx -> HeadState tx
Open
                OpenState tx
os
                  { chainState
                  , coordinatedHeadState =
                      coordinatedHeadState
                        { decommitTx = Nothing
                        , version = newVersion
                        , -- If a snapshot is already in SeenSnapshot, all parties have
                          -- processed the ReqSn and sent AckSns — preserve it so that
                          -- snapshot can still complete and chain the next one with the
                          -- bumped version. Only reset when nothing is in-flight.
                          seenSnapshot = case seenSnapshot of
                            SeenSnapshot{} -> SeenSnapshot tx
seenSnapshot
                            SeenSnapshot tx
_ -> LastSeenSnapshot{$sel:lastSeen:NoSeenSnapshot :: SnapshotNumber
lastSeen = SnapshotNumber
confirmedSn}
                        }
                  }
      HeadState tx
_otherState -> HeadState tx
st
  HeadClosed{ChainStateType tx
$sel:chainState:NetworkConnected :: forall tx. StateChanged tx -> ChainStateType tx
chainState :: ChainStateType tx
chainState, UTCTime
$sel:contestationDeadline:NetworkConnected :: forall tx. StateChanged tx -> UTCTime
contestationDeadline :: UTCTime
contestationDeadline} ->
    case HeadState tx
st of
      Open
        OpenState
          { HeadParameters
$sel:parameters:OpenState :: forall tx. OpenState tx -> HeadParameters
parameters :: HeadParameters
parameters
          , $sel:coordinatedHeadState:OpenState :: forall tx. OpenState tx -> CoordinatedHeadState tx
coordinatedHeadState =
            CoordinatedHeadState
              { ConfirmedSnapshot tx
$sel:confirmedSnapshot:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> ConfirmedSnapshot tx
confirmedSnapshot :: ConfirmedSnapshot tx
confirmedSnapshot
              , SnapshotVersion
$sel:version:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> SnapshotVersion
version :: SnapshotVersion
version
              }
          , HeadId
$sel:headId:OpenState :: forall tx. OpenState tx -> HeadId
headId :: HeadId
headId
          , HeadSeed
$sel:headSeed:OpenState :: forall tx. OpenState tx -> HeadSeed
headSeed :: HeadSeed
headSeed
          } ->
          ClosedState tx -> HeadState tx
forall tx. ClosedState tx -> HeadState tx
Closed
            ClosedState
              { HeadParameters
$sel:parameters:ClosedState :: HeadParameters
parameters :: HeadParameters
parameters
              , ConfirmedSnapshot tx
$sel:confirmedSnapshot:ClosedState :: ConfirmedSnapshot tx
confirmedSnapshot :: ConfirmedSnapshot tx
confirmedSnapshot
              , UTCTime
$sel:contestationDeadline:ClosedState :: UTCTime
contestationDeadline :: UTCTime
contestationDeadline
              , readyToFanoutSent :: Bool
readyToFanoutSent = Bool
False
              , ChainStateType tx
$sel:chainState:ClosedState :: ChainStateType tx
chainState :: ChainStateType tx
chainState
              , HeadId
$sel:headId:ClosedState :: HeadId
headId :: HeadId
headId
              , HeadSeed
$sel:headSeed:ClosedState :: HeadSeed
headSeed :: HeadSeed
headSeed
              , SnapshotVersion
$sel:version:ClosedState :: SnapshotVersion
version :: SnapshotVersion
version
              }
      HeadState tx
_otherState -> HeadState tx
st
  HeadContested{ChainStateType tx
$sel:chainState:NetworkConnected :: forall tx. StateChanged tx -> ChainStateType tx
chainState :: ChainStateType tx
chainState, UTCTime
$sel:contestationDeadline:NetworkConnected :: forall tx. StateChanged tx -> UTCTime
contestationDeadline :: UTCTime
contestationDeadline} ->
    case HeadState tx
st of
      Closed ClosedState{HeadParameters
$sel:parameters:ClosedState :: forall tx. ClosedState tx -> HeadParameters
parameters :: HeadParameters
parameters, ConfirmedSnapshot tx
$sel:confirmedSnapshot:ClosedState :: forall tx. ClosedState tx -> ConfirmedSnapshot tx
confirmedSnapshot :: ConfirmedSnapshot tx
confirmedSnapshot, Bool
readyToFanoutSent :: forall tx. ClosedState tx -> Bool
readyToFanoutSent :: Bool
readyToFanoutSent, HeadId
$sel:headId:ClosedState :: forall tx. ClosedState tx -> HeadId
headId :: HeadId
headId, HeadSeed
$sel:headSeed:ClosedState :: forall tx. ClosedState tx -> HeadSeed
headSeed :: HeadSeed
headSeed, SnapshotVersion
$sel:version:ClosedState :: forall tx. ClosedState tx -> SnapshotVersion
version :: SnapshotVersion
version} ->
        ClosedState tx -> HeadState tx
forall tx. ClosedState tx -> HeadState tx
Closed
          ClosedState
            { HeadParameters
$sel:parameters:ClosedState :: HeadParameters
parameters :: HeadParameters
parameters
            , ConfirmedSnapshot tx
$sel:confirmedSnapshot:ClosedState :: ConfirmedSnapshot tx
confirmedSnapshot :: ConfirmedSnapshot tx
confirmedSnapshot
            , UTCTime
$sel:contestationDeadline:ClosedState :: UTCTime
contestationDeadline :: UTCTime
contestationDeadline
            , Bool
readyToFanoutSent :: Bool
readyToFanoutSent :: Bool
readyToFanoutSent
            , ChainStateType tx
$sel:chainState:ClosedState :: ChainStateType tx
chainState :: ChainStateType tx
chainState
            , HeadId
$sel:headId:ClosedState :: HeadId
headId :: HeadId
headId
            , HeadSeed
$sel:headSeed:ClosedState :: HeadSeed
headSeed :: HeadSeed
headSeed
            , SnapshotVersion
$sel:version:ClosedState :: SnapshotVersion
version :: SnapshotVersion
version
            }
      HeadState tx
_otherState -> HeadState tx
st
  HeadFannedOut{ChainStateType tx
$sel:chainState:NetworkConnected :: forall tx. StateChanged tx -> ChainStateType tx
chainState :: ChainStateType tx
chainState} ->
    case HeadState tx
st of
      Closed ClosedState tx
_ ->
        IdleState tx -> HeadState tx
forall tx. IdleState tx -> HeadState tx
Idle (IdleState tx -> HeadState tx) -> IdleState tx -> HeadState tx
forall a b. (a -> b) -> a -> b
$ IdleState{ChainStateType tx
$sel:chainState:IdleState :: ChainStateType tx
chainState :: ChainStateType tx
chainState}
      FanoutProgress PartialFanoutState tx
_ ->
        IdleState tx -> HeadState tx
forall tx. IdleState tx -> HeadState tx
Idle (IdleState tx -> HeadState tx) -> IdleState tx -> HeadState tx
forall a b. (a -> b) -> a -> b
$ IdleState{ChainStateType tx
$sel:chainState:IdleState :: ChainStateType tx
chainState :: ChainStateType tx
chainState}
      HeadState tx
_otherState -> HeadState tx
st
  HeadFanoutInitiated{UTxOType tx
$sel:remainingOutputs:NetworkConnected :: forall tx. StateChanged tx -> UTxOType tx
remainingOutputs :: UTxOType tx
remainingOutputs} ->
    case HeadState tx
st of
      -- This node initiated a full automatic fanout: become the driver in
      -- 'AutoDrain' mode so its observations auto-continue to completion.
      Closed cst :: ClosedState tx
cst@ClosedState{ChainStateType tx
$sel:chainState:ClosedState :: forall tx. ClosedState tx -> ChainStateType tx
chainState :: ChainStateType tx
chainState} ->
        ClosedState tx
-> ChainStateType tx
-> UTxOType tx
-> UTxOType tx
-> FanoutMode tx
-> HeadState tx
forall tx.
ClosedState tx
-> ChainStateType tx
-> UTxOType tx
-> UTxOType tx
-> FanoutMode tx
-> HeadState tx
closedToFanoutProgress ClosedState tx
cst ChainStateType tx
chainState UTxOType tx
remainingOutputs UTxOType tx
forall a. Monoid a => a
mempty FanoutMode tx
forall tx. FanoutMode tx
AutoDrain
      HeadState tx
_otherState -> HeadState tx
st
  HeadPartialFanoutSelected{UTxOType tx
$sel:remainingOutputs:NetworkConnected :: forall tx. StateChanged tx -> UTxOType tx
remainingOutputs :: UTxOType tx
remainingOutputs, UTxOType tx
$sel:selection:NetworkConnected :: forall tx. StateChanged tx -> UTxOType tx
selection :: UTxOType tx
selection} ->
    case HeadState tx
st of
      -- First selective partial fanout from a freshly closed head: enter the
      -- 'PartialFanout' state with nothing distributed yet.
      Closed cst :: ClosedState tx
cst@ClosedState{ChainStateType tx
$sel:chainState:ClosedState :: forall tx. ClosedState tx -> ChainStateType tx
chainState :: ChainStateType tx
chainState} ->
        ClosedState tx
-> ChainStateType tx
-> UTxOType tx
-> UTxOType tx
-> FanoutMode tx
-> HeadState tx
forall tx.
ClosedState tx
-> ChainStateType tx
-> UTxOType tx
-> UTxOType tx
-> FanoutMode tx
-> HeadState tx
closedToFanoutProgress ClosedState tx
cst ChainStateType tx
chainState UTxOType tx
remainingOutputs UTxOType tx
forall a. Monoid a => a
mempty (UTxOType tx -> FanoutMode tx
forall tx. UTxOType tx -> FanoutMode tx
DistributingSelection UTxOType tx
selection)
      -- Continuing: just record the new active selection.
      FanoutProgress PartialFanoutState tx
pfs -> PartialFanoutState tx -> HeadState tx
forall tx. PartialFanoutState tx -> HeadState tx
FanoutProgress PartialFanoutState tx
pfs{mode = DistributingSelection selection}
      HeadState tx
_otherState -> HeadState tx
st
  HeadFanoutReverted{} ->
    case HeadState tx
st of
      -- Roll the optimistic transition back: the initiating fanout tx failed to
      -- post and nothing landed on chain, so the head is really still 'Closed'.
      FanoutProgress PartialFanoutState tx
pfs -> ClosedState tx -> HeadState tx
forall tx. ClosedState tx -> HeadState tx
Closed (PartialFanoutState tx -> ClosedState tx
forall tx. PartialFanoutState tx -> ClosedState tx
fanoutProgressToClosed PartialFanoutState tx
pfs)
      HeadState tx
_otherState -> HeadState tx
st
  HeadPartialFannedOut{$sel:distributedOutputs:NetworkConnected :: forall tx. StateChanged tx -> UTxOType tx
distributedOutputs = UTxOType tx
newlyDistributed, UTxOType tx
$sel:remainingOutputs:NetworkConnected :: forall tx. StateChanged tx -> UTxOType tx
remainingOutputs :: UTxOType tx
remainingOutputs, ChainStateType tx
$sel:chainState:NetworkConnected :: forall tx. StateChanged tx -> ChainStateType tx
chainState :: ChainStateType tx
chainState, FanoutMode tx
$sel:mode:NetworkConnected :: forall tx. StateChanged tx -> FanoutMode tx
mode :: FanoutMode tx
mode} ->
    case HeadState tx
st of
      -- First partial fanout observed by a passive observer: transition from
      -- 'Closed' into 'PartialFanout' (using the observed chain state).
      Closed ClosedState tx
cst ->
        ClosedState tx
-> ChainStateType tx
-> UTxOType tx
-> UTxOType tx
-> FanoutMode tx
-> HeadState tx
forall tx.
ClosedState tx
-> ChainStateType tx
-> UTxOType tx
-> UTxOType tx
-> FanoutMode tx
-> HeadState tx
closedToFanoutProgress ClosedState tx
cst ChainStateType tx
chainState UTxOType tx
remainingOutputs UTxOType tx
newlyDistributed FanoutMode tx
mode
      -- Subsequent steps: accumulate distributed outputs and update remaining/mode.
      FanoutProgress pfs :: PartialFanoutState tx
pfs@PartialFanoutState{$sel:distributedOutputs:PartialFanoutState :: forall tx. PartialFanoutState tx -> UTxOType tx
distributedOutputs = UTxOType tx
priorDistributed} ->
        PartialFanoutState tx -> HeadState tx
forall tx. PartialFanoutState tx -> HeadState tx
FanoutProgress
          PartialFanoutState tx
pfs
            { chainState
            , remainingOutputs
            , distributedOutputs = priorDistributed <> newlyDistributed
            , mode
            }
      HeadState tx
_otherState -> HeadState tx
st
  HeadIsReadyToFanout{} ->
    case HeadState tx
st of
      Closed ClosedState tx
cst -> ClosedState tx -> HeadState tx
forall tx. ClosedState tx -> HeadState tx
Closed ClosedState tx
cst{readyToFanoutSent = True}
      HeadState tx
_otherState -> HeadState tx
st
  ChainRolledBack{ChainStateType tx
$sel:chainState:NetworkConnected :: forall tx. StateChanged tx -> ChainStateType tx
chainState :: ChainStateType tx
chainState} ->
    ChainStateType tx -> HeadState tx -> HeadState tx
forall tx. ChainStateType tx -> HeadState tx -> HeadState tx
setChainState ChainStateType tx
chainState HeadState tx
st
  TickObserved{} -> HeadState tx
st
  IgnoredHeadInitializing{} -> HeadState tx
st
  TxInvalid{tx
$sel:transaction:NetworkConnected :: forall tx. StateChanged tx -> tx
transaction :: tx
transaction} -> case HeadState tx
st of
    Open ost :: OpenState tx
ost@OpenState{$sel:coordinatedHeadState:OpenState :: forall tx. OpenState tx -> CoordinatedHeadState tx
coordinatedHeadState = coordState :: CoordinatedHeadState tx
coordState@CoordinatedHeadState{$sel:allTxs:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> Map (TxIdType tx) tx
allTxs = Map (TxIdType tx) tx
allTransactions}} ->
      OpenState tx -> HeadState tx
forall tx. OpenState tx -> HeadState tx
Open OpenState tx
ost{coordinatedHeadState = coordState{allTxs = Map.delete (txId transaction) allTransactions}}
    HeadState tx
_otherState -> HeadState tx
st
  Checkpoint NodeState tx
nodeState -> NodeState tx -> HeadState tx
forall tx. NodeState tx -> HeadState tx
headState NodeState tx
nodeState
  NodeSynced{} -> HeadState tx
st
  NodeUnsynced{} -> HeadState tx
st

aggregateState ::
  IsChainState tx =>
  NodeState tx ->
  Outcome tx ->
  NodeState tx
aggregateState :: forall tx.
IsChainState tx =>
NodeState tx -> Outcome tx -> NodeState tx
aggregateState NodeState tx
s Outcome tx
outcome =
  (NodeState tx -> StateChanged tx -> NodeState tx)
-> NodeState tx -> [StateChanged tx] -> NodeState tx
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' NodeState tx -> StateChanged tx -> NodeState tx
forall tx.
IsChainState tx =>
NodeState tx -> StateChanged tx -> NodeState tx
aggregateNodeState NodeState tx
s ([StateChanged tx] -> NodeState tx)
-> [StateChanged tx] -> NodeState tx
forall a b. (a -> b) -> a -> b
$ Outcome tx -> [StateChanged tx]
forall tx. Outcome tx -> [StateChanged tx]
collectStateChanged Outcome tx
outcome
 where
  collectStateChanged :: Outcome tx -> [StateChanged tx]
  collectStateChanged :: forall tx. Outcome tx -> [StateChanged tx]
collectStateChanged = \case
    Error{} -> []
    Wait{[StateChanged tx]
stateChanges :: [StateChanged tx]
$sel:stateChanges:Continue :: forall tx. Outcome tx -> [StateChanged tx]
stateChanges} -> [StateChanged tx]
stateChanges
    Continue{[StateChanged tx]
$sel:stateChanges:Continue :: forall tx. Outcome tx -> [StateChanged tx]
stateChanges :: [StateChanged tx]
stateChanges} -> [StateChanged tx]
stateChanges

aggregateChainStateHistory :: IsChainState tx => ChainStateHistory tx -> StateChanged tx -> ChainStateHistory tx
aggregateChainStateHistory :: forall tx.
IsChainState tx =>
ChainStateHistory tx -> StateChanged tx -> ChainStateHistory tx
aggregateChainStateHistory ChainStateHistory tx
history = \case
  StateChanged tx
NetworkConnected -> ChainStateHistory tx
history
  StateChanged tx
NetworkDisconnected -> ChainStateHistory tx
history
  NetworkVersionMismatch{} -> ChainStateHistory tx
history
  NetworkClusterIDMismatch{} -> ChainStateHistory tx
history
  PeerConnected{} -> ChainStateHistory tx
history
  PeerDisconnected{} -> ChainStateHistory tx
history
  HeadOpened{ChainStateType tx
$sel:chainState:NetworkConnected :: forall tx. StateChanged tx -> ChainStateType tx
chainState :: ChainStateType tx
chainState} -> ChainStateType tx -> ChainStateHistory tx -> ChainStateHistory tx
forall tx.
IsChainState tx =>
ChainStateType tx -> ChainStateHistory tx -> ChainStateHistory tx
pushNewState ChainStateType tx
chainState ChainStateHistory tx
history
  TransactionAppliedToLocalUTxO{} -> ChainStateHistory tx
history
  SnapshotRequestDecided{} -> ChainStateHistory tx
history
  SnapshotRequested{} -> ChainStateHistory tx
history
  TransactionReceived{} -> ChainStateHistory tx
history
  PartySignedSnapshot{} -> ChainStateHistory tx
history
  SnapshotConfirmed{} -> ChainStateHistory tx
history
  DepositRecorded{ChainStateType tx
$sel:chainState:NetworkConnected :: forall tx. StateChanged tx -> ChainStateType tx
chainState :: ChainStateType tx
chainState} -> ChainStateType tx -> ChainStateHistory tx -> ChainStateHistory tx
forall tx.
IsChainState tx =>
ChainStateType tx -> ChainStateHistory tx -> ChainStateHistory tx
pushNewState ChainStateType tx
chainState ChainStateHistory tx
history
  DepositActivated{} -> ChainStateHistory tx
history
  DepositExpired{} -> ChainStateHistory tx
history
  DepositRecovered{ChainStateType tx
$sel:chainState:NetworkConnected :: forall tx. StateChanged tx -> ChainStateType tx
chainState :: ChainStateType tx
chainState} -> ChainStateType tx -> ChainStateHistory tx -> ChainStateHistory tx
forall tx.
IsChainState tx =>
ChainStateType tx -> ChainStateHistory tx -> ChainStateHistory tx
pushNewState ChainStateType tx
chainState ChainStateHistory tx
history
  CommitFinalized{ChainStateType tx
$sel:chainState:NetworkConnected :: forall tx. StateChanged tx -> ChainStateType tx
chainState :: ChainStateType tx
chainState} -> ChainStateType tx -> ChainStateHistory tx -> ChainStateHistory tx
forall tx.
IsChainState tx =>
ChainStateType tx -> ChainStateHistory tx -> ChainStateHistory tx
pushNewState ChainStateType tx
chainState ChainStateHistory tx
history
  DecommitRecorded{} -> ChainStateHistory tx
history
  DecommitFinalized{ChainStateType tx
$sel:chainState:NetworkConnected :: forall tx. StateChanged tx -> ChainStateType tx
chainState :: ChainStateType tx
chainState} -> ChainStateType tx -> ChainStateHistory tx -> ChainStateHistory tx
forall tx.
IsChainState tx =>
ChainStateType tx -> ChainStateHistory tx -> ChainStateHistory tx
pushNewState ChainStateType tx
chainState ChainStateHistory tx
history
  HeadClosed{ChainStateType tx
$sel:chainState:NetworkConnected :: forall tx. StateChanged tx -> ChainStateType tx
chainState :: ChainStateType tx
chainState} -> ChainStateType tx -> ChainStateHistory tx -> ChainStateHistory tx
forall tx.
IsChainState tx =>
ChainStateType tx -> ChainStateHistory tx -> ChainStateHistory tx
pushNewState ChainStateType tx
chainState ChainStateHistory tx
history
  HeadContested{ChainStateType tx
$sel:chainState:NetworkConnected :: forall tx. StateChanged tx -> ChainStateType tx
chainState :: ChainStateType tx
chainState} -> ChainStateType tx -> ChainStateHistory tx -> ChainStateHistory tx
forall tx.
IsChainState tx =>
ChainStateType tx -> ChainStateHistory tx -> ChainStateHistory tx
pushNewState ChainStateType tx
chainState ChainStateHistory tx
history
  HeadIsReadyToFanout{} -> ChainStateHistory tx
history
  HeadFannedOut{ChainStateType tx
$sel:chainState:NetworkConnected :: forall tx. StateChanged tx -> ChainStateType tx
chainState :: ChainStateType tx
chainState} -> ChainStateType tx -> ChainStateHistory tx -> ChainStateHistory tx
forall tx.
IsChainState tx =>
ChainStateType tx -> ChainStateHistory tx -> ChainStateHistory tx
pushNewState ChainStateType tx
chainState ChainStateHistory tx
history
  HeadPartialFannedOut{ChainStateType tx
$sel:chainState:NetworkConnected :: forall tx. StateChanged tx -> ChainStateType tx
chainState :: ChainStateType tx
chainState} -> ChainStateType tx -> ChainStateHistory tx -> ChainStateHistory tx
forall tx.
IsChainState tx =>
ChainStateType tx -> ChainStateHistory tx -> ChainStateHistory tx
pushNewState ChainStateType tx
chainState ChainStateHistory tx
history
  HeadFanoutInitiated{} -> ChainStateHistory tx
history
  HeadPartialFanoutSelected{} -> ChainStateHistory tx
history
  HeadFanoutReverted{} -> ChainStateHistory tx
history
  ChainRolledBack{ChainStateType tx
$sel:chainState:NetworkConnected :: forall tx. StateChanged tx -> ChainStateType tx
chainState :: ChainStateType tx
chainState} -> ChainSlot -> ChainStateHistory tx -> ChainStateHistory tx
forall tx.
IsChainState tx =>
ChainSlot -> ChainStateHistory tx -> ChainStateHistory tx
rollbackHistory (ChainStateType tx -> ChainSlot
forall tx. IsChainState tx => ChainStateType tx -> ChainSlot
chainStateSlot ChainStateType tx
chainState) ChainStateHistory tx
history
  TickObserved{ChainPointType tx
$sel:chainPoint:NetworkConnected :: forall tx. StateChanged tx -> ChainPointType tx
chainPoint :: ChainPointType tx
chainPoint} -> ChainPointType tx -> ChainStateHistory tx -> ChainStateHistory tx
forall tx.
ChainPointType tx -> ChainStateHistory tx -> ChainStateHistory tx
setLastKnown ChainPointType tx
chainPoint ChainStateHistory tx
history
  CommitApproved{} -> ChainStateHistory tx
history
  DecommitApproved{} -> ChainStateHistory tx
history
  DecommitInvalid{} -> ChainStateHistory tx
history
  IgnoredHeadInitializing{} -> ChainStateHistory tx
history
  TxInvalid{} -> ChainStateHistory tx
history
  LocalStateCleared{} -> ChainStateHistory tx
history
  -- FIXME: This makes chain sync starting after rollbacks past the chain state impossible
  Checkpoint NodeState tx
nodeState -> ChainStateType tx -> ChainStateHistory tx
forall tx.
IsChainState tx =>
ChainStateType tx -> ChainStateHistory tx
initHistory (ChainStateType tx -> ChainStateHistory tx)
-> ChainStateType tx -> ChainStateHistory tx
forall a b. (a -> b) -> a -> b
$ HeadState tx -> ChainStateType tx
forall tx. HeadState tx -> ChainStateType tx
getChainState NodeState tx
nodeState.headState
  NodeUnsynced{} -> ChainStateHistory tx
history
  NodeSynced{} -> ChainStateHistory tx
history