{-# 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 (..), validateClientInput)
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 (..),
  FinalizedSnapshot (..),
  HeadState (..),
  IdleState (IdleState, chainState),
  OpenState (..),
  PartialFanoutState (..),
  SeenSnapshot (..),
  getChainState,
  isCollectingAcks,
  mkSeenSnapshot,
  seenSnapshotNumber,
  setChainState,
  snapshotInFlight,
 )
import Hydra.Ledger (Ledger (..), ValidationError (..), applyTransactions)
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 (..), consumeDeposit, depositsForHead, recordDeposit, rollbackDeposits, syncedStatus, updateDeposit)
import Hydra.Node.UnsyncedPeriod (UnsyncedPeriod (..))
import Hydra.Tx (
  HeadId,
  HeadSeed,
  IsTx (..),
  TxIdType,
  UTxOType,
  combinedUTxO,
  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)

-- * 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 ->
  TTL ->
  -- | 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
-> TTL
-> 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 TTL
ttl 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
                    -- The predecessor is confirmed at this point (see
                    -- requireReqSn and waitNoSnapshotInFlight), so its two
                    -- accumulators cover exactly its own two owed sets (see
                    -- 'Accumulator.buildFromSnapshotUTxOs') 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
                        (UTxOType tx
-> Maybe (UTxOType tx) -> Maybe (UTxOType tx) -> UTxOType tx
forall a. Monoid a => a -> Maybe a -> Maybe a -> a
combinedUTxO Snapshot tx
prevSnapshot.utxo Maybe (UTxOType tx)
forall a. Maybe a
Nothing Snapshot tx
prevSnapshot.utxoToDecommit)
                        (UTxOType tx
-> Maybe (UTxOType tx) -> Maybe (UTxOType tx) -> UTxOType tx
forall a. Monoid a => a -> Maybe a -> Maybe a -> a
combinedUTxO UTxOType tx
nextUTxO Maybe (UTxOType tx)
forall a. Maybe a
Nothing Maybe (UTxOType tx)
mUtxoToDecommit)
                    appliedAccumulator :: HydraAccumulator
appliedAccumulator
                      -- Nothing pending: both accumulators are the same value,
                      -- share the thunk so the commitment is computed once.
                      | Maybe (UTxOType tx) -> Bool
forall a. Maybe a -> Bool
isNothing Maybe (UTxOType tx)
mUtxoToCommit Bool -> Bool -> Bool
&& Maybe (UTxOType tx) -> Bool
forall a. Maybe a -> Bool
isNothing Maybe (UTxOType tx)
mUtxoToDecommit = HydraAccumulator
accumulator
                      | Bool
otherwise =
                          HydraAccumulator -> UTxOType tx -> UTxOType tx -> HydraAccumulator
forall tx.
IsTx tx =>
HydraAccumulator -> UTxOType tx -> UTxOType tx -> HydraAccumulator
Accumulator.applyUTxODelta
                            Snapshot tx
prevSnapshot.appliedAccumulator
                            (UTxOType tx
-> Maybe (UTxOType tx) -> Maybe (UTxOType tx) -> UTxOType tx
forall a. Monoid a => a -> Maybe a -> Maybe a -> a
combinedUTxO Snapshot tx
prevSnapshot.utxo Snapshot tx
prevSnapshot.utxoToCommit Maybe (UTxOType tx)
forall a. Maybe a
Nothing)
                            (UTxOType tx
-> Maybe (UTxOType tx) -> Maybe (UTxOType tx) -> UTxOType tx
forall a. Monoid a => a -> Maybe a -> Maybe a -> a
combinedUTxO UTxOType tx
nextUTxO Maybe (UTxOType tx)
mUtxoToCommit Maybe (UTxOType tx)
forall a. Maybe a
Nothing)
                 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
$ HydraAccumulator -> Outcome tx -> Outcome tx
forall tx. HydraAccumulator -> Outcome tx -> Outcome tx
requireValidAccumulatorSize HydraAccumulator
appliedAccumulator (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
                              , HydraAccumulator
appliedAccumulator :: HydraAccumulator
$sel:appliedAccumulator:Snapshot :: HydraAccumulator
appliedAccumulator
                              }

                      -- 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
        -- The deposit is already claimed by a signed snapshot whose increment
        -- settled on-chain: it only resurfaces in 'pendingDeposits' when a
        -- rollback erased that increment, and honest leaders exclude it from
        -- selection (see 'eligibleDeposits'). Reject rather than sign a
        -- second snapshot claiming the same deposit, see #2741.
        | Maybe (FinalizedSnapshot tx) -> Maybe (TxIdType tx)
forall tx.
IsTx tx =>
Maybe (FinalizedSnapshot tx) -> Maybe (TxIdType tx)
finalizedDepositTxId Maybe (FinalizedSnapshot tx)
finalizedCommit 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 ->
            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 ReqSnDepositBlockedByFinalizedCommit{TxIdType tx
depositTxId :: TxIdType tx
$sel:depositTxId:ReqSnNumberInvalid :: TxIdType tx
depositTxId}
      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
            -- NOTE: must be a Wait while ttl remains, not a require: a
            -- follower can receive the ReqSn before its own chain handler has
            -- processed the deposit observation. Erroring would drop the
            -- message permanently and this node would never sign — with the
            -- snapshot then in flight on all other nodes, the head is stuck
            -- for good. Once ttl is exhausted the deposit is genuinely
            -- unknown (e.g. a stale ReqSn referencing an already recovered
            -- deposit) and we error out.
            | 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 WaitOnDepositObserved{TxIdType tx
depositTxId :: TxIdType tx
$sel:depositTxId:WaitOnNotApplicableTx :: TxIdType tx
depositTxId}
            | Bool
otherwise -> 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
$sel:depositTxId:ReqSnNumberInvalid :: TxIdType tx
depositTxId :: 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
$sel:depositTxId:ReqSnNumberInvalid :: TxIdType tx
depositTxId :: 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)

  -- The snapshot can contain fewer 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.
  --
  -- We fully apply here, re-running signature and Plutus checks. Transactions
  -- resolved from 'allTxs' are not guaranteed to have been validated locally
  -- (an invalid one can be recorded on the receipt 'Wait' branch, and a
  -- follower may not have applied a valid one that conflicts with its own
  -- optimistic local state), so full application is the only place that
  -- guarantees a confirmed snapshot never contains an unvalidated transaction.
  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)
forall tx.
Ledger tx
-> ChainSlot
-> UTxOType tx
-> [tx]
-> Either (tx, ValidationError) (UTxOType tx)
applyTransactions 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

  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.
      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
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, Maybe (FinalizedSnapshot tx)
finalizedCommit :: Maybe (FinalizedSnapshot tx)
$sel:finalizedCommit:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> Maybe (FinalizedSnapshot tx)
finalizedCommit} = 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 ->
  -- | Deposit claimed by the retained finalized increment of an open head, if
  -- any (see 'openFinalizedDeposit').
  Maybe (TxIdType tx) ->
  TxIdType tx ->
  Outcome tx
onClientRecover :: forall tx.
IsTx tx =>
ChainSlot
-> PendingDeposits tx
-> Maybe (TxIdType tx)
-> TxIdType tx
-> Outcome tx
onClientRecover ChainSlot
currentSlot PendingDeposits tx
pendingDeposits Maybe (TxIdType tx)
finalizedDeposit 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}
      -- The deposit resurfaced because its finalized increment was rolled
      -- back: the deposited funds are already merged into the head, so
      -- recovering them on-chain would corrupt the L2 ledger. Only re-posting
      -- the increment settles this deposit, see #2741.
      | Maybe (TxIdType tx)
finalizedDeposit 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
recoverTxId ->
          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 RecoverBlockedByFinalizedCommit{$sel:depositTxId:ReqSnNumberInvalid :: TxIdType tx
depositTxId = TxIdType tx
recoverTxId}
      | Bool
otherwise ->
          [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 :: Environment -> PendingDeposits tx -> UTCTime -> PendingDeposits tx
determineNextDepositStatus :: forall tx.
Environment -> PendingDeposits tx -> UTCTime -> PendingDeposits tx
determineNextDepositStatus Environment
env PendingDeposits tx
pendingDeposits UTCTime
chainTime =
  (\Deposit tx
deposit -> Deposit tx
deposit{status = determineStatus deposit}) (Deposit tx -> Deposit tx)
-> PendingDeposits tx -> PendingDeposits tx
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PendingDeposits tx
pendingDeposits
 where
  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.
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.
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 'newVersion' is ahead of the local 'version': this
--     avoids duplicate 'SnapshotRequestDecided' events when multiple parties
--     post the same on-chain tx and each posting produces a separate
--     finalisation observation, and it keeps a finalization re-landing after a
--     rollback (its 'newVersion' is at or behind the local version, which
--     never rolls back) from requesting a snapshot with a stale version.
--   * 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
newVersion SnapshotVersion -> SnapshotVersion -> Bool
forall a. Ord a => a -> a -> Bool
> SnapshotVersion
version 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
newVersion :: 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
newVersion :: 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.
--
-- If the increment was already finalized ('CommitFinalized' consumed the
-- deposit and 'confirmedSnapshot' may have advanced past the incrementing
-- snapshot), fall back to the retained 'finalizedCommit' — but only when the
-- rollback reaches strictly before its observation slot; otherwise the
-- increment is still on chain and re-posting would only produce noise. See
-- #2741.
maybeRepostIncrementTx ::
  IsTx tx =>
  HeadSeed ->
  HeadId ->
  HeadParameters ->
  PendingDeposits tx ->
  ConfirmedSnapshot tx ->
  Maybe (FinalizedSnapshot tx) ->
  -- | Slot rolled back to
  ChainSlot ->
  Outcome tx
maybeRepostIncrementTx :: forall tx.
IsTx tx =>
HeadSeed
-> HeadId
-> HeadParameters
-> PendingDeposits tx
-> ConfirmedSnapshot tx
-> Maybe (FinalizedSnapshot tx)
-> ChainSlot
-> Outcome tx
maybeRepostIncrementTx HeadSeed
headSeed HeadId
headId HeadParameters
parameters PendingDeposits tx
pendingDeposits ConfirmedSnapshot tx
confirmedSnapshot Maybe (FinalizedSnapshot tx)
finalizedCommit ChainSlot
rolledBackSlot =
  -- 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}
      | Just 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
pendingDeposits ->
          ConfirmedSnapshot tx -> TxIdType tx -> Outcome tx
repost 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
depositTxId
    ConfirmedSnapshot tx
_ ->
      case Maybe (FinalizedSnapshot tx)
finalizedCommit of
        Just FinalizedSnapshot{ConfirmedSnapshot tx
snapshot :: ConfirmedSnapshot tx
$sel:snapshot:FinalizedSnapshot :: forall tx. FinalizedSnapshot tx -> ConfirmedSnapshot tx
snapshot, ChainSlot
observedAtSlot :: ChainSlot
$sel:observedAtSlot:FinalizedSnapshot :: forall tx. FinalizedSnapshot tx -> ChainSlot
observedAtSlot}
          -- Strictly (<): the rollback point is the last common block, so
          -- rolling back TO the increment's slot means it is still on chain.
          | ChainSlot
rolledBackSlot ChainSlot -> ChainSlot -> Bool
forall a. Ord a => a -> a -> Bool
< ChainSlot
observedAtSlot
          , Just TxIdType tx
depositTxId <- (ConfirmedSnapshot tx -> Snapshot tx
forall tx. IsTx tx => ConfirmedSnapshot tx -> Snapshot tx
getSnapshot ConfirmedSnapshot tx
snapshot).depositTxId ->
              ConfirmedSnapshot tx -> TxIdType tx -> Outcome tx
repost ConfirmedSnapshot tx
snapshot TxIdType tx
depositTxId
        Maybe (FinalizedSnapshot tx)
_ -> Outcome tx
forall tx. Outcome tx
noop
 where
  repost :: ConfirmedSnapshot tx -> TxIdType tx -> Outcome tx
repost ConfirmedSnapshot tx
incrementingSnapshot TxIdType tx
depositTxId =
    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
              , ConfirmedSnapshot tx
$sel:incrementingSnapshot:InitTx :: ConfirmedSnapshot tx
incrementingSnapshot :: ConfirmedSnapshot tx
incrementingSnapshot
              , TxIdType tx
$sel:depositTxId:InitTx :: TxIdType tx
depositTxId :: TxIdType tx
depositTxId
              }
        }

-- | 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.
--
-- If the decrement was already finalized ('DecommitFinalized' cleared
-- 'decommitTx' and 'confirmedSnapshot' may have advanced past the decrementing
-- snapshot), fall back to the retained 'finalizedDecommit' — but only when the
-- rollback reaches strictly before its observation slot. See #2741.
maybeRepostDecrementTx ::
  HeadSeed ->
  HeadId ->
  HeadParameters ->
  Maybe tx ->
  ConfirmedSnapshot tx ->
  Maybe (FinalizedSnapshot tx) ->
  -- | Slot rolled back to
  ChainSlot ->
  Outcome tx
maybeRepostDecrementTx :: forall tx.
HeadSeed
-> HeadId
-> HeadParameters
-> Maybe tx
-> ConfirmedSnapshot tx
-> Maybe (FinalizedSnapshot tx)
-> ChainSlot
-> Outcome tx
maybeRepostDecrementTx HeadSeed
headSeed HeadId
headId HeadParameters
parameters Maybe tx
mDecommitTx ConfirmedSnapshot tx
confirmedSnapshot Maybe (FinalizedSnapshot tx)
finalizedDecommit ChainSlot
rolledBackSlot =
  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}) ->
      ConfirmedSnapshot tx -> Outcome tx
repost 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)
_ ->
      case Maybe (FinalizedSnapshot tx)
finalizedDecommit of
        Just FinalizedSnapshot{ConfirmedSnapshot tx
$sel:snapshot:FinalizedSnapshot :: forall tx. FinalizedSnapshot tx -> ConfirmedSnapshot tx
snapshot :: ConfirmedSnapshot tx
snapshot, ChainSlot
$sel:observedAtSlot:FinalizedSnapshot :: forall tx. FinalizedSnapshot tx -> ChainSlot
observedAtSlot :: ChainSlot
observedAtSlot}
          | ChainSlot
rolledBackSlot ChainSlot -> ChainSlot -> Bool
forall a. Ord a => a -> a -> Bool
< ChainSlot
observedAtSlot ->
              ConfirmedSnapshot tx -> Outcome tx
repost ConfirmedSnapshot tx
snapshot
        Maybe (FinalizedSnapshot tx)
_ -> Outcome tx
forall tx. Outcome tx
noop
 where
  repost :: ConfirmedSnapshot tx -> Outcome tx
repost ConfirmedSnapshot tx
decrementingSnapshot =
    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
              , ConfirmedSnapshot tx
$sel:decrementingSnapshot:InitTx :: ConfirmedSnapshot tx
decrementingSnapshot :: ConfirmedSnapshot tx
decrementingSnapshot
              }
        }

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 :: forall tx. ClosedState tx -> ConfirmedSnapshot tx
confirmedSnapshot :: ConfirmedSnapshot tx
confirmedSnapshot, HeadId
headId :: HeadId
$sel:headId:ClosedState :: forall tx. ClosedState tx -> HeadId
headId, SnapshotVersion
version :: forall tx. ClosedState tx -> SnapshotVersion
version :: 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 =
  -- A plain 'Fanout' is a full fanout by definition, and is only reachable from
  -- 'Closed'.
  HeadId -> NextFanoutStep tx -> UTxOType tx -> Outcome tx
forall tx. HeadId -> NextFanoutStep tx -> UTxOType tx -> Outcome tx
fanoutStepStateChange HeadId
headId NextFanoutStep tx
forall tx. NextFanoutStep tx
FullFanoutStep UTxOType tx
fullUTxO
    Outcome tx -> Outcome tx -> Outcome tx
forall a. Semigroup a => a -> a -> a
<> NextFanoutStep tx
-> ConfirmedSnapshot tx
-> SnapshotVersion
-> HeadSeed
-> UTCTime
-> Outcome tx
forall tx.
IsTx tx =>
NextFanoutStep tx
-> ConfirmedSnapshot tx
-> SnapshotVersion
-> HeadSeed
-> UTCTime
-> Outcome tx
emitFanoutStep NextFanoutStep tx
forall tx. NextFanoutStep tx
FullFanoutStep 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
confirmedSnapshot :: forall tx. ClosedState tx -> ConfirmedSnapshot tx
confirmedSnapshot :: ConfirmedSnapshot tx
confirmedSnapshot, SnapshotVersion
version :: 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

-- | The state change that goes with a fanout step, for the callers that own the
-- head state: taking the driver role, or recording the selection being
-- distributed. Decided here once rather than in each handler.
--
-- The selection comes from the step rather than the caller, so a step can only
-- ever be recorded against the set it actually distributes.
fanoutStepStateChange ::
  HeadId ->
  NextFanoutStep tx ->
  -- | The head's full remaining set
  UTxOType tx ->
  Outcome tx
fanoutStepStateChange :: forall tx. HeadId -> NextFanoutStep tx -> UTxOType tx -> Outcome tx
fanoutStepStateChange HeadId
headId NextFanoutStep tx
step UTxOType tx
remainingOutputs =
  case NextFanoutStep tx
step of
    -- The selection is not distributed as one: it becomes a full fanout, and this
    -- node drives the rest of it.
    NextFanoutStep tx
FullFanoutStep -> StateChanged tx -> Outcome tx
forall tx. StateChanged tx -> Outcome tx
newState HeadFanoutInitiated{HeadId
$sel:headId:NetworkConnected :: HeadId
headId :: HeadId
headId, UTxOType tx
remainingOutputs :: UTxOType tx
$sel:remainingOutputs:NetworkConnected :: UTxOType tx
remainingOutputs}
    -- 'FinalStep' posts a transaction and nothing else, so the selection has to
    -- be recorded for it too: a rollback or restart before that transaction
    -- lands otherwise leaves the driver with no selection to resume from.
    FinalStep{UTxOType tx
stepDistribute :: UTxOType tx
$sel:stepDistribute:FinalStep :: forall tx. NextFanoutStep tx -> UTxOType tx
stepDistribute} -> UTxOType tx -> Outcome tx
recordSelection UTxOType tx
stepDistribute
    PartialStep{UTxOType tx
$sel:stepDistribute:FinalStep :: forall tx. NextFanoutStep tx -> UTxOType tx
stepDistribute :: UTxOType tx
stepDistribute} -> UTxOType tx -> Outcome tx
recordSelection UTxOType tx
stepDistribute
 where
  recordSelection :: UTxOType tx -> Outcome tx
recordSelection UTxOType tx
selection = StateChanged tx -> Outcome tx
forall tx. StateChanged tx -> Outcome tx
newState HeadPartialFanoutSelected{HeadId
$sel:headId:NetworkConnected :: HeadId
headId :: HeadId
headId, UTxOType tx
remainingOutputs :: UTxOType tx
$sel:remainingOutputs:NetworkConnected :: UTxOType tx
remainingOutputs, UTxOType tx
selection :: UTxOType tx
$sel:selection:NetworkConnected :: UTxOType tx
selection}

-- | Which transaction the next fanout step has to be, carrying the sets that
-- transaction needs. Decided once by 'nextFanoutStep' so that callers deciding
-- what else to record and 'emitFanoutStep' deciding what to post cannot
-- disagree, and so that no caller can pair a step with sets it does not go with.
data NextFanoutStep tx
  = -- | The target is the whole remainder and the head is already in
    -- @FanoutProgress@ on chain: the final step, distributing the rest and
    -- burning the head tokens.
    FinalStep {forall tx. NextFanoutStep tx -> UTxOType tx
stepDistribute :: UTxOType tx}
  | -- | The target is the whole remainder but the head output still carries the
    -- @Closed@ datum, which the final step is not valid against. Posted as a
    -- non-final step it would empty the head, which 'mustNotBeLastBatch' rejects,
    -- so the chunk search settles for one output less and the head needs a second
    -- transaction to finish — and cannot be drained at all when a single output
    -- is left. Covering everything is a full fanout, so post that (#2855).
    FullFanoutStep
  | -- | The target is a strict subset: a non-final chunk distributing it, proved
    -- against the set the head's current datum commits to.
    PartialStep {stepDistribute :: UTxOType tx, forall tx. NextFanoutStep tx -> UTxOType tx
stepProof :: UTxOType tx}

-- | Decide the next fanout step. The multiset comparison here is the only one
-- needed: callers pass the result on rather than re-deriving it.
nextFanoutStep ::
  IsTx tx =>
  ConfirmedSnapshot tx ->
  SnapshotVersion ->
  -- | Chunk source for the next step (the user selection, or the whole remaining
  --   set when auto-draining)
  UTxOType tx ->
  -- | The head's full remaining set
  UTxOType tx ->
  OnChainFanoutDatum ->
  NextFanoutStep tx
nextFanoutStep :: forall tx.
IsTx tx =>
ConfirmedSnapshot tx
-> SnapshotVersion
-> UTxOType tx
-> UTxOType tx
-> OnChainFanoutDatum
-> NextFanoutStep tx
nextFanoutStep ConfirmedSnapshot tx
confirmedSnapshot SnapshotVersion
version UTxOType tx
target UTxOType tx
remaining OnChainFanoutDatum
onChainDatum
  | UTxOType tx
target UTxOType tx -> UTxOType tx -> Bool
forall tx. IsTx tx => UTxOType tx -> UTxOType tx -> Bool
`sameOutputs` UTxOType tx
remaining =
      case OnChainFanoutDatum
onChainDatum of
        OnChainFanoutDatum
DatumFanoutProgress -> FinalStep{$sel:stepDistribute:FinalStep :: UTxOType tx
stepDistribute = UTxOType tx
remaining}
        OnChainFanoutDatum
DatumClosed -> NextFanoutStep tx
forall tx. NextFanoutStep tx
FullFanoutStep
  | Bool
otherwise = PartialStep{$sel:stepDistribute:FinalStep :: UTxOType tx
stepDistribute = UTxOType tx
target, $sel:stepProof:FinalStep :: UTxOType tx
stepProof = UTxOType tx
proofSet}
 where
  -- The set the on-chain datum commits to: the fan-out-able set from a @Closed@
  -- head, and the not-yet-distributed set once the head is in @FanoutProgress@,
  -- since every step removes exactly what it distributed.
  proofSet :: UTxOType tx
proofSet = case OnChainFanoutDatum
onChainDatum of
    OnChainFanoutDatum
DatumClosed -> ConfirmedSnapshot tx -> SnapshotVersion -> UTxOType tx
forall tx.
IsTx tx =>
ConfirmedSnapshot tx -> SnapshotVersion -> UTxOType tx
fanoutUTxOFromSnapshot ConfirmedSnapshot tx
confirmedSnapshot SnapshotVersion
version
    OnChainFanoutDatum
DatumFanoutProgress -> UTxOType tx
remaining

-- | 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
    , 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{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

-- | 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, then transitions the head into 'PartialFanout' and posts
-- whichever step 'nextFanoutStep' decides on: a strict subset records the
-- selection and posts a 'PartialFanoutTx', while a selection covering the whole
-- head is a full fanout and drains it automatically instead.
--
-- __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)
  | Bool
otherwise =
      -- A selection covering the whole head becomes a full fanout - what the user
      -- means by "fan out everything", and the only option for a head holding a
      -- single UTxO, since a non-final batch has to leave one behind.
      HeadId -> NextFanoutStep tx -> UTxOType tx -> Outcome tx
forall tx. HeadId -> NextFanoutStep tx -> UTxOType tx -> Outcome tx
fanoutStepStateChange HeadId
headId NextFanoutStep tx
step UTxOType tx
fullUTxO
        Outcome tx -> Outcome tx -> Outcome tx
forall a. Semigroup a => a -> a -> a
<> NextFanoutStep tx
-> ConfirmedSnapshot tx
-> SnapshotVersion
-> HeadSeed
-> UTCTime
-> Outcome tx
forall tx.
IsTx tx =>
NextFanoutStep tx
-> ConfirmedSnapshot tx
-> SnapshotVersion
-> HeadSeed
-> UTCTime
-> Outcome tx
emitFanoutStep NextFanoutStep tx
step ConfirmedSnapshot tx
confirmedSnapshot SnapshotVersion
version HeadSeed
headSeed UTCTime
contestationDeadline
 where
  -- Fresh head: the on-chain datum is still @Closed@.
  step :: NextFanoutStep tx
step = ConfirmedSnapshot tx
-> SnapshotVersion
-> UTxOType tx
-> UTxOType tx
-> OnChainFanoutDatum
-> NextFanoutStep tx
forall tx.
IsTx tx =>
ConfirmedSnapshot tx
-> SnapshotVersion
-> UTxOType tx
-> UTxOType tx
-> OnChainFanoutDatum
-> NextFanoutStep tx
nextFanoutStep ConfirmedSnapshot tx
confirmedSnapshot SnapshotVersion
version UTxOType tx
selection UTxOType tx
fullUTxO OnChainFanoutDatum
DatumClosed

  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
confirmedSnapshot :: forall tx. ClosedState tx -> ConfirmedSnapshot tx
confirmedSnapshot :: ConfirmedSnapshot tx
confirmedSnapshot, SnapshotVersion
version :: 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' and emits whichever step
-- 'nextFanoutStep' decides on, which is not always a recorded selection: one
-- covering the whole remainder finalizes the head, or, if nothing has been
-- distributed yet, becomes a full fanout that drains it automatically.
--
-- __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 =
      HeadId -> NextFanoutStep tx -> UTxOType tx -> Outcome tx
forall tx. HeadId -> NextFanoutStep tx -> UTxOType tx -> Outcome tx
fanoutStepStateChange HeadId
headId NextFanoutStep tx
step UTxOType tx
remainingOutputs
        Outcome tx -> Outcome tx -> Outcome tx
forall a. Semigroup a => a -> a -> a
<> NextFanoutStep tx
-> ConfirmedSnapshot tx
-> SnapshotVersion
-> HeadSeed
-> UTCTime
-> Outcome tx
forall tx.
IsTx tx =>
NextFanoutStep tx
-> ConfirmedSnapshot tx
-> SnapshotVersion
-> HeadSeed
-> UTCTime
-> Outcome tx
emitFanoutStep NextFanoutStep tx
step ConfirmedSnapshot tx
confirmedSnapshot SnapshotVersion
version HeadSeed
headSeed UTCTime
contestationDeadline
 where
  -- 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'.
  step :: NextFanoutStep tx
step = ConfirmedSnapshot tx
-> SnapshotVersion
-> UTxOType tx
-> UTxOType tx
-> OnChainFanoutDatum
-> NextFanoutStep tx
forall tx.
IsTx tx =>
ConfirmedSnapshot tx
-> SnapshotVersion
-> UTxOType tx
-> UTxOType tx
-> OnChainFanoutDatum
-> NextFanoutStep tx
nextFanoutStep ConfirmedSnapshot tx
confirmedSnapshot SnapshotVersion
version UTxOType tx
selection UTxOType tx
remainingOutputs (UTxOType tx -> OnChainFanoutDatum
forall tx. IsTx tx => UTxOType tx -> OnChainFanoutDatum
onChainFanoutDatum UTxOType tx
distributedOutputs)

  PartialFanoutState{HeadId
headId :: HeadId
$sel:headId:PartialFanoutState :: forall tx. PartialFanoutState tx -> HeadId
headId, ConfirmedSnapshot tx
confirmedSnapshot :: forall tx. PartialFanoutState tx -> ConfirmedSnapshot tx
confirmedSnapshot :: ConfirmedSnapshot tx
confirmedSnapshot, SnapshotVersion
version :: forall tx. PartialFanoutState tx -> SnapshotVersion
version :: 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 = NextFanoutStep tx -> Outcome tx
emitStep (ConfirmedSnapshot tx
-> SnapshotVersion
-> UTxOType tx
-> UTxOType tx
-> OnChainFanoutDatum
-> NextFanoutStep tx
forall tx.
IsTx tx =>
ConfirmedSnapshot tx
-> SnapshotVersion
-> UTxOType tx
-> UTxOType tx
-> OnChainFanoutDatum
-> NextFanoutStep tx
nextFanoutStep ConfirmedSnapshot tx
confirmedSnapshot SnapshotVersion
version UTxOType tx
remaining UTxOType tx
remaining OnChainFanoutDatum
DatumFanoutProgress)
      continue :: Outcome tx
continue
        -- The head's remaining set is now empty: emit the final (burning) step.
        -- This must happen regardless of mode — otherwise a selection that
        -- drains everything 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' ->
              NextFanoutStep tx -> Outcome tx
emitStep (ConfirmedSnapshot tx
-> SnapshotVersion
-> UTxOType tx
-> UTxOType tx
-> OnChainFanoutDatum
-> NextFanoutStep tx
forall tx.
IsTx tx =>
ConfirmedSnapshot tx
-> SnapshotVersion
-> UTxOType tx
-> UTxOType tx
-> OnChainFanoutDatum
-> NextFanoutStep tx
nextFanoutStep ConfirmedSnapshot tx
confirmedSnapshot SnapshotVersion
version UTxOType tx
sel' UTxOType tx
remaining OnChainFanoutDatum
DatumFanoutProgress)
            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
  emitStep :: NextFanoutStep tx -> Outcome tx
emitStep NextFanoutStep tx
step = NextFanoutStep tx
-> ConfirmedSnapshot tx
-> SnapshotVersion
-> HeadSeed
-> UTCTime
-> Outcome tx
forall tx.
IsTx tx =>
NextFanoutStep tx
-> ConfirmedSnapshot tx
-> SnapshotVersion
-> HeadSeed
-> UTCTime
-> Outcome tx
emitFanoutStep NextFanoutStep tx
step ConfirmedSnapshot tx
confirmedSnapshot SnapshotVersion
version HeadSeed
headSeed UTCTime
contestationDeadline

  PartialFanoutState{HeadId
$sel:headId:PartialFanoutState :: forall tx. PartialFanoutState tx -> HeadId
headId :: HeadId
headId, ConfirmedSnapshot tx
confirmedSnapshot :: forall tx. PartialFanoutState tx -> ConfirmedSnapshot tx
confirmedSnapshot :: ConfirmedSnapshot tx
confirmedSnapshot, SnapshotVersion
version :: 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
confirmedSnapshot :: forall tx. ClosedState tx -> ConfirmedSnapshot tx
confirmedSnapshot :: ConfirmedSnapshot tx
confirmedSnapshot, SnapshotVersion
version :: 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
-> Maybe (UTxOType tx) -> Maybe (UTxOType tx) -> UTxOType tx
forall a. Monoid a => a -> Maybe a -> Maybe a -> a
combinedUTxO UTxOType tx
utxo Maybe (UTxOType tx)
effectiveCommit 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
confirmedSnapshot :: 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
version :: 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
confirmedSnapshot :: 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
version :: 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
confirmedSnapshot :: 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
version :: SnapshotVersion
version :: SnapshotVersion
version
    }
 where
  PartialFanoutState{HeadParameters
$sel:parameters:PartialFanoutState :: forall tx. PartialFanoutState tx -> HeadParameters
parameters :: HeadParameters
parameters, ConfirmedSnapshot tx
confirmedSnapshot :: 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
version :: forall tx. PartialFanoutState tx -> SnapshotVersion
version :: SnapshotVersion
version} = PartialFanoutState tx
pfs

-- | The step this node is currently driving. 'Nothing' while a manual fanout
-- waits on the next selection, where nothing is pending.
currentFanoutStep :: IsTx tx => PartialFanoutState tx -> Maybe (NextFanoutStep tx)
currentFanoutStep :: forall tx.
IsTx tx =>
PartialFanoutState tx -> Maybe (NextFanoutStep tx)
currentFanoutStep PartialFanoutState{ConfirmedSnapshot tx
confirmedSnapshot :: forall tx. PartialFanoutState tx -> ConfirmedSnapshot tx
confirmedSnapshot :: ConfirmedSnapshot tx
confirmedSnapshot, SnapshotVersion
version :: forall tx. PartialFanoutState tx -> SnapshotVersion
version :: SnapshotVersion
version, 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} =
  case FanoutMode tx
mode of
    FanoutMode tx
AwaitingSelection -> Maybe (NextFanoutStep tx)
forall a. Maybe a
Nothing
    FanoutMode tx
AutoDrain -> NextFanoutStep tx -> Maybe (NextFanoutStep tx)
forall a. a -> Maybe a
Just (UTxOType tx -> NextFanoutStep tx
step UTxOType tx
remainingOutputs)
    DistributingSelection UTxOType tx
selection -> NextFanoutStep tx -> Maybe (NextFanoutStep tx)
forall a. a -> Maybe a
Just (UTxOType tx -> NextFanoutStep tx
step UTxOType tx
selection)
 where
  step :: UTxOType tx -> NextFanoutStep tx
step UTxOType tx
target = ConfirmedSnapshot tx
-> SnapshotVersion
-> UTxOType tx
-> UTxOType tx
-> OnChainFanoutDatum
-> NextFanoutStep tx
forall tx.
IsTx tx =>
ConfirmedSnapshot tx
-> SnapshotVersion
-> UTxOType tx
-> UTxOType tx
-> OnChainFanoutDatum
-> NextFanoutStep tx
nextFanoutStep ConfirmedSnapshot tx
confirmedSnapshot SnapshotVersion
version UTxOType tx
target UTxOType tx
remainingOutputs OnChainFanoutDatum
onChainDatum

  onChainDatum :: OnChainFanoutDatum
onChainDatum = UTxOType tx -> OnChainFanoutDatum
forall tx. IsTx tx => UTxOType tx -> OnChainFanoutDatum
onChainFanoutDatum UTxOType tx
distributedOutputs

-- | Whether a posted transaction is the one a given step posts, telling a failure
-- of the step this node is driving from one it has already moved past.
--
-- Compares the distributed set, not just the transaction shape, since two
-- selections can both be non-final steps. By content, because naming the same
-- outputs under other inputs is a valid way to ask for the same set.
matchesFanoutStep :: IsTx tx => NextFanoutStep tx -> PostChainTx tx -> Bool
matchesFanoutStep :: forall tx. IsTx tx => NextFanoutStep tx -> PostChainTx tx -> Bool
matchesFanoutStep NextFanoutStep tx
step PostChainTx tx
postChainTx =
  case (NextFanoutStep tx
step, PostChainTx tx
postChainTx) of
    -- Only one full fanout is ever in flight: it covers the whole head.
    (NextFanoutStep tx
FullFanoutStep, FanoutTx{}) -> Bool
True
    (FinalStep{UTxOType tx
$sel:stepDistribute:FinalStep :: forall tx. NextFanoutStep tx -> UTxOType tx
stepDistribute :: UTxOType tx
stepDistribute}, FinalPartialFanoutTx{UTxOType tx
utxoToDistribute :: UTxOType tx
$sel:utxoToDistribute:InitTx :: forall tx. PostChainTx tx -> UTxOType tx
utxoToDistribute}) -> UTxOType tx
utxoToDistribute UTxOType tx -> UTxOType tx -> Bool
forall tx. IsTx tx => UTxOType tx -> UTxOType tx -> Bool
`sameOutputs` UTxOType tx
stepDistribute
    (PartialStep{UTxOType tx
$sel:stepDistribute:FinalStep :: forall tx. NextFanoutStep tx -> UTxOType tx
stepDistribute :: UTxOType tx
stepDistribute}, PartialFanoutTx{UTxOType tx
$sel:utxoToDistribute:InitTx :: forall tx. PostChainTx tx -> UTxOType tx
utxoToDistribute :: UTxOType tx
utxoToDistribute}) -> UTxOType tx
utxoToDistribute UTxOType tx -> UTxOType tx -> Bool
forall tx. IsTx tx => UTxOType tx -> UTxOType tx -> Bool
`sameOutputs` UTxOType tx
stepDistribute
    (NextFanoutStep tx, 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

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

-- | The mode a recorded selection leaves the driver in. A selection covering the
-- whole remainder with nothing distributed yet is not distributed as a selection
-- at all: 'nextFanoutStep' routes it to a full fanout and the driver auto-drains
-- the rest, so that is the mode it has to be recorded under.
--
-- 'fanoutStepStateChange' never pairs the two - such a step is a
-- 'FullFanoutStep', recorded as 'HeadFanoutInitiated' - so this only normalises
-- a selection recorded before that routing existed and replayed here. Without it
-- the re-posts ('repostFanoutStep') would post the full fanout that
-- 'nextFanoutStep' decides on while the mode kept claiming a selection is being
-- distributed, which is what every 'HeadPartiallyFannedOut' then reports.
recordedSelectionMode ::
  IsTx tx =>
  -- | Distributed so far
  UTxOType tx ->
  -- | The head's full remaining set
  UTxOType tx ->
  -- | The recorded selection
  UTxOType tx ->
  FanoutMode tx
recordedSelectionMode :: forall tx.
IsTx tx =>
UTxOType tx -> UTxOType tx -> UTxOType tx -> FanoutMode tx
recordedSelectionMode UTxOType tx
distributed UTxOType tx
remaining UTxOType tx
selection
  | UTxOType tx -> Bool
forall tx. IsTx tx => UTxOType tx -> Bool
nullOutputs UTxOType tx
distributed Bool -> Bool -> Bool
&& UTxOType tx
selection UTxOType tx -> UTxOType tx -> Bool
forall tx. IsTx tx => UTxOType tx -> UTxOType tx -> Bool
`sameOutputs` UTxOType tx
remaining = FanoutMode tx
forall tx. FanoutMode tx
AutoDrain
  | Bool
otherwise = UTxOType tx -> FanoutMode tx
forall tx. UTxOType tx -> FanoutMode tx
DistributingSelection UTxOType tx
selection

-- | Post the transaction a decided 'NextFanoutStep' calls for. The chain layer
-- chunks a full fanout, and sizes a partial one, dynamically.
--
-- Transactions only: any accompanying state change belongs to the caller that
-- owns the head state, via 'fanoutStepStateChange'. That keeps this safe to call
-- where effects can be applied but state changes cannot, as in the startup
-- re-post in 'Hydra.Node.runHydraNode'.
emitFanoutStep ::
  IsTx tx =>
  -- | The step to emit, from 'nextFanoutStep'.
  NextFanoutStep tx ->
  ConfirmedSnapshot tx ->
  SnapshotVersion ->
  HeadSeed ->
  UTCTime ->
  Outcome tx
emitFanoutStep :: forall tx.
IsTx tx =>
NextFanoutStep tx
-> ConfirmedSnapshot tx
-> SnapshotVersion
-> HeadSeed
-> UTCTime
-> Outcome tx
emitFanoutStep NextFanoutStep tx
step ConfirmedSnapshot tx
confirmedSnapshot SnapshotVersion
version HeadSeed
headSeed UTCTime
contestationDeadline =
  case NextFanoutStep tx
step of
    FinalStep{UTxOType tx
$sel:stepDistribute:FinalStep :: forall tx. NextFanoutStep tx -> UTxOType tx
stepDistribute :: UTxOType tx
stepDistribute} ->
      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
stepDistribute
                , HeadSeed
$sel:headSeed:InitTx :: HeadSeed
headSeed :: HeadSeed
headSeed
                , UTCTime
$sel:contestationDeadline:InitTx :: UTCTime
contestationDeadline :: UTCTime
contestationDeadline
                }
          }
    NextFanoutStep tx
FullFanoutStep ->
      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}
    PartialStep{UTxOType tx
$sel:stepDistribute:FinalStep :: forall tx. NextFanoutStep tx -> UTxOType tx
stepDistribute :: UTxOType tx
stepDistribute, UTxOType tx
$sel:stepProof:FinalStep :: forall tx. NextFanoutStep tx -> UTxOType tx
stepProof :: UTxOType tx
stepProof} ->
      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
stepDistribute
                , $sel:utxoForProof:InitTx :: UTxOType tx
utxoForProof = UTxOType tx
stepProof
                , HeadSeed
$sel:headSeed:InitTx :: HeadSeed
headSeed :: HeadSeed
headSeed
                , UTCTime
$sel:contestationDeadline:InitTx :: UTCTime
contestationDeadline :: UTCTime
contestationDeadline
                }
          }

-- | 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).
--
-- Which step that is comes from 'currentFanoutStep', the same derivation the
-- revert guard uses to tell this step's failure from a superseded one's.
repostFanoutStep :: IsTx tx => PartialFanoutState tx -> Outcome tx
repostFanoutStep :: forall tx. IsTx tx => PartialFanoutState tx -> Outcome tx
repostFanoutStep PartialFanoutState tx
pfs =
  case PartialFanoutState tx -> Maybe (NextFanoutStep tx)
forall tx.
IsTx tx =>
PartialFanoutState tx -> Maybe (NextFanoutStep tx)
currentFanoutStep PartialFanoutState tx
pfs of
    -- Manual mode paused on the user: nothing to re-post, wait for the next
    -- 'PartialFanout' command.
    Maybe (NextFanoutStep tx)
Nothing -> Outcome tx
forall tx. Outcome tx
noop
    -- Only the transaction is re-posted: this node is the driver already, and
    -- re-posting is not a new decision to record. So this emits no state
    -- changes, which is what lets 'Hydra.Node.runHydraNode' apply its effects
    -- alone at startup.
    Just NextFanoutStep tx
step ->
      NextFanoutStep tx
-> ConfirmedSnapshot tx
-> SnapshotVersion
-> HeadSeed
-> UTCTime
-> Outcome tx
forall tx.
IsTx tx =>
NextFanoutStep tx
-> ConfirmedSnapshot tx
-> SnapshotVersion
-> HeadSeed
-> UTCTime
-> Outcome tx
emitFanoutStep NextFanoutStep tx
step ConfirmedSnapshot tx
confirmedSnapshot SnapshotVersion
version HeadSeed
headSeed UTCTime
contestationDeadline
 where
  PartialFanoutState{ConfirmedSnapshot tx
confirmedSnapshot :: forall tx. PartialFanoutState tx -> ConfirmedSnapshot tx
confirmedSnapshot :: ConfirmedSnapshot tx
confirmedSnapshot, SnapshotVersion
version :: 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} = 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)

-- | The deposit claimed by a retained finalized increment ('finalizedCommit'),
-- if any. Such a deposit only resurfaces in 'pendingDeposits' when a rollback
-- erased its increment, and it is settled solely by re-posting that increment
-- ('maybeRepostIncrementTx'): it must never be proposed for a snapshot again
-- (the deposited funds are already counted in the head) nor recovered (that
-- would corrupt the L2 ledger). See #2741.
finalizedDepositTxId :: IsTx tx => Maybe (FinalizedSnapshot tx) -> Maybe (TxIdType tx)
finalizedDepositTxId :: forall tx.
IsTx tx =>
Maybe (FinalizedSnapshot tx) -> Maybe (TxIdType tx)
finalizedDepositTxId Maybe (FinalizedSnapshot tx)
finalizedCommit = do
  FinalizedSnapshot{ConfirmedSnapshot tx
$sel:snapshot:FinalizedSnapshot :: forall tx. FinalizedSnapshot tx -> ConfirmedSnapshot tx
snapshot :: ConfirmedSnapshot tx
snapshot} <- Maybe (FinalizedSnapshot tx)
finalizedCommit
  (ConfirmedSnapshot tx -> Snapshot tx
forall tx. IsTx tx => ConfirmedSnapshot tx -> Snapshot tx
getSnapshot ConfirmedSnapshot tx
snapshot).depositTxId

-- | The deposits handlers of an open head may act on: scoped to the head and
-- excluding the deposit claimed by the retained finalized increment (see
-- 'finalizedDepositTxId').
eligibleDeposits :: IsTx tx => OpenState tx -> PendingDeposits tx -> PendingDeposits tx
eligibleDeposits :: forall tx.
IsTx tx =>
OpenState tx -> PendingDeposits tx -> PendingDeposits tx
eligibleDeposits 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} =
  (Map (TxIdType tx) (Deposit tx) -> Map (TxIdType tx) (Deposit tx))
-> (TxIdType tx
    -> Map (TxIdType tx) (Deposit tx)
    -> Map (TxIdType tx) (Deposit tx))
-> Maybe (TxIdType tx)
-> Map (TxIdType tx) (Deposit tx)
-> Map (TxIdType tx) (Deposit tx)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Map (TxIdType tx) (Deposit tx) -> Map (TxIdType tx) (Deposit tx)
forall a. a -> a
id TxIdType tx
-> Map (TxIdType tx) (Deposit tx) -> Map (TxIdType tx) (Deposit tx)
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete (Maybe (FinalizedSnapshot tx) -> Maybe (TxIdType tx)
forall tx.
IsTx tx =>
Maybe (FinalizedSnapshot tx) -> Maybe (TxIdType tx)
finalizedDepositTxId CoordinatedHeadState tx
coordinatedHeadState.finalizedCommit) (Map (TxIdType tx) (Deposit tx) -> Map (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 b c a. (b -> c) -> (a -> b) -> a -> c
. HeadId
-> Map (TxIdType tx) (Deposit tx) -> Map (TxIdType tx) (Deposit tx)
forall tx. HeadId -> PendingDeposits tx -> PendingDeposits tx
depositsForHead HeadId
headId

-- | The deposit blocked by a retained finalized increment of an open head, if
-- any.
--
-- Deliberately 'Nothing' for any other head state: an increment can only
-- settle into an open head, so once the head closes the retained snapshot can
-- never claim the deposit on-chain anymore. The resurfaced deposit's escape
-- hatch is then to recover it (after its deadline) and exclude the deposited
-- outputs from the fanout via 'PartialFanout' — so 'Recover' must not stay
-- blocked after close.
openFinalizedDeposit :: IsTx tx => HeadState tx -> Maybe (TxIdType tx)
openFinalizedDeposit :: forall tx. IsTx tx => HeadState tx -> Maybe (TxIdType tx)
openFinalizedDeposit = \case
  Open OpenState{$sel:coordinatedHeadState:OpenState :: forall tx. OpenState tx -> CoordinatedHeadState tx
coordinatedHeadState = CoordinatedHeadState{Maybe (FinalizedSnapshot tx)
$sel:finalizedCommit:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> Maybe (FinalizedSnapshot tx)
finalizedCommit :: Maybe (FinalizedSnapshot tx)
finalizedCommit}} -> Maybe (FinalizedSnapshot tx) -> Maybe (TxIdType tx)
forall tx.
IsTx tx =>
Maybe (FinalizedSnapshot tx) -> Maybe (TxIdType tx)
finalizedDepositTxId Maybe (FinalizedSnapshot tx)
finalizedCommit
  HeadState tx
_ -> Maybe (TxIdType tx)
forall a. Maybe a
Nothing

-- | Update the retained 'finalizedCommit' on (re-)observation of an increment
-- claiming @depositTxId@:
--
--   * the locally confirmed snapshot claims it: retain that snapshot — only it
--     can re-claim the deposit if a rollback erases the increment, and
--     'confirmedSnapshot' may advance past it;
--   * the already retained snapshot claims it: the increment re-landed (e.g.
--     re-posted after a rollback) — re-stamp the observation slot, so a
--     rollback of the re-landed increment still triggers a re-post;
--   * neither: the observation raced local snapshot confirmation (another
--     party collected the last AckSn and posted first) — retention happens
--     once the snapshot confirms, see the 'SnapshotConfirmed' branch of
--     'applyEvent'.
--
-- See #2741.
retainFinalizedCommit ::
  IsTx tx =>
  ChainSlot ->
  TxIdType tx ->
  ConfirmedSnapshot tx ->
  Maybe (FinalizedSnapshot tx) ->
  Maybe (FinalizedSnapshot tx)
retainFinalizedCommit :: forall tx.
IsTx tx =>
ChainSlot
-> TxIdType tx
-> ConfirmedSnapshot tx
-> Maybe (FinalizedSnapshot tx)
-> Maybe (FinalizedSnapshot tx)
retainFinalizedCommit ChainSlot
slot TxIdType tx
depositTxId ConfirmedSnapshot tx
confirmedSnapshot Maybe (FinalizedSnapshot tx)
retained
  | ConfirmedSnapshot tx -> Bool
claims ConfirmedSnapshot tx
confirmedSnapshot = FinalizedSnapshot tx -> Maybe (FinalizedSnapshot tx)
forall a. a -> Maybe a
Just FinalizedSnapshot{$sel:snapshot:FinalizedSnapshot :: ConfirmedSnapshot tx
snapshot = ConfirmedSnapshot tx
confirmedSnapshot, $sel:observedAtSlot:FinalizedSnapshot :: ChainSlot
observedAtSlot = ChainSlot
slot}
  | Just f :: FinalizedSnapshot tx
f@FinalizedSnapshot{ConfirmedSnapshot tx
$sel:snapshot:FinalizedSnapshot :: forall tx. FinalizedSnapshot tx -> ConfirmedSnapshot tx
snapshot :: ConfirmedSnapshot tx
snapshot} <- Maybe (FinalizedSnapshot tx)
retained, ConfirmedSnapshot tx -> Bool
claims ConfirmedSnapshot tx
snapshot = FinalizedSnapshot tx -> Maybe (FinalizedSnapshot tx)
forall a. a -> Maybe a
Just FinalizedSnapshot tx
f{observedAtSlot = slot}
  | Bool
otherwise = Maybe (FinalizedSnapshot tx)
retained
 where
  claims :: ConfirmedSnapshot tx -> Bool
claims ConfirmedSnapshot tx
s = (ConfirmedSnapshot tx -> Snapshot tx
forall tx. IsTx tx => ConfirmedSnapshot tx -> Snapshot tx
getSnapshot ConfirmedSnapshot tx
s).depositTxId 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

-- | Update the retained 'finalizedDecommit' on (re-)observation of a decrement
-- bumping to @newVersion@; the counterpart of 'retainFinalizedCommit'. A
-- snapshot is tied to the decrement by identity, not by merely carrying a
-- decommit: only the decrement of that very snapshot bumps the version to
-- exactly one past the snapshot's (with a second decommit racing, the locally
-- confirmed snapshot may still be the previous, already settled one).
retainFinalizedDecommit ::
  IsTx tx =>
  ChainSlot ->
  SnapshotVersion ->
  ConfirmedSnapshot tx ->
  Maybe (FinalizedSnapshot tx) ->
  Maybe (FinalizedSnapshot tx)
retainFinalizedDecommit :: forall tx.
IsTx tx =>
ChainSlot
-> SnapshotVersion
-> ConfirmedSnapshot tx
-> Maybe (FinalizedSnapshot tx)
-> Maybe (FinalizedSnapshot tx)
retainFinalizedDecommit ChainSlot
slot SnapshotVersion
newVersion ConfirmedSnapshot tx
confirmedSnapshot Maybe (FinalizedSnapshot tx)
retained
  | ConfirmedSnapshot tx -> Bool
settles ConfirmedSnapshot tx
confirmedSnapshot = FinalizedSnapshot tx -> Maybe (FinalizedSnapshot tx)
forall a. a -> Maybe a
Just FinalizedSnapshot{$sel:snapshot:FinalizedSnapshot :: ConfirmedSnapshot tx
snapshot = ConfirmedSnapshot tx
confirmedSnapshot, $sel:observedAtSlot:FinalizedSnapshot :: ChainSlot
observedAtSlot = ChainSlot
slot}
  | Just f :: FinalizedSnapshot tx
f@FinalizedSnapshot{ConfirmedSnapshot tx
$sel:snapshot:FinalizedSnapshot :: forall tx. FinalizedSnapshot tx -> ConfirmedSnapshot tx
snapshot :: ConfirmedSnapshot tx
snapshot} <- Maybe (FinalizedSnapshot tx)
retained, ConfirmedSnapshot tx -> Bool
settles ConfirmedSnapshot tx
snapshot = FinalizedSnapshot tx -> Maybe (FinalizedSnapshot tx)
forall a. a -> Maybe a
Just FinalizedSnapshot tx
f{observedAtSlot = slot}
  | Bool
otherwise = Maybe (FinalizedSnapshot tx)
retained
 where
  settles :: ConfirmedSnapshot tx -> Bool
settles ConfirmedSnapshot tx
s = Maybe (UTxOType tx) -> Bool
forall a. Maybe a -> Bool
isJust (ConfirmedSnapshot tx -> Snapshot tx
forall tx. IsTx tx => ConfirmedSnapshot tx -> Snapshot tx
getSnapshot ConfirmedSnapshot tx
s).utxoToDecommit Bool -> Bool -> Bool
&& (ConfirmedSnapshot tx -> Snapshot tx
forall tx. IsTx tx => ConfirmedSnapshot tx -> Snapshot tx
getSnapshot ConfirmedSnapshot tx
s).version SnapshotVersion -> SnapshotVersion -> SnapshotVersion
forall a. Num a => a -> a -> a
+ SnapshotVersion
1 SnapshotVersion -> SnapshotVersion -> Bool
forall a. Eq a => a -> a -> Bool
== SnapshotVersion
newVersion

-- | 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
  -- SECURITY: before anything else, in every head state and whether or not the
  -- node is in sync. An accumulator over more elements than the trusted setup
  -- supports has no commitment at all -- forcing it calls 'error', see
  -- 'Hydra.Tx.Accumulator.checkAccumulatorSize'. Almost every way this input
  -- can be turned away echoes it back to clients, and encoding that echo forces
  -- the accumulator: 'RejectedInputBecauseUnsynced' while catching up,
  -- 'CommandFailed' in a state that does not handle the command,
  -- 'SideLoadSnapshotRejected' from the open-state checks, 'UnhandledInput'.
  -- So an oversized snapshot has to be rejected here, ahead of all of them.
  --
  -- This is a backstop. The client API rejects such a snapshot before it is ever
  -- queued (see 'Hydra.API.ClientInput.validateClientInput'), which it must,
  -- since the node traces an input before the head logic sees it and tracing
  -- forces the accumulator too. That is also where a client gets a useful
  -- error. Reaching here means some new producer of 'SideLoadSnapshot' skipped
  -- that check, so this only has to be safe, not informative -- hence 'Error'
  -- via 'SideLoadSnapshotFailed', which carries the failure alone. Note this
  -- cannot go through 'sideLoadFailed': that emits a 'SideLoadSnapshotRejected'
  -- client message, which echoes the input.
  | ClientInput ClientInput tx
clientInput <- Input tx
ev
  , Left (Int
utxoCount, Int
maxAllowed) <- ClientInput tx -> Either (Int, Int) (ClientInput tx)
forall tx.
IsTx tx =>
ClientInput tx -> Either (Int, Int) (ClientInput tx)
validateClientInput ClientInput tx
clientInput =
      LogicError tx -> Outcome tx
forall tx. LogicError tx -> Outcome tx
Error (LogicError tx -> Outcome tx)
-> (SideLoadRequirementFailure tx -> LogicError tx)
-> SideLoadRequirementFailure tx
-> Outcome tx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SideLoadRequirementFailure tx -> LogicError tx
forall tx. SideLoadRequirementFailure tx -> LogicError tx
SideLoadSnapshotFailed (SideLoadRequirementFailure tx -> Outcome tx)
-> SideLoadRequirementFailure tx -> Outcome tx
forall a b. (a -> b) -> a -> b
$ SideLoadUTxOSetTooLarge{Int
utxoCount :: Int
$sel:utxoCount:SideLoadInitialSnapshotMismatch :: Int
utxoCount, Int
maxAllowed :: Int
$sel:maxAllowed:SideLoadInitialSnapshotMismatch :: Int
maxAllowed}
  | Bool
otherwise =
      case NodeState tx
nodeState of
        NodeCatchingUp{HeadState tx
headState :: HeadState tx
$sel:headState:NodeInSync :: forall tx. NodeState tx -> HeadState tx
headState, ChainPointTime
chainPointTime :: ChainPointTime
$sel:chainPointTime:NodeInSync :: forall tx. NodeState tx -> ChainPointTime
chainPointTime} ->
          Environment
-> Ledger tx
-> UTCTime
-> ChainPointTime
-> Map (TxIdType tx) (Deposit 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 NodeState tx
nodeState.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, ChainPointTime
$sel:chainPointTime:NodeInSync :: forall tx. NodeState tx -> ChainPointTime
chainPointTime :: ChainPointTime
chainPointTime} ->
          Environment
-> Ledger tx
-> UTCTime
-> ChainPointTime
-> Map (TxIdType tx) (Deposit 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 NodeState tx
nodeState.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 tx
openState, 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 (OpenState tx -> PendingDeposits tx -> PendingDeposits tx
forall tx.
IsTx tx =>
OpenState tx -> PendingDeposits tx -> PendingDeposits tx
eligibleDeposits OpenState tx
openState 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 :: forall tx. OnChainTx tx -> SnapshotVersion
newVersion :: 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
newVersion :: 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 (OpenState tx -> PendingDeposits tx -> PendingDeposits tx
forall tx.
IsTx tx =>
OpenState tx -> PendingDeposits tx -> PendingDeposits tx
eligibleDeposits OpenState tx
openState 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, HeadSeed
$sel:headSeed:OpenState :: forall tx. OpenState tx -> HeadSeed
headSeed :: HeadSeed
headSeed, HeadParameters
$sel:parameters:OpenState :: forall tx. OpenState tx -> HeadParameters
parameters :: HeadParameters
parameters, $sel:coordinatedHeadState:OpenState :: forall tx. OpenState tx -> CoordinatedHeadState tx
coordinatedHeadState = CoordinatedHeadState{Maybe (FinalizedSnapshot tx)
$sel:finalizedCommit:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> Maybe (FinalizedSnapshot tx)
finalizedCommit :: Maybe (FinalizedSnapshot tx)
finalizedCommit}}
    , 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}
            -- The finalized deposit observed *again* means a rollback erased
            -- both the deposit and its finalized increment, and the deposit tx
            -- just re-landed on the new chain. The increment re-post issued at
            -- rollback time necessarily failed (the deposit UTxO did not exist
            -- on the new chain yet) and is not retried anywhere else, while
            -- every alternative settlement of this deposit is deliberately
            -- blocked (see 'finalizedDepositTxId'): re-post the increment
            -- now that the deposit is on chain again, see #2741.
            Outcome tx -> Outcome tx -> Outcome tx
forall a. Semigroup a => a -> a -> a
<> case Maybe (FinalizedSnapshot tx)
finalizedCommit of
              Just FinalizedSnapshot{ConfirmedSnapshot tx
$sel:snapshot:FinalizedSnapshot :: forall tx. FinalizedSnapshot tx -> ConfirmedSnapshot tx
snapshot :: ConfirmedSnapshot tx
snapshot}
                | Maybe (FinalizedSnapshot tx) -> Maybe (TxIdType tx)
forall tx.
IsTx tx =>
Maybe (FinalizedSnapshot tx) -> Maybe (TxIdType tx)
finalizedDepositTxId Maybe (FinalizedSnapshot tx)
finalizedCommit 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 ->
                    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
                              , $sel:headId:InitTx :: HeadId
headId = HeadId
ourHeadId
                              , $sel:headParameters:InitTx :: HeadParameters
headParameters = HeadParameters
parameters
                              , $sel:incrementingSnapshot:InitTx :: ConfirmedSnapshot tx
incrementingSnapshot = ConfirmedSnapshot tx
snapshot
                              , TxIdType tx
$sel:depositTxId:InitTx :: TxIdType tx
depositTxId :: TxIdType tx
depositTxId
                              }
                        }
              Maybe (FinalizedSnapshot tx)
_ -> [StateChanged tx] -> [Effect tx] -> Outcome tx
forall tx. [StateChanged tx] -> [Effect tx] -> Outcome tx
Continue [] []
      | 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
  -- or already finalized past the rolled-back slot (#2741)
  ( 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
            , Maybe (FinalizedSnapshot tx)
$sel:finalizedCommit:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> Maybe (FinalizedSnapshot tx)
finalizedCommit :: Maybe (FinalizedSnapshot tx)
finalizedCommit
            , Maybe (FinalizedSnapshot tx)
finalizedDecommit :: forall tx. CoordinatedHeadState tx -> Maybe (FinalizedSnapshot tx)
finalizedDecommit :: Maybe (FinalizedSnapshot tx)
finalizedDecommit
            }
        }
    , 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
-> Maybe (FinalizedSnapshot tx)
-> ChainSlot
-> Outcome tx
forall tx.
IsTx tx =>
HeadSeed
-> HeadId
-> HeadParameters
-> PendingDeposits tx
-> ConfirmedSnapshot tx
-> Maybe (FinalizedSnapshot tx)
-> ChainSlot
-> 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 Maybe (FinalizedSnapshot tx)
finalizedCommit (ChainStateType tx -> ChainSlot
forall tx. IsChainState tx => ChainStateType tx -> ChainSlot
chainStateSlot ChainStateType tx
rolledBackChainState)
        Outcome tx -> Outcome tx -> Outcome tx
forall a. Semigroup a => a -> a -> a
<> HeadSeed
-> HeadId
-> HeadParameters
-> Maybe tx
-> ConfirmedSnapshot tx
-> Maybe (FinalizedSnapshot tx)
-> ChainSlot
-> Outcome tx
forall tx.
HeadSeed
-> HeadId
-> HeadParameters
-> Maybe tx
-> ConfirmedSnapshot tx
-> Maybe (FinalizedSnapshot tx)
-> ChainSlot
-> Outcome tx
maybeRepostDecrementTx HeadSeed
headSeed HeadId
headId HeadParameters
parameters Maybe tx
decommitTx ConfirmedSnapshot tx
confirmedSnapshot Maybe (FinalizedSnapshot tx)
finalizedDecommit (ChainStateType tx -> ChainSlot
forall tx. IsChainState tx => ChainStateType tx -> ChainSlot
chainStateSlot ChainStateType tx
rolledBackChainState)
  -- 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 tx
pfs, 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.
    --
    -- Only for a failure of the step this node is actually driving, of which
    -- 'AwaitingSelection' has none. A superseded transaction can still be in
    -- flight — a selection covering the whole remainder turns into a full fanout
    -- and leaves the earlier chunk behind — and reverting on its failure would
    -- drop the driver role for a transaction nobody is waiting on.
    | 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
    , UTxOType tx -> Bool
forall tx. IsTx tx => UTxOType tx -> Bool
nullOutputs UTxOType tx
distributedOutputs
    , Bool
-> (NextFanoutStep tx -> Bool) -> Maybe (NextFanoutStep tx) -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (NextFanoutStep tx -> PostChainTx tx -> Bool
forall tx. IsTx tx => NextFanoutStep tx -> PostChainTx tx -> Bool
`matchesFanoutStep` PostChainTx tx
postChainTx) (PartialFanoutState tx -> Maybe (NextFanoutStep tx)
forall tx.
IsTx tx =>
PartialFanoutState tx -> Maybe (NextFanoutStep tx)
currentFanoutStep PartialFanoutState tx
pfs) ->
        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 tx
openState, 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 (OpenState tx -> PendingDeposits tx -> PendingDeposits tx
forall tx.
IsTx tx =>
OpenState tx -> PendingDeposits tx -> PendingDeposits tx
eligibleDeposits OpenState tx
openState PendingDeposits tx
pendingDeposits) tx
tx
  -- NOTE: 'ReqSn' gets the unfiltered (per-head) deposits: it distinguishes a
  -- requested deposit that is blocked by a finalized increment (hard error)
  -- from one that is simply not known locally (wait).
  (Open openState :: OpenState tx
openState@OpenState{$sel:headId:OpenState :: forall tx. OpenState tx -> HeadId
headId = HeadId
ourHeadId}, NetworkInput TTL
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
-> TTL
-> Party
-> SnapshotVersion
-> SnapshotNumber
-> [TxIdType tx]
-> Maybe tx
-> Maybe (TxIdType tx)
-> Outcome tx
forall tx.
IsTx tx =>
Environment
-> Ledger tx
-> PendingDeposits tx
-> ChainSlot
-> OpenState tx
-> TTL
-> 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 TTL
ttl Party
sender SnapshotVersion
sv SnapshotNumber
sn [TxIdType tx]
txIds Maybe tx
decommitTx Maybe (TxIdType tx)
depositTxId
  (Open OpenState tx
openState, 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 (OpenState tx -> PendingDeposits tx -> PendingDeposits tx
forall tx.
IsTx tx =>
OpenState tx -> PendingDeposits tx -> PendingDeposits tx
eligibleDeposits OpenState tx
openState PendingDeposits tx
pendingDeposits) OpenState tx
openState Party
sender Signature (Snapshot tx)
snapshotSignature SnapshotNumber
sn
  (Open OpenState tx
openState, 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 (OpenState tx -> PendingDeposits tx -> PendingDeposits tx
forall tx.
IsTx tx =>
OpenState tx -> PendingDeposits tx -> PendingDeposits tx
eligibleDeposits OpenState tx
openState 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 :: forall tx. ClientInput tx -> tx
decommitTx :: 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
-> Maybe (TxIdType tx)
-> TxIdType tx
-> Outcome tx
forall tx.
IsTx tx =>
ChainSlot
-> PendingDeposits tx
-> Maybe (TxIdType tx)
-> TxIdType tx
-> Outcome tx
onClientRecover ChainSlot
currentSlot PendingDeposits tx
pendingDeposits (HeadState tx -> Maybe (TxIdType tx)
forall tx. IsTx tx => HeadState tx -> Maybe (TxIdType tx)
openFinalizedDeposit HeadState tx
st) 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 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{ChainStateType tx
$sel:chainState:NetworkConnected :: forall tx. StateChanged tx -> ChainStateType tx
chainState :: ChainStateType tx
chainState, 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} ->
              ChainSlot
-> TxIdType tx -> Deposit tx -> NodeState tx -> NodeState tx
forall tx.
IsTx tx =>
ChainSlot
-> TxIdType tx -> Deposit tx -> NodeState tx -> NodeState tx
recordDeposit (ChainStateType tx -> ChainSlot
forall tx. IsChainState tx => ChainStateType tx -> ChainSlot
chainStateSlot ChainStateType tx
chainState) TxIdType tx
depositTxId Deposit{HeadId
$sel:headId:Deposit :: HeadId
headId :: HeadId
headId, UTxOType tx
$sel:deposited:Deposit :: UTxOType tx
deposited :: UTxOType tx
deposited, UTCTime
$sel:created:Deposit :: UTCTime
created :: UTCTime
created, UTCTime
$sel:deadline:Deposit :: UTCTime
deadline :: UTCTime
deadline, $sel:status:Deposit :: DepositStatus
status = DepositStatus
Inactive} (NodeState tx -> NodeState tx) -> NodeState tx -> NodeState tx
forall a b. (a -> b) -> a -> b
$
                NodeState tx
nodeState{headState = 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} ->
              TxIdType tx -> Deposit tx -> NodeState tx -> NodeState tx
forall tx.
IsTx tx =>
TxIdType tx -> Deposit tx -> NodeState tx -> NodeState tx
updateDeposit TxIdType tx
depositTxId Deposit tx
deposit (NodeState tx -> NodeState tx) -> NodeState tx -> NodeState tx
forall a b. (a -> b) -> a -> b
$
                NodeState tx
nodeState{headState = st}
            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} ->
              -- NB: We keep expired deposits since we actually need them when Recovering.
              -- There is a corresponding error RequestedDepositExpired which gives users context on stale ReqSn.
              TxIdType tx -> Deposit tx -> NodeState tx -> NodeState tx
forall tx.
IsTx tx =>
TxIdType tx -> Deposit tx -> NodeState tx -> NodeState tx
updateDeposit TxIdType tx
depositTxId Deposit tx
deposit (NodeState tx -> NodeState tx) -> NodeState tx -> NodeState tx
forall a b. (a -> b) -> a -> b
$
                NodeState tx
nodeState{headState = st}
            DepositRecovered{ChainStateType tx
$sel:chainState:NetworkConnected :: forall tx. StateChanged tx -> ChainStateType tx
chainState :: ChainStateType tx
chainState, TxIdType tx
$sel:depositTxId:NetworkConnected :: forall tx. StateChanged tx -> TxIdType tx
depositTxId :: TxIdType tx
depositTxId} ->
              ChainSlot -> TxIdType tx -> NodeState tx -> NodeState tx
forall tx.
IsTx tx =>
ChainSlot -> TxIdType tx -> NodeState tx -> NodeState tx
consumeDeposit (ChainStateType tx -> ChainSlot
forall tx. IsChainState tx => ChainStateType tx -> ChainSlot
chainStateSlot ChainStateType tx
chainState) TxIdType tx
depositTxId (NodeState tx -> NodeState tx) -> NodeState tx -> NodeState tx
forall a b. (a -> b) -> a -> b
$
                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
                                    }
                              }
                      }
                  HeadState tx
_ ->
                    NodeState tx
nodeState{headState = st}
            CommitFinalized{ChainStateType tx
$sel:chainState:NetworkConnected :: forall tx. StateChanged tx -> ChainStateType tx
chainState :: ChainStateType tx
chainState, SnapshotVersion
newVersion :: forall tx. StateChanged tx -> SnapshotVersion
newVersion :: SnapshotVersion
newVersion, TxIdType tx
$sel:depositTxId:NetworkConnected :: forall tx. StateChanged tx -> TxIdType tx
depositTxId :: TxIdType tx
depositTxId} ->
              ChainSlot -> TxIdType tx -> NodeState tx -> NodeState tx
forall tx.
IsTx tx =>
ChainSlot -> TxIdType tx -> NodeState tx -> NodeState tx
consumeDeposit (ChainStateType tx -> ChainSlot
forall tx. IsChainState tx => ChainStateType tx -> ChainSlot
chainStateSlot ChainStateType tx
chainState) TxIdType tx
depositTxId (NodeState tx -> NodeState tx) -> NodeState tx -> NodeState tx
forall a b. (a -> b) -> a -> b
$ 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{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}}
                  -- Re-observation: the increment re-landed after a rollback
                  -- (the local 'version' never rolls back, so a 'newVersion'
                  -- not ahead of it means this finalization was applied
                  -- before). Only convergence bookkeeping: in particular
                  -- 'localUTxO' must not absorb the deposit again (its outputs
                  -- may have been spent on L2 in the meantime and the union
                  -- would resurrect them) and an unrelated deposit already
                  -- parked in 'currentDepositTxId' for the next snapshot must
                  -- be left alone. See #2741.
                  | SnapshotVersion
newVersion SnapshotVersion -> SnapshotVersion -> Bool
forall a. Ord a => a -> a -> Bool
<= CoordinatedHeadState tx
chs.version ->
                      NodeState tx
nodeState
                        { headState =
                            Open
                              os
                                { chainState
                                , coordinatedHeadState =
                                    chs
                                      { currentDepositTxId = mfilter (/= depositTxId) chs.currentDepositTxId
                                      , finalizedCommit = retainFinalizedCommit (chainStateSlot chainState) depositTxId confirmedSnapshot chs.finalizedCommit
                                      }
                                }
                        }
                  | Bool
otherwise ->
                      NodeState tx
nodeState
                        { headState =
                            Open
                              os
                                { chainState
                                , coordinatedHeadState =
                                    chs
                                      { version = newVersion
                                      , -- NOTE: This must correspond to the just finalized
                                        -- depositTxId, but we should not verify this here.
                                        currentDepositTxId = Nothing
                                      , localUTxO = localUTxO <> maybe mempty (.deposited) (Map.lookup depositTxId nodeState.pendingDeposits)
                                      , -- 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 = (ConfirmedSnapshot tx -> Snapshot tx
forall tx. IsTx tx => ConfirmedSnapshot tx -> Snapshot tx
getSnapshot ConfirmedSnapshot tx
confirmedSnapshot).number}
                                      , finalizedCommit = retainFinalizedCommit (chainStateSlot chainState) depositTxId confirmedSnapshot chs.finalizedCommit
                                      }
                                }
                        }
                HeadState tx
_ ->
                  NodeState tx
nodeState{headState = st}
            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} ->
              -- Deposits are L1-derived: restore the view at the rolled-back
              -- slot. Deposits whose consuming tx (increment/recover) was
              -- erased resurface, deposits whose deposit tx was erased vanish;
              -- forward re-observation converges the view again. See #2741.
              ChainSlot -> NodeState tx -> NodeState tx
forall tx. ChainSlot -> NodeState tx -> NodeState tx
rollbackDeposits (ChainStateType tx -> ChainSlot
forall tx. IsChainState tx => ChainStateType tx -> ChainSlot
chainStateSlot ChainStateType tx
chainState) (NodeState tx -> NodeState tx) -> NodeState tx -> NodeState tx
forall a b. (a -> b) -> a -> b
$
                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, $sel:deposits:NodeInSync :: TrackedDeposits tx
deposits = NodeState tx -> TrackedDeposits tx
forall tx. NodeState tx -> TrackedDeposits tx
deposits NodeState tx
nodeState, $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, $sel:deposits:NodeInSync :: TrackedDeposits tx
deposits = NodeState tx -> TrackedDeposits tx
forall tx. NodeState tx -> TrackedDeposits tx
deposits NodeState tx
nodeState, $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
              , $sel:finalizedCommit:CoordinatedHeadState :: Maybe (FinalizedSnapshot tx)
finalizedCommit = Maybe (FinalizedSnapshot tx)
forall a. Maybe a
Nothing
              , finalizedDecommit :: Maybe (FinalizedSnapshot tx)
finalizedDecommit = Maybe (FinalizedSnapshot tx)
forall a. Maybe a
Nothing
              }
        , 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{ChainStateType tx
$sel:chainState:OpenState :: forall tx. OpenState tx -> ChainStateType tx
chainState :: ChainStateType tx
chainState, $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, SnapshotVersion
$sel:version:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> SnapshotVersion
version :: SnapshotVersion
version}} ->
        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 ->
            -- The snapshot's settling transaction (increment/decrement) may
            -- have been observed on chain *before* this local confirmation
            -- (another party collected the last AckSn and posted first) —
            -- recognizable by 'version' already bumped one past the
            -- snapshot's. Nothing could be retained at observation time (see
            -- 'retainFinalizedCommit'), so retain now. The current chain slot
            -- over-approximates the observation slot, which errs towards
            -- re-posting on rollback (harmless noise) rather than staying
            -- silent when the settlement was erased.
            let confirmed :: ConfirmedSnapshot tx
confirmed = 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}
                retainIfSettled :: Bool
-> Maybe (FinalizedSnapshot tx) -> Maybe (FinalizedSnapshot tx)
retainIfSettled Bool
settles Maybe (FinalizedSnapshot tx)
retained
                  | SnapshotVersion
version SnapshotVersion -> SnapshotVersion -> Bool
forall a. Eq a => a -> a -> Bool
== Snapshot tx
snapshot.version SnapshotVersion -> SnapshotVersion -> SnapshotVersion
forall a. Num a => a -> a -> a
+ SnapshotVersion
1 Bool -> Bool -> Bool
&& Bool
settles =
                      FinalizedSnapshot tx -> Maybe (FinalizedSnapshot tx)
forall a. a -> Maybe a
Just FinalizedSnapshot{$sel:snapshot:FinalizedSnapshot :: ConfirmedSnapshot tx
snapshot = ConfirmedSnapshot tx
confirmed, $sel:observedAtSlot:FinalizedSnapshot :: ChainSlot
observedAtSlot = ChainStateType tx -> ChainSlot
forall tx. IsChainState tx => ChainStateType tx -> ChainSlot
chainStateSlot ChainStateType tx
chainState}
                  | Bool
otherwise = Maybe (FinalizedSnapshot tx)
retained
             in OpenState tx -> HeadState tx
forall tx. OpenState tx -> HeadState tx
Open
                  OpenState tx
os
                    { coordinatedHeadState =
                        chs
                          { confirmedSnapshot = confirmed
                          , seenSnapshot = LastSeenSnapshot snapshot.number
                          , finalizedCommit =
                              retainIfSettled (isJust snapshot.utxoToCommit && isJust snapshot.depositTxId) chs.finalizedCommit
                          , finalizedDecommit =
                              retainIfSettled (isJust snapshot.utxoToDecommit) chs.finalizedDecommit
                          }
                    }
          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
              -- The finalized deposit can be re-activated when a rollback rewinds
              -- the deposit view to before its activation: never park it in
              -- 'currentDepositTxId' — it is settled by re-posting the increment,
              -- not by a new snapshot, see 'finalizedDepositTxId' and #2741.
              | Maybe (FinalizedSnapshot tx) -> Maybe (TxIdType tx)
forall tx.
IsTx tx =>
Maybe (FinalizedSnapshot tx) -> Maybe (TxIdType tx)
finalizedDepositTxId CoordinatedHeadState tx
chs.finalizedCommit 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 -> HeadState tx
st
              | Bool
otherwise -> 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
newVersion :: 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 = chs :: CoordinatedHeadState tx
chs@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}}
        -- Re-observation: the decrement re-landed after a rollback (the local
        -- 'version' never rolls back, so a 'newVersion' not ahead of it means
        -- this finalization was applied before). Only convergence bookkeeping:
        -- in particular an unrelated newer decommit may already be in flight
        -- and must be left alone. See #2741.
        | SnapshotVersion
newVersion SnapshotVersion -> SnapshotVersion -> Bool
forall a. Ord a => a -> a -> Bool
<= CoordinatedHeadState tx
chs.version ->
            OpenState tx -> HeadState tx
forall tx. OpenState tx -> HeadState tx
Open
              OpenState tx
os
                { chainState
                , coordinatedHeadState =
                    chs{finalizedDecommit = retainFinalizedDecommit (chainStateSlot chainState) newVersion confirmedSnapshot chs.finalizedDecommit}
                }
        | Bool
otherwise ->
            OpenState tx -> HeadState tx
forall tx. OpenState tx -> HeadState tx
Open
              OpenState tx
os
                { chainState
                , coordinatedHeadState =
                    chs
                      { 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 = (ConfirmedSnapshot tx -> Snapshot tx
forall tx. IsTx tx => ConfirmedSnapshot tx -> Snapshot tx
getSnapshot ConfirmedSnapshot tx
confirmedSnapshot).number}
                      , -- Retain the signed decrementing snapshot: if a rollback
                        -- erases the just observed decrement, 'confirmedSnapshot'
                        -- may have advanced past it and this is the only snapshot
                        -- that can settle the decommit on-chain.
                        finalizedDecommit = retainFinalizedDecommit (chainStateSlot chainState) newVersion confirmedSnapshot chs.finalizedDecommit
                      }
                }
      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
confirmedSnapshot :: 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
version :: 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
confirmedSnapshot :: 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
version :: 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
confirmedSnapshot :: 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
version :: 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
      -- A target covering the whole remainder before anything landed is a full
      -- fanout too ('nextFanoutStep'), so the driver switches to draining
      -- automatically.
      FanoutProgress PartialFanoutState tx
pfs -> PartialFanoutState tx -> HeadState tx
forall tx. PartialFanoutState tx -> HeadState tx
FanoutProgress PartialFanoutState tx
pfs{mode = AutoDrain, remainingOutputs}
      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 -> UTxOType tx -> UTxOType tx -> FanoutMode tx
forall tx.
IsTx tx =>
UTxOType tx -> UTxOType tx -> UTxOType tx -> FanoutMode tx
recordedSelectionMode UTxOType tx
forall a. Monoid a => a
mempty UTxOType tx
remainingOutputs UTxOType tx
selection)
      -- Continuing: just record the new active selection.
      FanoutProgress pfs :: PartialFanoutState tx
pfs@PartialFanoutState{UTxOType tx
$sel:distributedOutputs:PartialFanoutState :: forall tx. PartialFanoutState tx -> UTxOType tx
distributedOutputs :: UTxOType tx
distributedOutputs} ->
        PartialFanoutState tx -> HeadState tx
forall tx. PartialFanoutState tx -> HeadState tx
FanoutProgress PartialFanoutState tx
pfs{mode = recordedSelectionMode distributedOutputs remainingOutputs 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