{-# 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 (AccumulatorTooLarge (..))
import Hydra.Tx.Accumulator qualified as Accumulator
import Hydra.Tx.Crypto (
  MultiSignature,
  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.
--
-- 4000 was chosen from backlog-drain sweeps at caps 1000 to 8000 (see
-- hydra-cluster/bench/BASELINES.md): per-round costs scale with the backlog,
-- so under sustained overload larger caps drain strictly faster (2.7x at
-- 4000 vs 1000 on a 24k-tx backlog) with lower confirmation latency and
-- lower peak memory, while the cap never binds under light load. Gains taper
-- beyond 4000 and worst-case round size keeps growing (ReqSn bytes, failed
-- round rework, follower reapply stall), so we stop at roughly 10x below
-- etcd's 1.5MiB request limit, which a too-large ReqSn would wedge on.
maxTxsPerSnapshot :: Int
maxTxsPerSnapshot :: Int
maxTxsPerSnapshot = Int
4000

-- ** 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 ::
  forall tx.
  IsTx tx =>
  Environment ->
  Ledger tx ->
  ChainPointTime ->
  OpenState tx ->
  TTL ->
  PendingDeposits tx ->
  -- | The transaction to be submitted to the head.
  tx ->
  Outcome tx
onOpenNetworkReqTx :: forall tx.
IsTx tx =>
Environment
-> Ledger tx
-> ChainPointTime
-> OpenState tx
-> TTL
-> PendingDeposits tx
-> tx
-> Outcome tx
onOpenNetworkReqTx Environment
env Ledger tx
ledger ChainPointTime{ChainSlot
currentSlot :: ChainSlot
$sel:currentSlot:ChainPointTime :: ChainPointTime -> ChainSlot
currentSlot, UTCTime
currentChainTime :: UTCTime
$sel:currentChainTime:ChainPointTime :: ChainPointTime -> UTCTime
currentChainTime} 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 Ledger tx
-> ChainSlot
-> UTxOType tx
-> [tx]
-> Either (tx, ValidationError) (UTxOType tx)
forall tx.
IsTx tx =>
Ledger tx
-> ChainSlot
-> UTxOType tx
-> [tx]
-> Either (tx, ValidationError) (UTxOType tx)
applyTransactionsWithoutCollision Ledger tx
ledger ChainSlot
currentSlot UTxOType tx
localUTxO [tx
tx] of
      Right UTxOType tx
_
        -- Refuse a tx creating an output that a claimable or settling deposit
        -- names: it would collide with that deposit once absorbed, and no node
        -- signs a snapshot carrying both. Expired deposits are never claimed, so
        -- they do not count.
        | UTxOType tx -> UTxOType tx -> Bool
forall tx. IsTx tx => UTxOType tx -> UTxOType tx -> Bool
namesNoneOf (tx -> UTxOType tx
forall tx. IsTx tx => tx -> UTxOType tx
utxoFromTx tx
tx) UTxOType tx
namedByDepositsInPlay -> Outcome tx
cont
        | Bool
otherwise -> ValidationError -> Outcome tx
notApplicable (Text -> ValidationError
ValidationError Text
"transaction creates an output a pending deposit names")
      Left (tx
_, ValidationError
err) -> ValidationError -> Outcome tx
notApplicable ValidationError
err
   where
    namedByDepositsInPlay :: UTxOType tx
    namedByDepositsInPlay :: UTxOType tx
namedByDepositsInPlay =
      (Deposit tx -> UTxOType tx) -> PendingDeposits tx -> UTxOType tx
forall m a. Monoid m => (a -> m) -> Map (TxIdType tx) a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (.deposited) ((Deposit tx -> Bool) -> PendingDeposits tx -> PendingDeposits tx
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (\Deposit{DepositStatus
status :: DepositStatus
$sel:status:Deposit :: forall tx. Deposit tx -> DepositStatus
status} -> DepositStatus
status DepositStatus -> DepositStatus -> Bool
forall a. Eq a => a -> a -> Bool
/= DepositStatus
Expired) PendingDeposits tx
pendingDeposits)
        UTxOType tx -> UTxOType tx -> UTxOType tx
forall a. Semigroup a => a -> a -> a
<> case Maybe (SettlingCommit tx)
settlingCommit of
          Just (ContinueCommit (TxIdType tx
_, Deposit{UTxOType tx
deposited :: UTxOType tx
$sel:deposited:Deposit :: forall tx. Deposit tx -> UTxOType tx
deposited})) -> UTxOType tx
deposited
          Maybe (SettlingCommit tx)
_ -> UTxOType tx
forall a. Monoid a => a
mempty

    notApplicable :: ValidationError -> Outcome tx
    notApplicable :: ValidationError -> Outcome tx
notApplicable 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 =
    -- The request includes this tx. It is checked against the same UTxO the
    -- followers use to check it, so they do not reject it.
    case UTxOType tx
-> Seq tx
-> PendingDeposits tx
-> Maybe (TxIdType tx)
-> Maybe tx
-> Maybe (SettlingCommit tx)
-> Maybe (SnapshotRequest tx)
forall tx.
IsTx tx =>
UTxOType tx
-> Seq tx
-> PendingDeposits tx
-> Maybe (TxIdType tx)
-> Maybe tx
-> Maybe (SettlingCommit tx)
-> Maybe (SnapshotRequest tx)
chainedSnapshotRequest UTxOType tx
confirmedUTxO Seq tx
localTxs' PendingDeposits tx
pendingDeposits Maybe (TxIdType tx)
currentDepositTxId Maybe tx
decommitTx Maybe (SettlingCommit tx)
settlingCommit of
      Just SnapshotRequest{[tx]
requestTxs :: [tx]
$sel:requestTxs:SnapshotRequest :: forall tx. SnapshotRequest tx -> [tx]
requestTxs, Maybe tx
requestDecommitTx :: Maybe tx
$sel:requestDecommitTx:SnapshotRequest :: forall tx. SnapshotRequest tx -> Maybe tx
requestDecommitTx, Maybe (TxIdType tx)
requestDepositTxId :: Maybe (TxIdType tx)
$sel:requestDepositTxId:SnapshotRequest :: forall tx. SnapshotRequest tx -> Maybe (TxIdType tx)
requestDepositTxId}
        | 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 ->
            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
$ 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 (tx -> TxIdType tx
forall tx. IsTx tx => tx -> TxIdType tx
txId (tx -> TxIdType tx) -> [tx] -> [TxIdType tx]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [tx]
requestTxs) Maybe tx
requestDecommitTx Maybe (TxIdType tx)
requestDepositTxId)
      Maybe (SnapshotRequest tx)
_ -> Outcome tx
outcome

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

  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

  confirmedUTxO :: UTxOType tx
confirmedUTxO = SnapshotVersion -> Snapshot tx -> UTxOType tx
forall tx. IsTx tx => SnapshotVersion -> Snapshot tx -> UTxOType tx
settledUTxO SnapshotVersion
version (ConfirmedSnapshot tx -> Snapshot tx
forall tx. IsTx tx => ConfirmedSnapshot tx -> Snapshot tx
getSnapshot ConfirmedSnapshot tx
confirmedSnapshot)

  settlingCommit :: Maybe (SettlingCommit tx)
settlingCommit = Environment
-> SnapshotVersion
-> UTCTime
-> PendingDeposits tx
-> Snapshot tx
-> Maybe (SettlingCommit tx)
forall tx.
IsTx tx =>
Environment
-> SnapshotVersion
-> UTCTime
-> PendingDeposits tx
-> Snapshot tx
-> Maybe (SettlingCommit tx)
settlingCommitAt Environment
env SnapshotVersion
version UTCTime
currentChainTime PendingDeposits tx
pendingDeposits (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 ::
  forall tx.
  IsTx tx =>
  Environment ->
  Ledger tx ->
  PendingDeposits tx ->
  ChainPointTime ->
  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
-> ChainPointTime
-> OpenState tx
-> TTL
-> Party
-> SnapshotVersion
-> SnapshotNumber
-> [TxIdType tx]
-> Maybe tx
-> Maybe (TxIdType tx)
-> Outcome tx
onOpenNetworkReqSn Environment
env Ledger tx
ledger PendingDeposits tx
pendingDeposits ChainPointTime{ChainSlot
$sel:currentSlot:ChainPointTime :: ChainPointTime -> ChainSlot
currentSlot :: ChainSlot
currentSlot, UTCTime
$sel:currentChainTime:ChainPointTime :: ChainPointTime -> UTCTime
currentChainTime :: UTCTime
currentChainTime} 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
activeUTxO, Maybe (UTxOType tx)
mUtxoToDecommit) ->
          -- Wait for the deposit and require any pending commit to be consistent
          (Maybe (UTxOType tx) -> Outcome tx) -> Outcome tx
waitForDeposit ((Maybe (UTxOType tx) -> Outcome tx) -> Outcome tx)
-> (Maybe (UTxOType tx) -> Outcome tx) -> Outcome tx
forall a b. (a -> b) -> a -> b
$ \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 = ∅ ∧ 𝑈_𝛼 ∩ outputs(Treq) = ∅
              --       require 𝑈_active ◦ Treq ≠ ⊥
              --       𝑈 ← 𝑈_active ◦ Treq
              UTxOType tx
-> Maybe (UTxOType tx)
-> [tx]
-> (UTxOType tx -> Outcome tx)
-> Outcome tx
requireApplyTxs UTxOType tx
activeUTxO Maybe (UTxOType tx)
mUtxoToCommit [tx]
requestedTxs ((UTxOType tx -> Outcome tx) -> Outcome tx)
-> (UTxOType tx -> Outcome tx) -> Outcome tx
forall a b. (a -> b) -> a -> b
$ \UTxOType tx
nextUTxO ->
                -- 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.
                let 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
requireValidAccumulatorSize HydraAccumulator
accumulator (Outcome tx -> Outcome tx) -> Outcome tx -> Outcome tx
forall a b. (a -> b) -> a -> b
$ 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
                        --
                        -- NOTE: 'SnapshotRequested' rebuilds 'localUTxO' from
                        -- 'nextUTxO', so every kept tx applies there.
                        let newLocalTxs :: Seq tx
newLocalTxs = UTxOType tx -> Seq tx
pruneTransactions UTxOType tx
nextUTxO
                        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

  -- Resolve the requested deposit into the snapshot's 'utxoToCommit'. It is
  -- not added to the active UTxO: a deposit is not spendable on L2 until its
  -- increment lands, otherwise a requested tx could spend it and the snapshot
  -- would count its value twice.
  waitForDeposit :: (Maybe (UTxOType tx) -> Outcome tx) -> Outcome tx
waitForDeposit Maybe (UTxOType tx) -> Outcome tx
cont =
    case Maybe (TxIdType tx)
mDepositTxId of
      -- A request without a deposit drops the commit the confirmed snapshot is
      -- settling. Allow that only once its increment can no longer land
      -- ('DropCommit'), otherwise the head ends up over-backed. Wait instead of
      -- failing: this node may be behind the leader's chain view ('Hydra.Node'
      -- keeps this wait beyond the ttl).
      Maybe (TxIdType tx)
Nothing ->
        case Environment
-> SnapshotVersion
-> UTCTime
-> PendingDeposits tx
-> Snapshot tx
-> Maybe (SettlingCommit tx)
forall tx.
IsTx tx =>
Environment
-> SnapshotVersion
-> UTCTime
-> PendingDeposits tx
-> Snapshot tx
-> Maybe (SettlingCommit tx)
settlingCommitAt Environment
env SnapshotVersion
version UTCTime
currentChainTime PendingDeposits tx
pendingDeposits (ConfirmedSnapshot tx -> Snapshot tx
forall tx. IsTx tx => ConfirmedSnapshot tx -> Snapshot tx
getSnapshot ConfirmedSnapshot tx
confirmedSnapshot) of
          Just (ContinueCommit (TxIdType tx
_, Deposit{UTxOType tx
$sel:deposited:Deposit :: forall tx. Deposit tx -> UTxOType tx
deposited :: UTxOType tx
deposited})) -> WaitReason tx -> Outcome tx
forall tx. WaitReason tx -> Outcome tx
wait WaitOnUnresolvedCommit{$sel:commitUTxO:WaitOnNotApplicableTx :: UTxOType tx
commitUTxO = UTxOType tx
deposited}
          Maybe (SettlingCommit tx)
_ -> Maybe (UTxOType tx) -> Outcome tx
cont 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 'scopedDeposits'). 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
$sel:status:Deposit :: forall tx. Deposit tx -> DepositStatus
status :: DepositStatus
status, UTxOType tx
$sel:deposited:Deposit :: forall tx. Deposit tx -> UTxOType tx
deposited :: 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}
            -- NOTE: this makes the commits sequential in a sense that you can't
            -- commit unless the previous commit is settled.
            | 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 ->
                -- 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.
                --
                -- Accepted even if the deposit is 'Expired': its increment
                -- may still land.
                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 Maybe (UTxOType tx) -> Outcome tx
cont 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
            | 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 -> Maybe (UTxOType tx) -> Outcome tx
cont (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
      -- A request without a decommit drops the one the confirmed snapshot is
      -- settling. Unlike a settling commit (see 'waitForDeposit'), a decommit
      -- is never dropped: its decrement is re-posted with every snapshot
      -- carrying it, and a leader stops carrying it only once it observed
      -- the decrement, at the bumped version. Signing such a request would
      -- leave the decommitted outputs in no confirmed snapshot once the
      -- decrement lands (a deposit claimed in their place would also race it
      -- for the version bump), so the head could not be closed and fanned
      -- out from any snapshot the honest nodes hold.
      Maybe tx
Nothing
        | 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 ->
            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
        | Bool
otherwise -> (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
      -- 'nextSnapshotRequest'), 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.
  --
  -- A claimed deposit must also be 'absorbable' next to the requested txs.
  requireApplyTxs :: UTxOType tx -> Maybe (UTxOType tx) -> [tx] -> (UTxOType tx -> Outcome tx) -> Outcome tx
  requireApplyTxs :: UTxOType tx
-> Maybe (UTxOType tx)
-> [tx]
-> (UTxOType tx -> Outcome tx)
-> Outcome tx
requireApplyTxs UTxOType tx
utxo Maybe (UTxOType tx)
mUtxoToCommit' [tx]
requestedTxs UTxOType tx -> Outcome tx
cont
    | Just TxIdType tx
depositTxId <- Maybe (TxIdType tx)
mDepositTxId
    , Just UTxOType tx
deposited <- Maybe (UTxOType tx)
mUtxoToCommit'
    , Bool -> Bool
not (UTxOType tx -> [tx] -> UTxOType tx -> Bool
forall tx. IsTx tx => UTxOType tx -> [tx] -> UTxOType tx -> Bool
absorbable UTxOType tx
utxo [tx]
requestedTxs UTxOType tx
deposited) =
        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 ReqSnDepositOutputsHeld{TxIdType tx
$sel:depositTxId:ReqSnNumberInvalid :: TxIdType tx
depositTxId :: TxIdType tx
depositTxId}
    | Bool
otherwise =
        -- Spec: require outputs(Treq) ∩ 𝑈_active = ∅
        case Ledger tx
-> ChainSlot
-> UTxOType tx
-> [tx]
-> Either (tx, ValidationError) (UTxOType tx)
forall tx.
IsTx tx =>
Ledger tx
-> ChainSlot
-> UTxOType tx
-> [tx]
-> Either (tx, ValidationError) (UTxOType tx)
applyTransactionsWithoutCollision 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 :: HydraAccumulator -> Outcome tx -> Outcome tx
requireValidAccumulatorSize HydraAccumulator
accumulator Outcome tx
continue =
    case HydraAccumulator -> Either AccumulatorTooLarge ()
Accumulator.checkAccumulatorSize HydraAccumulator
accumulator of
      Left AccumulatorTooLarge{Int
utxoCount :: Int
$sel:utxoCount:AccumulatorTooLarge :: AccumulatorTooLarge -> Int
utxoCount, Int
maxAllowed :: Int
$sel:maxAllowed:AccumulatorTooLarge :: AccumulatorTooLarge -> Int
maxAllowed} ->
        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 ReqSnUTxOSetTooLarge{Int
utxoCount :: Int
$sel:utxoCount:ReqSnNumberInvalid :: Int
utxoCount, Int
maxAllowed :: Int
$sel:maxAllowed:ReqSnNumberInvalid :: Int
maxAllowed}
      Right () -> 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.
IsTx tx =>
Ledger tx
-> ChainSlot
-> UTxOType tx
-> [tx]
-> Either (tx, ValidationError) (UTxOType tx)
applyTransactionsWithoutCollision 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 = SnapshotVersion -> Snapshot tx -> UTxOType tx
forall tx. IsTx tx => SnapshotVersion -> Snapshot tx -> UTxOType tx
settledUTxO SnapshotVersion
version (ConfirmedSnapshot tx -> Snapshot tx
forall tx. IsTx tx => ConfirmedSnapshot tx -> Snapshot tx
getSnapshot ConfirmedSnapshot tx
confirmedSnapshot)

  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 ->
  ChainPointTime ->
  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
-> ChainPointTime
-> PendingDeposits tx
-> OpenState tx
-> Party
-> Signature (Snapshot tx)
-> SnapshotNumber
-> Outcome tx
onOpenNetworkAckSn env :: Environment
env@Environment{Party
$sel:party:Environment :: Environment -> Party
party :: Party
party} ChainPointTime{UTCTime
$sel:currentChainTime:ChainPointTime :: ChainPointTime -> UTCTime
currentChainTime :: UTCTime
currentChainTime} 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 =
    -- Checked against the snapshot just confirmed: the followers check the
    -- request against that snapshot too.
    case UTxOType tx
-> Seq tx
-> PendingDeposits tx
-> Maybe (TxIdType tx)
-> Maybe tx
-> Maybe (SettlingCommit tx)
-> Maybe (SnapshotRequest tx)
forall tx.
IsTx tx =>
UTxOType tx
-> Seq tx
-> PendingDeposits tx
-> Maybe (TxIdType tx)
-> Maybe tx
-> Maybe (SettlingCommit tx)
-> Maybe (SnapshotRequest tx)
chainedSnapshotRequest (SnapshotVersion -> Snapshot tx -> UTxOType tx
forall tx. IsTx tx => SnapshotVersion -> Snapshot tx -> UTxOType tx
settledUTxO SnapshotVersion
version Snapshot tx
previous) Seq tx
localTxs PendingDeposits tx
pendingDeposits Maybe (TxIdType tx)
currentDepositTxId Maybe tx
decommitTx (Environment
-> SnapshotVersion
-> UTCTime
-> PendingDeposits tx
-> Snapshot tx
-> Maybe (SettlingCommit tx)
forall tx.
IsTx tx =>
Environment
-> SnapshotVersion
-> UTCTime
-> PendingDeposits tx
-> Snapshot tx
-> Maybe (SettlingCommit tx)
settlingCommitAt Environment
env SnapshotVersion
version UTCTime
currentChainTime PendingDeposits tx
pendingDeposits Snapshot tx
previous) of
      Just SnapshotRequest{[tx]
$sel:requestTxs:SnapshotRequest :: forall tx. SnapshotRequest tx -> [tx]
requestTxs :: [tx]
requestTxs, Maybe tx
$sel:requestDecommitTx:SnapshotRequest :: forall tx. SnapshotRequest tx -> Maybe tx
requestDecommitTx :: Maybe tx
requestDecommitTx, Maybe (TxIdType tx)
$sel:requestDepositTxId:SnapshotRequest :: forall tx. SnapshotRequest tx -> Maybe (TxIdType tx)
requestDepositTxId :: Maybe (TxIdType tx)
requestDepositTxId}
        | HeadParameters -> Party -> SnapshotNumber -> Bool
isLeader HeadParameters
parameters Party
party SnapshotNumber
nextSn ->
            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 (tx -> TxIdType tx
forall tx. IsTx tx => tx -> TxIdType tx
txId (tx -> TxIdType tx) -> [tx] -> [TxIdType tx]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [tx]
requestTxs) Maybe tx
requestDecommitTx Maybe (TxIdType tx)
requestDepositTxId)
      Maybe (SnapshotRequest tx)
_ -> Outcome tx
outcome
   where
    nextSn :: SnapshotNumber
nextSn = Snapshot tx
previous.number SnapshotNumber -> SnapshotNumber -> SnapshotNumber
forall a. Num a => a -> a -> a
+ SnapshotNumber
1

  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 ->
  ChainPointTime ->
  PendingDeposits tx ->
  OpenState tx ->
  tx ->
  Outcome tx
onOpenNetworkReqDec :: forall tx.
IsTx tx =>
Environment
-> Ledger tx
-> TTL
-> ChainPointTime
-> PendingDeposits tx
-> OpenState tx
-> tx
-> Outcome tx
onOpenNetworkReqDec Environment
env Ledger tx
ledger TTL
ttl ChainPointTime{ChainSlot
$sel:currentSlot:ChainPointTime :: ChainPointTime -> ChainSlot
currentSlot :: ChainSlot
currentSlot, UTCTime
$sel:currentChainTime:ChainPointTime :: ChainPointTime -> UTCTime
currentChainTime :: UTCTime
currentChainTime} 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.
  --
  -- The decommit waits if the next snapshot request would include a deposit.
  waitOnApplicableDecommit :: Outcome tx -> Outcome tx
waitOnApplicableDecommit Outcome tx
cont
    | Just TxIdType tx
depositTxId <- Maybe (TxIdType tx)
requestDepositTxId
    , Just Deposit{$sel:deposited:Deposit :: forall tx. Deposit tx -> UTxOType tx
deposited = UTxOType tx
commitUTxO} <- 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 =
        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
$sel:commitUTxO:WaitOnNotApplicableTx :: UTxOType tx
commitUTxO :: 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}
                    }

  -- May carry a settling commit instead of the decommit.
  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 (tx -> TxIdType tx
forall tx. IsTx tx => tx -> TxIdType tx
txId (tx -> TxIdType tx) -> [tx] -> [TxIdType tx]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [tx]
requestTxs) Maybe tx
requestDecommitTx Maybe (TxIdType tx)
requestDepositTxId))
      else Outcome tx
forall tx. Outcome tx
noop

  SnapshotRequest{[tx]
$sel:requestTxs:SnapshotRequest :: forall tx. SnapshotRequest tx -> [tx]
requestTxs :: [tx]
requestTxs, Maybe tx
$sel:requestDecommitTx:SnapshotRequest :: forall tx. SnapshotRequest tx -> Maybe tx
requestDecommitTx :: Maybe tx
requestDecommitTx, Maybe (TxIdType tx)
$sel:requestDepositTxId:SnapshotRequest :: forall tx. SnapshotRequest tx -> Maybe (TxIdType tx)
requestDepositTxId :: Maybe (TxIdType tx)
requestDepositTxId} =
    UTxOType tx
-> Seq tx
-> PendingDeposits tx
-> Maybe (TxIdType tx)
-> Maybe tx
-> Maybe (SettlingCommit tx)
-> SnapshotRequest tx
forall tx.
IsTx tx =>
UTxOType tx
-> Seq tx
-> PendingDeposits tx
-> Maybe (TxIdType tx)
-> Maybe tx
-> Maybe (SettlingCommit tx)
-> SnapshotRequest tx
nextSnapshotRequest UTxOType tx
confirmedUTxO Seq tx
localTxs PendingDeposits tx
pendingDeposits Maybe (TxIdType tx)
currentDepositTxId (tx -> Maybe tx
forall a. a -> Maybe a
Just tx
decommitTx) (Environment
-> SnapshotVersion
-> UTCTime
-> PendingDeposits tx
-> Snapshot tx
-> Maybe (SettlingCommit tx)
forall tx.
IsTx tx =>
Environment
-> SnapshotVersion
-> UTCTime
-> PendingDeposits tx
-> Snapshot tx
-> Maybe (SettlingCommit tx)
settlingCommitAt Environment
env SnapshotVersion
version UTCTime
currentChainTime PendingDeposits tx
pendingDeposits (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

  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

  confirmedUTxO :: UTxOType tx
confirmedUTxO = SnapshotVersion -> Snapshot tx -> UTxOType tx
forall tx. IsTx tx => SnapshotVersion -> Snapshot tx -> UTxOType tx
settledUTxO SnapshotVersion
version (ConfirmedSnapshot tx -> Snapshot tx
forall tx. IsTx tx => ConfirmedSnapshot tx -> Snapshot tx
getSnapshot ConfirmedSnapshot tx
confirmedSnapshot)

  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 :: forall tx. 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
  | SeenSnapshot tx -> Bool
forall tx. SeenSnapshot tx -> Bool
snapshotInFlight SeenSnapshot tx
seenSnapshot Bool -> Bool -> Bool
|| Bool -> Bool
not (HeadParameters -> Party -> SnapshotNumber -> Bool
isLeader HeadParameters
parameters Party
party SnapshotNumber
nextSn) = Outcome tx
forall tx. Outcome tx
noop
  | Bool
otherwise =
      let settling :: Maybe (SettlingCommit tx)
settling = Environment
-> SnapshotVersion
-> UTCTime
-> Map (TxIdType tx) (Deposit tx)
-> Snapshot tx
-> Maybe (SettlingCommit tx)
forall tx.
IsTx tx =>
Environment
-> SnapshotVersion
-> UTCTime
-> PendingDeposits tx
-> Snapshot tx
-> Maybe (SettlingCommit tx)
settlingCommitAt Environment
env SnapshotVersion
version UTCTime
chainTime Map (TxIdType tx) (Deposit tx)
deposits Snapshot tx
confirmed
          built :: SnapshotRequest tx
built = UTxOType tx
-> Seq tx
-> Map (TxIdType tx) (Deposit tx)
-> Maybe (TxIdType tx)
-> Maybe tx
-> Maybe (SettlingCommit tx)
-> SnapshotRequest tx
forall tx.
IsTx tx =>
UTxOType tx
-> Seq tx
-> PendingDeposits tx
-> Maybe (TxIdType tx)
-> Maybe tx
-> Maybe (SettlingCommit tx)
-> SnapshotRequest tx
nextSnapshotRequest (SnapshotVersion -> Snapshot tx -> UTxOType tx
forall tx. IsTx tx => SnapshotVersion -> Snapshot tx -> UTxOType tx
settledUTxO SnapshotVersion
version (ConfirmedSnapshot tx -> Snapshot tx
forall tx. IsTx tx => ConfirmedSnapshot tx -> Snapshot tx
getSnapshot ConfirmedSnapshot tx
confirmedSnapshot)) Seq tx
localTxs Map (TxIdType tx) (Deposit tx)
deposits Maybe (TxIdType tx)
currentDepositTxId Maybe tx
decommitTx Maybe (SettlingCommit tx)
settling
       in case (Maybe (SettlingCommit tx)
settling, SnapshotRequest tx
built) of
            -- The commit is still settling; requests carrying txs continue it.
            (Just (ContinueCommit (TxIdType tx, Deposit tx)
_), SnapshotRequest tx
_) -> Outcome tx
forall tx. Outcome tx
noop
            -- The commit can no longer land: drop it so other deposits can be claimed.
            (Just SettlingCommit tx
DropCommit, SnapshotRequest{[tx]
$sel:requestTxs:SnapshotRequest :: forall tx. SnapshotRequest tx -> [tx]
requestTxs :: [tx]
requestTxs, Maybe tx
$sel:requestDecommitTx:SnapshotRequest :: forall tx. SnapshotRequest tx -> Maybe tx
requestDecommitTx :: Maybe tx
requestDecommitTx, Maybe (TxIdType tx)
$sel:requestDepositTxId:SnapshotRequest :: forall tx. SnapshotRequest tx -> Maybe (TxIdType tx)
requestDepositTxId :: Maybe (TxIdType tx)
requestDepositTxId}) -> [tx] -> Maybe tx -> Maybe (TxIdType tx) -> Outcome tx
request [tx]
requestTxs Maybe tx
requestDecommitTx Maybe (TxIdType tx)
requestDepositTxId
            -- Spec: wait txω = ⊥ ∧ Uα = ∅.
            (Maybe (SettlingCommit tx)
Nothing, SnapshotRequest{[tx]
$sel:requestTxs:SnapshotRequest :: forall tx. SnapshotRequest tx -> [tx]
requestTxs :: [tx]
requestTxs, Maybe tx
$sel:requestDecommitTx:SnapshotRequest :: forall tx. SnapshotRequest tx -> Maybe tx
requestDecommitTx :: Maybe tx
requestDecommitTx, $sel:requestDepositTxId:SnapshotRequest :: forall tx. SnapshotRequest tx -> Maybe (TxIdType tx)
requestDepositTxId = Just TxIdType tx
depositTxId})
              | Maybe tx -> Bool
forall a. Maybe a -> Bool
isNothing Maybe tx
decommitTx -> [tx] -> Maybe tx -> Maybe (TxIdType tx) -> Outcome tx
request [tx]
requestTxs Maybe tx
requestDecommitTx (TxIdType tx -> Maybe (TxIdType tx)
forall a. a -> Maybe a
Just TxIdType tx
depositTxId)
            (Maybe (SettlingCommit tx), SnapshotRequest tx)
_ -> Outcome tx
forall tx. Outcome tx
noop
 where
  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

  -- All deposits, with their status updated to this tick's time. Empty
  -- deposits are ignored, because an empty increment cannot be posted.
  deposits :: Map (TxIdType tx) (Deposit tx)
deposits = (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{UTxOType tx
$sel:deposited:Deposit :: forall tx. Deposit tx -> UTxOType tx
deposited :: UTxOType tx
deposited} -> UTxOType tx
deposited UTxOType tx -> UTxOType tx -> Bool
forall a. Eq a => a -> a -> Bool
/= UTxOType tx
forall a. Monoid a => a
mempty) (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)

  request :: [tx] -> Maybe tx -> Maybe (TxIdType tx) -> Outcome tx
  request :: [tx] -> Maybe tx -> Maybe (TxIdType tx) -> Outcome tx
request [tx]
txs Maybe tx
mDecommitTx Maybe (TxIdType tx)
mDepositTxId =
    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 (tx -> TxIdType tx
forall tx. IsTx tx => tx -> TxIdType tx
txId (tx -> TxIdType tx) -> [tx] -> [TxIdType tx]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [tx]
txs) Maybe tx
mDecommitTx Maybe (TxIdType tx)
mDepositTxId)

  confirmed :: Snapshot tx
confirmed@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

  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

  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 ->
  -- | The request to make, if any, built for the new version. Its decommit is
  -- ignored: it is the one that just settled.
  Maybe (SnapshotRequest tx) ->
  SnapshotVersion ->
  SnapshotVersion ->
  SeenSnapshot tx ->
  Outcome tx
maybeRequestSnapshotAfterVersionBump :: forall tx.
IsTx tx =>
HeadParameters
-> Party
-> SnapshotNumber
-> Maybe (SnapshotRequest tx)
-> SnapshotVersion
-> SnapshotVersion
-> SeenSnapshot tx
-> Outcome tx
maybeRequestSnapshotAfterVersionBump HeadParameters
parameters Party
party SnapshotNumber
nextSn Maybe (SnapshotRequest tx)
mRequest SnapshotVersion
version SnapshotVersion
newVersion SeenSnapshot tx
seenSnapshot =
  case Maybe (SnapshotRequest tx)
mRequest of
    Just SnapshotRequest{[tx]
$sel:requestTxs:SnapshotRequest :: forall tx. SnapshotRequest tx -> [tx]
requestTxs :: [tx]
requestTxs, Maybe (TxIdType tx)
$sel:requestDepositTxId:SnapshotRequest :: forall tx. SnapshotRequest tx -> Maybe (TxIdType tx)
requestDepositTxId :: Maybe (TxIdType tx)
requestDepositTxId}
      | HeadParameters -> Party -> SnapshotNumber -> Bool
isLeader HeadParameters
parameters Party
party SnapshotNumber
nextSn 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) ->
          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 (tx -> TxIdType tx
forall tx. IsTx tx => tx -> TxIdType tx
txId (tx -> TxIdType tx) -> [tx] -> [TxIdType tx]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [tx]
requestTxs) Maybe tx
forall a. Maybe a
Nothing Maybe (TxIdType tx)
requestDepositTxId)
    Maybe (SnapshotRequest tx)
_ -> 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 ->
  PendingDeposits tx ->
  OpenState tx ->
  ChainStateType tx ->
  -- | New open state version
  SnapshotVersion ->
  -- | Deposit TxId
  TxIdType tx ->
  SnapshotNumber ->
  MultiSignature (Snapshot tx) ->
  Outcome tx
onOpenChainIncrementTx :: forall tx.
IsTx tx =>
Environment
-> PendingDeposits tx
-> OpenState tx
-> ChainStateType tx
-> SnapshotVersion
-> TxIdType tx
-> SnapshotNumber
-> MultiSignature (Snapshot tx)
-> Outcome tx
onOpenChainIncrementTx Environment
env PendingDeposits tx
pendingDeposits OpenState tx
openState ChainStateType tx
newChainState SnapshotVersion
newVersion TxIdType tx
depositTxId SnapshotNumber
observedSnapshotNumber MultiSignature (Snapshot tx)
observedSignatures =
  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
<> Outcome tx
adoptObservedSnapshotOrRequestNext
 where
  -- The increment proves on-chain that the snapshot it settled is fully
  -- signed. If that is the one we are still collecting AckSns for, adopt it
  -- with the on-chain multisignature instead of waiting on a peer.
  adoptObservedSnapshotOrRequestNext :: Outcome tx
adoptObservedSnapshotOrRequestNext =
    case SeenSnapshot tx
seenSnapshot of
      SeenSnapshot{$sel:snapshot:NoSeenSnapshot :: forall tx. SeenSnapshot tx -> Snapshot tx
snapshot = snapshot :: Snapshot tx
snapshot@Snapshot{$sel:number:Snapshot :: forall tx. Snapshot tx -> SnapshotNumber
number = SnapshotNumber
seenSnNumber, $sel:version:Snapshot :: forall tx. Snapshot tx -> SnapshotVersion
version = SnapshotVersion
seenSnapshotVersion, $sel:depositTxId:Snapshot :: forall tx. Snapshot tx -> Maybe (TxIdType tx)
depositTxId = Maybe (TxIdType tx)
seenDepositTxId}, ByteString
$sel:signableBytes:NoSeenSnapshot :: forall tx. SeenSnapshot tx -> ByteString
signableBytes :: ByteString
signableBytes}
        | SnapshotNumber
observedSnapshotNumber SnapshotNumber -> SnapshotNumber -> Bool
forall a. Eq a => a -> a -> Bool
== SnapshotNumber
seenSnNumber
        , SnapshotVersion
seenSnapshotVersion SnapshotVersion -> SnapshotVersion -> SnapshotVersion
forall a. Num a => a -> a -> a
+ SnapshotVersion
1 SnapshotVersion -> SnapshotVersion -> Bool
forall a. Eq a => a -> a -> Bool
== SnapshotVersion
newVersion
        , Maybe (TxIdType tx)
seenDepositTxId 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
        , Verified
Verified <- [VerificationKey HydraKey]
-> MultiSignature (Snapshot tx) -> ByteString -> Verified
forall a.
[VerificationKey HydraKey]
-> MultiSignature a -> ByteString -> Verified
verifyMultiSignatureBytes [VerificationKey HydraKey]
vkeys MultiSignature (Snapshot tx)
observedSignatures ByteString
signableBytes ->
            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 = Snapshot tx -> Maybe (Snapshot tx)
forall a. a -> Maybe a
Just Snapshot tx
snapshot, $sel:signatures:NetworkConnected :: MultiSignature (Snapshot tx)
signatures = MultiSignature (Snapshot tx)
observedSignatures}
              Outcome tx -> Outcome tx -> Outcome tx
forall a. Semigroup a => a -> a -> a
<> HeadParameters
-> Party
-> SnapshotNumber
-> Maybe (SnapshotRequest tx)
-> SnapshotVersion
-> SnapshotVersion
-> SeenSnapshot tx
-> Outcome tx
forall tx.
IsTx tx =>
HeadParameters
-> Party
-> SnapshotNumber
-> Maybe (SnapshotRequest tx)
-> SnapshotVersion
-> SnapshotVersion
-> SeenSnapshot tx
-> Outcome tx
maybeRequestSnapshotAfterVersionBump HeadParameters
parameters Party
party (SnapshotNumber
seenSnNumber SnapshotNumber -> SnapshotNumber -> SnapshotNumber
forall a. Num a => a -> a -> a
+ SnapshotNumber
1) (Snapshot tx -> Maybe (SnapshotRequest tx)
requestOn Snapshot tx
snapshot) SnapshotVersion
version SnapshotVersion
newVersion (SnapshotNumber -> SeenSnapshot tx
forall tx. SnapshotNumber -> SeenSnapshot tx
LastSeenSnapshot SnapshotNumber
seenSnNumber)
      SeenSnapshot tx
_ ->
        HeadParameters
-> Party
-> SnapshotNumber
-> Maybe (SnapshotRequest tx)
-> SnapshotVersion
-> SnapshotVersion
-> SeenSnapshot tx
-> Outcome tx
forall tx.
IsTx tx =>
HeadParameters
-> Party
-> SnapshotNumber
-> Maybe (SnapshotRequest tx)
-> SnapshotVersion
-> SnapshotVersion
-> SeenSnapshot tx
-> Outcome tx
maybeRequestSnapshotAfterVersionBump HeadParameters
parameters Party
party SnapshotNumber
nextSn (Snapshot tx -> Maybe (SnapshotRequest tx)
requestOn (ConfirmedSnapshot tx -> Snapshot tx
forall tx. IsTx tx => ConfirmedSnapshot tx -> Snapshot tx
getSnapshot ConfirmedSnapshot tx
confirmedSnapshot)) SnapshotVersion
version SnapshotVersion
newVersion SeenSnapshot tx
seenSnapshot

  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, Maybe tx
$sel:decommitTx:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> Maybe tx
decommitTx :: Maybe tx
decommitTx} = CoordinatedHeadState tx
coordinatedHeadState

  -- Built on the snapshot that is confirmed after this increment (the adopted
  -- one, if any), as followers check it. The deposit just settled, so it is
  -- excluded.
  requestOn :: Snapshot tx -> Maybe (SnapshotRequest tx)
requestOn Snapshot tx
snapshot =
    UTxOType tx
-> Seq tx
-> PendingDeposits tx
-> Maybe (TxIdType tx)
-> Maybe tx
-> Maybe (SettlingCommit tx)
-> Maybe (SnapshotRequest tx)
forall tx.
IsTx tx =>
UTxOType tx
-> Seq tx
-> PendingDeposits tx
-> Maybe (TxIdType tx)
-> Maybe tx
-> Maybe (SettlingCommit tx)
-> Maybe (SnapshotRequest tx)
chainedSnapshotRequest (SnapshotVersion -> Snapshot tx -> UTxOType tx
forall tx. IsTx tx => SnapshotVersion -> Snapshot tx -> UTxOType tx
settledUTxO SnapshotVersion
newVersion Snapshot tx
snapshot) Seq tx
localTxs (TxIdType tx -> PendingDeposits tx -> PendingDeposits tx
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete TxIdType tx
depositTxId PendingDeposits tx
pendingDeposits) Maybe (TxIdType tx)
forall a. Maybe a
Nothing Maybe tx
decommitTx Maybe (SettlingCommit tx)
forall a. Maybe a
Nothing

  HeadParameters{[Party]
$sel:parties:HeadParameters :: HeadParameters -> [Party]
parties :: [Party]
parties} = HeadParameters
parameters

  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

  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 ->
  -- | Number of the snapshot the decrement settled
  SnapshotNumber ->
  -- | Multisignature carried by the decrement redeemer
  MultiSignature (Snapshot tx) ->
  Outcome tx
onOpenChainDecrementTx :: forall tx.
IsTx tx =>
Environment
-> PendingDeposits tx
-> OpenState tx
-> ChainStateType tx
-> SnapshotVersion
-> UTxOType tx
-> SnapshotNumber
-> MultiSignature (Snapshot tx)
-> Outcome tx
onOpenChainDecrementTx Environment
env PendingDeposits tx
pendingDeposits OpenState tx
openState ChainStateType tx
newChainState SnapshotVersion
newVersion UTxOType tx
distributedUTxO SnapshotNumber
observedSnapshotNumber MultiSignature (Snapshot tx)
observedSignatures =
  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
<> Outcome tx
adoptObservedSnapshotOrRequestNext
 where
  -- Same reasoning as in 'onOpenChainIncrementTx': the decrement proves the
  -- snapshot it settled is fully signed, so adopt it if it is the one in flight.
  adoptObservedSnapshotOrRequestNext :: Outcome tx
adoptObservedSnapshotOrRequestNext =
    case SeenSnapshot tx
seenSnapshot of
      SeenSnapshot{$sel:snapshot:NoSeenSnapshot :: forall tx. SeenSnapshot tx -> Snapshot tx
snapshot = snapshot :: Snapshot tx
snapshot@Snapshot{$sel:number:Snapshot :: forall tx. Snapshot tx -> SnapshotNumber
number = SnapshotNumber
seenSnNumber, $sel:version:Snapshot :: forall tx. Snapshot tx -> SnapshotVersion
version = SnapshotVersion
seenSnapshotVersion, $sel:utxoToDecommit:Snapshot :: forall tx. Snapshot tx -> Maybe (UTxOType tx)
utxoToDecommit = Maybe (UTxOType tx)
seenDecommit}, ByteString
$sel:signableBytes:NoSeenSnapshot :: forall tx. SeenSnapshot tx -> ByteString
signableBytes :: ByteString
signableBytes}
        | SnapshotNumber
observedSnapshotNumber SnapshotNumber -> SnapshotNumber -> Bool
forall a. Eq a => a -> a -> Bool
== SnapshotNumber
seenSnNumber
        , SnapshotVersion
seenSnapshotVersion SnapshotVersion -> SnapshotVersion -> SnapshotVersion
forall a. Num a => a -> a -> a
+ SnapshotVersion
1 SnapshotVersion -> SnapshotVersion -> Bool
forall a. Eq a => a -> a -> Bool
== SnapshotVersion
newVersion
        , Maybe (UTxOType tx) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (UTxOType tx)
seenDecommit
        , Verified
Verified <- [VerificationKey HydraKey]
-> MultiSignature (Snapshot tx) -> ByteString -> Verified
forall a.
[VerificationKey HydraKey]
-> MultiSignature a -> ByteString -> Verified
verifyMultiSignatureBytes [VerificationKey HydraKey]
vkeys MultiSignature (Snapshot tx)
observedSignatures ByteString
signableBytes ->
            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 = Snapshot tx -> Maybe (Snapshot tx)
forall a. a -> Maybe a
Just Snapshot tx
snapshot, $sel:signatures:NetworkConnected :: MultiSignature (Snapshot tx)
signatures = MultiSignature (Snapshot tx)
observedSignatures}
              Outcome tx -> Outcome tx -> Outcome tx
forall a. Semigroup a => a -> a -> a
<> HeadParameters
-> Party
-> SnapshotNumber
-> Maybe (SnapshotRequest tx)
-> SnapshotVersion
-> SnapshotVersion
-> SeenSnapshot tx
-> Outcome tx
forall tx.
IsTx tx =>
HeadParameters
-> Party
-> SnapshotNumber
-> Maybe (SnapshotRequest tx)
-> SnapshotVersion
-> SnapshotVersion
-> SeenSnapshot tx
-> Outcome tx
maybeRequestSnapshotAfterVersionBump HeadParameters
parameters Party
party (SnapshotNumber
seenSnNumber SnapshotNumber -> SnapshotNumber -> SnapshotNumber
forall a. Num a => a -> a -> a
+ SnapshotNumber
1) (Snapshot tx -> Maybe (SnapshotRequest tx)
requestOn Snapshot tx
snapshot) SnapshotVersion
version SnapshotVersion
newVersion (SnapshotNumber -> SeenSnapshot tx
forall tx. SnapshotNumber -> SeenSnapshot tx
LastSeenSnapshot SnapshotNumber
seenSnNumber)
      SeenSnapshot tx
_ ->
        HeadParameters
-> Party
-> SnapshotNumber
-> Maybe (SnapshotRequest tx)
-> SnapshotVersion
-> SnapshotVersion
-> SeenSnapshot tx
-> Outcome tx
forall tx.
IsTx tx =>
HeadParameters
-> Party
-> SnapshotNumber
-> Maybe (SnapshotRequest tx)
-> SnapshotVersion
-> SnapshotVersion
-> SeenSnapshot tx
-> Outcome tx
maybeRequestSnapshotAfterVersionBump HeadParameters
parameters Party
party SnapshotNumber
nextSn (Snapshot tx -> Maybe (SnapshotRequest tx)
requestOn (ConfirmedSnapshot tx -> Snapshot tx
forall tx. IsTx tx => ConfirmedSnapshot tx -> Snapshot tx
getSnapshot ConfirmedSnapshot tx
confirmedSnapshot)) SnapshotVersion
version SnapshotVersion
newVersion SeenSnapshot tx
seenSnapshot

  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, Maybe tx
$sel:decommitTx:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> Maybe tx
decommitTx :: Maybe tx
decommitTx} = CoordinatedHeadState tx
coordinatedHeadState

  -- Built on the snapshot that is confirmed after this decrement (the adopted
  -- one, if any), as followers check it. No commit is settling next to a
  -- decommit.
  requestOn :: Snapshot tx -> Maybe (SnapshotRequest tx)
requestOn Snapshot tx
snapshot =
    UTxOType tx
-> Seq tx
-> PendingDeposits tx
-> Maybe (TxIdType tx)
-> Maybe tx
-> Maybe (SettlingCommit tx)
-> Maybe (SnapshotRequest tx)
forall tx.
IsTx tx =>
UTxOType tx
-> Seq tx
-> PendingDeposits tx
-> Maybe (TxIdType tx)
-> Maybe tx
-> Maybe (SettlingCommit tx)
-> Maybe (SnapshotRequest tx)
chainedSnapshotRequest (SnapshotVersion -> Snapshot tx -> UTxOType tx
forall tx. IsTx tx => SnapshotVersion -> Snapshot tx -> UTxOType tx
settledUTxO SnapshotVersion
newVersion Snapshot tx
snapshot) Seq tx
localTxs PendingDeposits tx
pendingDeposits Maybe (TxIdType tx)
currentDepositTxId Maybe tx
decommitTx Maybe (SettlingCommit tx)
forall a. Maybe a
Nothing

  HeadParameters{[Party]
$sel:parties:HeadParameters :: HeadParameters -> [Party]
parties :: [Party]
parties} = HeadParameters
parameters

  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

  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.
--
-- A peer that withheld its 'AckSn' can close with the snapshot we are still
-- collecting signatures for. The close carries its full multisignature, so
-- adopt it as confirmed; otherwise we could not fan out the closed head.
--
-- __Transition__: 'OpenState' → 'ClosedState'
onOpenChainCloseTx ::
  IsTx tx =>
  OpenState tx ->
  -- | New chain state.
  ChainStateType tx ->
  -- | Closed snapshot number.
  SnapshotNumber ->
  -- | Contestation deadline.
  UTCTime ->
  -- | Multisignature carried by the close redeemer.
  MultiSignature (Snapshot tx) ->
  Outcome tx
onOpenChainCloseTx :: forall tx.
IsTx tx =>
OpenState tx
-> ChainStateType tx
-> SnapshotNumber
-> UTCTime
-> MultiSignature (Snapshot tx)
-> Outcome tx
onOpenChainCloseTx OpenState tx
openState ChainStateType tx
newChainState SnapshotNumber
closedSnapshotNumber UTCTime
contestationDeadline MultiSignature (Snapshot tx)
observedSignatures =
  Outcome tx
adoptClosedSnapshot
    Outcome tx -> Outcome tx -> Outcome tx
forall a. Semigroup a => a -> a -> a
<> 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
  -- The multisignature verifying over our own signable bytes proves the head
  -- closed with exactly the snapshot we saw. Anything else leaves the confirmed
  -- snapshot as it is.
  adoptClosedSnapshot :: Outcome tx
adoptClosedSnapshot =
    case SeenSnapshot tx
seenSnapshot of
      SeenSnapshot{$sel:snapshot:NoSeenSnapshot :: forall tx. SeenSnapshot tx -> Snapshot tx
snapshot = snapshot :: Snapshot tx
snapshot@Snapshot{$sel:number:Snapshot :: forall tx. Snapshot tx -> SnapshotNumber
number = SnapshotNumber
seenSnNumber}, ByteString
$sel:signableBytes:NoSeenSnapshot :: forall tx. SeenSnapshot tx -> ByteString
signableBytes :: ByteString
signableBytes}
        | SnapshotNumber
seenSnNumber SnapshotNumber -> SnapshotNumber -> Bool
forall a. Eq a => a -> a -> Bool
== SnapshotNumber
closedSnapshotNumber
        , Verified
Verified <- [VerificationKey HydraKey]
-> MultiSignature (Snapshot tx) -> ByteString -> Verified
forall a.
[VerificationKey HydraKey]
-> MultiSignature a -> ByteString -> Verified
verifyMultiSignatureBytes [VerificationKey HydraKey]
vkeys MultiSignature (Snapshot tx)
observedSignatures ByteString
signableBytes ->
            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 = Snapshot tx -> Maybe (Snapshot tx)
forall a. a -> Maybe a
Just Snapshot tx
snapshot, $sel:signatures:NetworkConnected :: MultiSignature (Snapshot tx)
signatures = MultiSignature (Snapshot tx)
observedSignatures}
      SeenSnapshot tx
_ -> Outcome tx
forall tx. Outcome tx
noop

  HeadParameters{[Party]
$sel:parties:HeadParameters :: HeadParameters -> [Party]
parties :: [Party]
parties} = HeadParameters
headParameters

  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

  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, 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} = 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.
--
-- A peer that withheld its 'AckSn' can close with an older snapshot and then
-- contest with the one we are still collecting signatures for. The contest
-- carries its full multisignature, so adopt it as confirmed, like
-- 'onOpenChainCloseTx' does for a close.
--
-- __Transition__: 'ClosedState' → 'ClosedState'
onClosedChainContestTx ::
  IsTx tx =>
  ClosedState tx ->
  -- | New chain state.
  ChainStateType tx ->
  SnapshotNumber ->
  -- | Contestation deadline.
  UTCTime ->
  -- | Multisignature carried by the contest redeemer.
  MultiSignature (Snapshot tx) ->
  Outcome tx
onClosedChainContestTx :: forall tx.
IsTx tx =>
ClosedState tx
-> ChainStateType tx
-> SnapshotNumber
-> UTCTime
-> MultiSignature (Snapshot tx)
-> Outcome tx
onClosedChainContestTx ClosedState tx
closedState ChainStateType tx
newChainState SnapshotNumber
snapshotNumber UTCTime
contestationDeadline MultiSignature (Snapshot tx)
observedSignatures =
  if
    | -- The multisignature verifying over our own signable bytes proves the
      -- head was contested with exactly the snapshot we saw.
      Just snapshot :: Snapshot tx
snapshot@Snapshot{$sel:number:Snapshot :: forall tx. Snapshot tx -> SnapshotNumber
number = SnapshotNumber
unconfirmedSn} <- Maybe (Snapshot tx)
unconfirmedSnapshot
    , SnapshotNumber
unconfirmedSn SnapshotNumber -> SnapshotNumber -> Bool
forall a. Eq a => a -> a -> Bool
== SnapshotNumber
snapshotNumber
    , Verified
Verified <- [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)
observedSignatures Snapshot tx
snapshot ->
        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 = Snapshot tx -> Maybe (Snapshot tx)
forall a. a -> Maybe a
Just Snapshot tx
snapshot, $sel:signatures:NetworkConnected :: MultiSignature (Snapshot tx)
signatures = MultiSignature (Snapshot tx)
observedSignatures}
          Outcome tx -> Outcome tx -> Outcome tx
forall a. Semigroup a => a -> a -> a
<> 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}
    | -- 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, Maybe (Snapshot tx)
unconfirmedSnapshot :: Maybe (Snapshot tx)
$sel:unconfirmedSnapshot:ClosedState :: forall tx. ClosedState tx -> Maybe (Snapshot tx)
unconfirmedSnapshot} = ClosedState tx
closedState

  HeadParameters{[Party]
$sel:parties:HeadParameters :: HeadParameters -> [Party]
parties :: [Party]
parties} = HeadParameters
headParameters

  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

-- | 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'. The contestation period is over
-- by then, so no contest can confirm an 'unconfirmedSnapshot' anymore.
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
    , $sel:unconfirmedSnapshot:ClosedState :: Maybe (Snapshot tx)
unconfirmedSnapshot = Maybe (Snapshot tx)
forall a. Maybe a
Nothing
    }
 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)

-- | Find the oldest non-empty active deposit the request being built can
-- absorb ('absorbable'), if any. Deposits are selected in FIFO order by their
-- 'created' timestamp.
nextActiveDepositId :: IsTx tx => (UTxOType tx -> Bool) -> PendingDeposits tx -> Maybe (TxIdType tx)
nextActiveDepositId :: forall tx.
IsTx tx =>
(UTxOType tx -> Bool) -> PendingDeposits tx -> Maybe (TxIdType tx)
nextActiveDepositId UTxOType tx -> Bool
absorbableHere 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 Bool -> Bool -> Bool
&& UTxOType tx -> Bool
absorbableHere UTxOType tx
deposited) (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' the request
-- can absorb ('absorbable'), but only when neither a decommit is pending nor
-- the last confirmed snapshot's commit is still settling (to avoid
-- double-posting 'IncrementTx' before 'CommitFinalized' removes the deposit).
selectNextDeposit ::
  IsTx tx =>
  -- | Whether the request being built can absorb a deposit of these outputs,
  -- see 'absorbable'.
  (UTxOType tx -> Bool) ->
  PendingDeposits tx ->
  Maybe (TxIdType tx) ->
  -- | Pending decommit tx
  Maybe tx ->
  Maybe (TxIdType tx)
selectNextDeposit :: forall tx.
IsTx tx =>
(UTxOType tx -> Bool)
-> PendingDeposits tx
-> Maybe (TxIdType tx)
-> Maybe tx
-> Maybe (TxIdType tx)
selectNextDeposit UTxOType tx -> Bool
absorbableHere PendingDeposits tx
pendingDeposits Maybe (TxIdType tx)
currentDepositTxId Maybe tx
mDecommitTx =
  (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 Maybe (TxIdType tx, Deposit tx)
-> ((TxIdType tx, Deposit tx) -> Maybe (TxIdType tx))
-> Maybe (TxIdType tx)
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (TxIdType tx, Deposit tx) -> Maybe (TxIdType tx)
tracked)
    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
<|> (Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Maybe tx -> Bool
forall a. Maybe a -> Bool
isNothing Maybe tx
mDecommitTx) Maybe () -> Maybe (TxIdType tx) -> Maybe (TxIdType tx)
forall a b. Maybe a -> Maybe b -> Maybe b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (UTxOType tx -> Bool) -> PendingDeposits tx -> Maybe (TxIdType tx)
forall tx.
IsTx tx =>
(UTxOType tx -> Bool) -> PendingDeposits tx -> Maybe (TxIdType tx)
nextActiveDepositId UTxOType tx -> Bool
absorbableHere PendingDeposits tx
pendingDeposits)
 where
  tracked :: (TxIdType tx, Deposit tx) -> Maybe (TxIdType tx)
tracked (TxIdType tx
depositTxId, Deposit{UTxOType tx
$sel:deposited:Deposit :: forall tx. Deposit tx -> UTxOType tx
deposited :: UTxOType tx
deposited}) = TxIdType tx
depositTxId TxIdType tx -> Maybe () -> Maybe (TxIdType tx)
forall a b. a -> Maybe b -> Maybe a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (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
&& UTxOType tx -> Bool
absorbableHere UTxOType tx
deposited)

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

-- | What a leader puts in its next 'ReqSn', see 'nextSnapshotRequest'.
data SnapshotRequest tx = SnapshotRequest
  { forall tx. SnapshotRequest tx -> [tx]
requestTxs :: [tx]
  , forall tx. SnapshotRequest tx -> Maybe tx
requestDecommitTx :: Maybe tx
  , forall tx. SnapshotRequest tx -> Maybe (TxIdType tx)
requestDepositTxId :: Maybe (TxIdType tx)
  }

-- | The content of a leader's next 'ReqSn': the transactions to carry and the
-- incremental action, 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'.
--
-- Leaders never build a request followers reject: a leader's own rejection
-- would stall the head. A settling commit is always carried; txs colliding
-- with it are held back.
nextSnapshotRequest ::
  IsTx tx =>
  -- | The UTxO 'onOpenNetworkReqSn' applies the request's transactions to.
  UTxOType tx ->
  -- | Pending local transactions.
  Seq tx ->
  PendingDeposits tx ->
  Maybe (TxIdType tx) ->
  -- | Pending decommit tx
  Maybe tx ->
  -- | The commit the confirmed snapshot is settling, see 'settlingCommitAt'
  Maybe (SettlingCommit tx) ->
  SnapshotRequest tx
nextSnapshotRequest :: forall tx.
IsTx tx =>
UTxOType tx
-> Seq tx
-> PendingDeposits tx
-> Maybe (TxIdType tx)
-> Maybe tx
-> Maybe (SettlingCommit tx)
-> SnapshotRequest tx
nextSnapshotRequest UTxOType tx
utxo Seq tx
localTxs PendingDeposits tx
pendingDeposits Maybe (TxIdType tx)
currentDepositTxId Maybe tx
mDecommitTx Maybe (SettlingCommit tx)
mSettlingCommit =
  (SnapshotRequest tx, Bool) -> SnapshotRequest tx
forall a b. (a, b) -> a
fst (UTxOType tx
-> Seq tx
-> PendingDeposits tx
-> Maybe (TxIdType tx)
-> Maybe tx
-> Maybe (SettlingCommit tx)
-> (SnapshotRequest tx, Bool)
forall tx.
IsTx tx =>
UTxOType tx
-> Seq tx
-> PendingDeposits tx
-> Maybe (TxIdType tx)
-> Maybe tx
-> Maybe (SettlingCommit tx)
-> (SnapshotRequest tx, Bool)
buildSnapshotRequest UTxOType tx
utxo Seq tx
localTxs PendingDeposits tx
pendingDeposits Maybe (TxIdType tx)
currentDepositTxId Maybe tx
mDecommitTx Maybe (SettlingCommit tx)
mSettlingCommit)

-- | 'nextSnapshotRequest', if worth sending right away: it carries a tx or a
-- new deposit, or it prunes a pending tx no node accepts. A request carrying
-- only a settling commit or a decommit is not: it would be re-requested
-- forever at the same version.
chainedSnapshotRequest ::
  IsTx tx =>
  UTxOType tx ->
  Seq tx ->
  PendingDeposits tx ->
  Maybe (TxIdType tx) ->
  Maybe tx ->
  Maybe (SettlingCommit tx) ->
  Maybe (SnapshotRequest tx)
chainedSnapshotRequest :: forall tx.
IsTx tx =>
UTxOType tx
-> Seq tx
-> PendingDeposits tx
-> Maybe (TxIdType tx)
-> Maybe tx
-> Maybe (SettlingCommit tx)
-> Maybe (SnapshotRequest tx)
chainedSnapshotRequest UTxOType tx
utxo Seq tx
localTxs PendingDeposits tx
pendingDeposits Maybe (TxIdType tx)
currentDepositTxId Maybe tx
mDecommitTx Maybe (SettlingCommit tx)
mSettlingCommit =
  SnapshotRequest tx
request SnapshotRequest tx -> Maybe () -> Maybe (SnapshotRequest tx)
forall a b. a -> Maybe b -> Maybe a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard Bool
worthChaining
 where
  (SnapshotRequest tx
request, Bool
worthChaining) = UTxOType tx
-> Seq tx
-> PendingDeposits tx
-> Maybe (TxIdType tx)
-> Maybe tx
-> Maybe (SettlingCommit tx)
-> (SnapshotRequest tx, Bool)
forall tx.
IsTx tx =>
UTxOType tx
-> Seq tx
-> PendingDeposits tx
-> Maybe (TxIdType tx)
-> Maybe tx
-> Maybe (SettlingCommit tx)
-> (SnapshotRequest tx, Bool)
buildSnapshotRequest UTxOType tx
utxo Seq tx
localTxs PendingDeposits tx
pendingDeposits Maybe (TxIdType tx)
currentDepositTxId Maybe tx
mDecommitTx Maybe (SettlingCommit tx)
mSettlingCommit

-- | The request and whether it is worth chaining, see 'chainedSnapshotRequest'.
buildSnapshotRequest ::
  forall tx.
  IsTx tx =>
  UTxOType tx ->
  Seq tx ->
  PendingDeposits tx ->
  Maybe (TxIdType tx) ->
  Maybe tx ->
  Maybe (SettlingCommit tx) ->
  (SnapshotRequest tx, Bool)
buildSnapshotRequest :: forall tx.
IsTx tx =>
UTxOType tx
-> Seq tx
-> PendingDeposits tx
-> Maybe (TxIdType tx)
-> Maybe tx
-> Maybe (SettlingCommit tx)
-> (SnapshotRequest tx, Bool)
buildSnapshotRequest UTxOType tx
utxo Seq tx
localTxs PendingDeposits tx
pendingDeposits Maybe (TxIdType tx)
currentDepositTxId Maybe tx
mDecommitTx Maybe (SettlingCommit tx)
mSettlingCommit =
  case Maybe (SettlingCommit tx)
mSettlingCommit of
    Just (ContinueCommit (TxIdType tx
depositTxId, Deposit{UTxOType tx
$sel:deposited:Deposit :: forall tx. Deposit tx -> UTxOType tx
deposited :: UTxOType tx
deposited})) ->
      let requestTxs :: [tx]
requestTxs = UTxOType tx -> [tx]
requestable (UTxOType tx
utxo UTxOType tx -> UTxOType tx -> UTxOType tx
forall a. Semigroup a => a -> a -> a
<> UTxOType tx
deposited)
       in (SnapshotRequest{[tx]
$sel:requestTxs:SnapshotRequest :: [tx]
requestTxs :: [tx]
requestTxs, $sel:requestDecommitTx:SnapshotRequest :: Maybe tx
requestDecommitTx = Maybe tx
forall a. Maybe a
Nothing, $sel:requestDepositTxId:SnapshotRequest :: Maybe (TxIdType tx)
requestDepositTxId = TxIdType tx -> Maybe (TxIdType tx)
forall a. a -> Maybe a
Just TxIdType tx
depositTxId}, Bool -> Bool
not ([tx] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [tx]
requestTxs) Bool -> Bool -> Bool
|| Bool
prunesPending)
    Just SettlingCommit tx
DropCommit -> (SnapshotRequest tx, Bool)
withoutDeposit
    Maybe (SettlingCommit tx)
Nothing ->
      case (UTxOType tx -> Bool)
-> PendingDeposits tx
-> Maybe (TxIdType tx)
-> Maybe tx
-> Maybe (TxIdType tx)
forall tx.
IsTx tx =>
(UTxOType tx -> Bool)
-> PendingDeposits tx
-> Maybe (TxIdType tx)
-> Maybe tx
-> Maybe (TxIdType tx)
selectNextDeposit (UTxOType tx -> [tx] -> UTxOType tx -> Bool
forall tx. IsTx tx => UTxOType tx -> [tx] -> UTxOType tx -> Bool
absorbable UTxOType tx
utxo [tx]
candidates) PendingDeposits tx
pendingDeposits Maybe (TxIdType tx)
currentDepositTxId Maybe tx
mDecommitTx of
        Just TxIdType tx
depositTxId -> (SnapshotRequest{$sel:requestTxs:SnapshotRequest :: [tx]
requestTxs = UTxOType tx -> [tx]
requestable UTxOType tx
utxo, $sel:requestDecommitTx:SnapshotRequest :: Maybe tx
requestDecommitTx = Maybe tx
forall a. Maybe a
Nothing, $sel:requestDepositTxId:SnapshotRequest :: Maybe (TxIdType tx)
requestDepositTxId = TxIdType tx -> Maybe (TxIdType tx)
forall a. a -> Maybe a
Just TxIdType tx
depositTxId}, Bool
True)
        Maybe (TxIdType tx)
Nothing -> (SnapshotRequest tx, Bool)
withoutDeposit
 where
  withoutDeposit :: (SnapshotRequest tx, Bool)
  withoutDeposit :: (SnapshotRequest tx, Bool)
withoutDeposit =
    let requestTxs :: [tx]
requestTxs = UTxOType tx -> [tx]
requestable UTxOType tx
utxo
     in (SnapshotRequest{[tx]
$sel:requestTxs:SnapshotRequest :: [tx]
requestTxs :: [tx]
requestTxs, $sel:requestDecommitTx:SnapshotRequest :: Maybe tx
requestDecommitTx = Maybe tx
mDecommitTx, $sel:requestDepositTxId:SnapshotRequest :: Maybe (TxIdType tx)
requestDepositTxId = Maybe (TxIdType tx)
forall a. Maybe a
Nothing}, Bool -> Bool
not ([tx] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [tx]
requestTxs) Bool -> Bool -> Bool
|| Bool
prunesPending)

  -- The first pending tx collides with the ledger; only a snapshot prunes it.
  prunesPending :: Bool
  prunesPending :: Bool
prunesPending = case [tx]
candidates of
    tx
tx : [tx]
_ -> Bool -> Bool
not (UTxOType tx -> UTxOType tx -> Bool
forall tx. IsTx tx => UTxOType tx -> UTxOType tx -> Bool
namesNoneOf (tx -> UTxOType tx
forall tx. IsTx tx => tx -> UTxOType tx
utxoFromTx tx
tx) UTxOType tx
utxo)
    [] -> Bool
False

  -- The pending txs up to the first one creating an output the ledger or the
  -- carried commit holds: no node accepts that one.
  requestable :: UTxOType tx -> [tx]
  requestable :: UTxOType tx -> [tx]
requestable UTxOType tx
held = (tx -> Bool) -> [tx] -> [tx]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (\tx
tx -> UTxOType tx -> UTxOType tx -> Bool
forall tx. IsTx tx => UTxOType tx -> UTxOType tx -> Bool
namesNoneOf (tx -> UTxOType tx
forall tx. IsTx tx => tx -> UTxOType tx
utxoFromTx tx
tx) UTxOType tx
held) [tx]
candidates

  -- The first 'maxTxsPerSnapshot' pending txs: a snapshot request lists at
  -- most that many.
  candidates :: [tx]
  candidates :: [tx]
candidates = Seq tx -> [tx]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Int -> Seq tx -> Seq tx
forall a. Int -> Seq a -> Seq a
Seq.take Int
maxTxsPerSnapshot Seq tx
localTxs)

-- | 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 the handlers of an open head may act on: scoped to the head,
-- excluding the deposit claimed by the retained finalized increment (see
-- 'finalizedDepositTxId').
scopedDeposits :: IsTx tx => OpenState tx -> PendingDeposits tx -> PendingDeposits tx
scopedDeposits :: forall tx.
IsTx tx =>
OpenState tx -> PendingDeposits tx -> PendingDeposits tx
scopedDeposits 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

-- | What the next request does with a commit the confirmed snapshot claims but
-- whose increment has not landed. Leaders and followers decide it the same way.
data SettlingCommit tx
  = -- | The increment may still land: every request must carry the commit.
    ContinueCommit (TxIdType tx, Deposit tx)
  | -- | The increment can no longer land: the deposit was recovered, or its
    -- deadline passed by more than 'depositPeriod' (a margin for rollbacks).
    -- 'Expired' is not enough: it is set before the deadline.
    DropCommit

settlingCommitAt :: IsTx tx => Environment -> SnapshotVersion -> UTCTime -> PendingDeposits tx -> Snapshot tx -> Maybe (SettlingCommit tx)
settlingCommitAt :: forall tx.
IsTx tx =>
Environment
-> SnapshotVersion
-> UTCTime
-> PendingDeposits tx
-> Snapshot tx
-> Maybe (SettlingCommit tx)
settlingCommitAt Environment{DepositPeriod
$sel:depositPeriod:Environment :: Environment -> DepositPeriod
depositPeriod :: DepositPeriod
depositPeriod} SnapshotVersion
version UTCTime
chainTime PendingDeposits tx
pendingDeposits Snapshot{Maybe (UTxOType tx)
$sel:utxoToCommit:Snapshot :: forall tx. Snapshot tx -> Maybe (UTxOType tx)
utxoToCommit :: Maybe (UTxOType tx)
utxoToCommit, Maybe (TxIdType tx)
$sel:depositTxId:Snapshot :: forall tx. Snapshot tx -> Maybe (TxIdType tx)
depositTxId :: Maybe (TxIdType tx)
depositTxId, $sel:version:Snapshot :: forall tx. Snapshot tx -> SnapshotVersion
version = SnapshotVersion
snapshotVersion}
  | SnapshotVersion
version SnapshotVersion -> SnapshotVersion -> Bool
forall a. Eq a => a -> a -> Bool
/= SnapshotVersion
snapshotVersion Bool -> Bool -> Bool
|| Maybe (UTxOType tx) -> Bool
forall a. Maybe a -> Bool
isNothing Maybe (UTxOType tx)
utxoToCommit = Maybe (SettlingCommit tx)
forall a. Maybe a
Nothing
  | Bool
otherwise = SettlingCommit tx -> Maybe (SettlingCommit tx)
forall a. a -> Maybe a
Just (SettlingCommit tx -> Maybe (SettlingCommit tx))
-> SettlingCommit tx -> Maybe (SettlingCommit tx)
forall a b. (a -> b) -> a -> b
$ case (\TxIdType tx
claimed -> (TxIdType tx
claimed,) (Deposit tx -> (TxIdType tx, Deposit tx))
-> Maybe (Deposit tx) -> Maybe (TxIdType tx, Deposit tx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TxIdType tx -> PendingDeposits tx -> Maybe (Deposit tx)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TxIdType tx
claimed PendingDeposits tx
pendingDeposits) (TxIdType tx -> Maybe (TxIdType tx, Deposit tx))
-> Maybe (TxIdType tx) -> Maybe (TxIdType tx, Deposit tx)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe (TxIdType tx)
depositTxId of
      Just claimed :: (TxIdType tx, Deposit tx)
claimed@(TxIdType tx
_, Deposit{UTCTime
$sel:deadline:Deposit :: forall tx. Deposit tx -> UTCTime
deadline :: UTCTime
deadline})
        | UTCTime
chainTime UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
<= NominalDiffTime -> UTCTime -> UTCTime
addUTCTime (DepositPeriod -> NominalDiffTime
toNominalDiffTime DepositPeriod
depositPeriod) UTCTime
deadline -> (TxIdType tx, Deposit tx) -> SettlingCommit tx
forall tx. (TxIdType tx, Deposit tx) -> SettlingCommit tx
ContinueCommit (TxIdType tx, Deposit tx)
claimed
      -- Also for snapshots without a 'depositTxId' (before 2.4.0).
      Maybe (TxIdType tx, Deposit tx)
_ -> SettlingCommit tx
forall tx. SettlingCommit tx
DropCommit

-- | The UTxO the next request is validated against: the snapshot in flight, if
-- any, else the confirmed one.
nextRequestUTxO :: IsTx tx => CoordinatedHeadState tx -> UTxOType tx
nextRequestUTxO :: forall tx. IsTx tx => CoordinatedHeadState tx -> UTxOType tx
nextRequestUTxO CoordinatedHeadState{SeenSnapshot tx
$sel:seenSnapshot:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> SeenSnapshot tx
seenSnapshot :: SeenSnapshot tx
seenSnapshot, 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} =
  case SeenSnapshot tx
seenSnapshot of
    SeenSnapshot{Snapshot tx
$sel:snapshot:NoSeenSnapshot :: forall tx. SeenSnapshot tx -> Snapshot tx
snapshot :: Snapshot tx
snapshot} -> SnapshotVersion -> Snapshot tx -> UTxOType tx
forall tx. IsTx tx => SnapshotVersion -> Snapshot tx -> UTxOType tx
settledUTxO SnapshotVersion
version Snapshot tx
snapshot
    SeenSnapshot tx
_ -> SnapshotVersion -> Snapshot tx -> UTxOType tx
forall tx. IsTx tx => SnapshotVersion -> Snapshot tx -> UTxOType tx
settledUTxO SnapshotVersion
version (ConfirmedSnapshot tx -> Snapshot tx
forall tx. IsTx tx => ConfirmedSnapshot tx -> Snapshot tx
getSnapshot ConfirmedSnapshot tx
confirmedSnapshot)

-- | Whether a request applying these txs to this UTxO can absorb the deposit:
-- it must name no output the UTxO holds or the txs create. Deposit datums are
-- not authenticated, so anyone can name existing outputs, and absorbing such a
-- deposit would count value the ledger does not have.
absorbable :: IsTx tx => UTxOType tx -> [tx] -> UTxOType tx -> Bool
absorbable :: forall tx. IsTx tx => UTxOType tx -> [tx] -> UTxOType tx -> Bool
absorbable UTxOType tx
utxo [tx]
txs =
  let created :: UTxOType tx
created = (tx -> UTxOType tx) -> [tx] -> UTxOType tx
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap tx -> UTxOType tx
forall tx. IsTx tx => tx -> UTxOType tx
utxoFromTx [tx]
txs
   in \UTxOType tx
deposited -> UTxOType tx -> UTxOType tx -> Bool
forall tx. IsTx tx => UTxOType tx -> UTxOType tx -> Bool
namesNoneOf UTxOType tx
deposited UTxOType tx
utxo Bool -> Bool -> Bool
&& UTxOType tx -> UTxOType tx -> Bool
forall tx. IsTx tx => UTxOType tx -> UTxOType tx -> Bool
namesNoneOf UTxOType tx
deposited UTxOType tx
created

-- | Whether a deposit of the given outputs names none of the output references
-- the given UTxO holds.
namesNoneOf :: IsTx tx => UTxOType tx -> UTxOType tx -> Bool
namesNoneOf :: forall tx. IsTx tx => UTxOType tx -> UTxOType tx -> Bool
namesNoneOf UTxOType tx
deposited UTxOType tx
utxo =
  -- NOTE: remove the UTxO from the deposit, not the deposit from the UTxO: the
  -- deposit is small, so this is cheaper.
  UTxOType tx
deposited UTxOType tx -> UTxOType tx -> UTxOType tx
forall tx. IsTx tx => UTxOType tx -> UTxOType tx -> UTxOType tx
`withoutUTxO` UTxOType tx
utxo UTxOType tx -> UTxOType tx -> Bool
forall a. Eq a => a -> a -> Bool
== UTxOType tx
deposited

-- | Apply txs, refusing one that creates an output the UTxO already holds.
-- Impossible on L1, possible on L2: a deposit can name a tx's outputs before
-- that tx is submitted.
applyTransactionsWithoutCollision :: IsTx tx => Ledger tx -> ChainSlot -> UTxOType tx -> [tx] -> Either (tx, ValidationError) (UTxOType tx)
applyTransactionsWithoutCollision :: forall tx.
IsTx tx =>
Ledger tx
-> ChainSlot
-> UTxOType tx
-> [tx]
-> Either (tx, ValidationError) (UTxOType tx)
applyTransactionsWithoutCollision Ledger{$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)
apply} ChainSlot
slot =
  (UTxOType tx -> tx -> Either (tx, ValidationError) (UTxOType tx))
-> UTxOType tx
-> [tx]
-> Either (tx, ValidationError) (UTxOType tx)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM ((UTxOType tx -> tx -> Either (tx, ValidationError) (UTxOType tx))
 -> UTxOType tx
 -> [tx]
 -> Either (tx, ValidationError) (UTxOType tx))
-> (UTxOType tx
    -> tx -> Either (tx, ValidationError) (UTxOType tx))
-> UTxOType tx
-> [tx]
-> Either (tx, ValidationError) (UTxOType tx)
forall a b. (a -> b) -> a -> b
$ \UTxOType tx
utxo tx
tx ->
    if UTxOType tx -> UTxOType tx -> Bool
forall tx. IsTx tx => UTxOType tx -> UTxOType tx -> Bool
namesNoneOf (tx -> UTxOType tx
forall tx. IsTx tx => tx -> UTxOType tx
utxoFromTx tx
tx) UTxOType tx
utxo
      then ChainSlot
-> UTxOType tx
-> [tx]
-> Either (tx, ValidationError) (UTxOType tx)
apply ChainSlot
slot UTxOType tx
utxo [tx
tx]
      else (tx, ValidationError) -> Either (tx, ValidationError) (UTxOType tx)
forall a b. a -> Either a b
Left (tx
tx, Text -> ValidationError
ValidationError Text
"transaction creates an output the head already holds")

-- | 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 AccumulatorTooLarge{Int
$sel:utxoCount:AccumulatorTooLarge :: AccumulatorTooLarge -> Int
utxoCount :: Int
utxoCount, Int
$sel:maxAllowed:AccumulatorTooLarge :: AccumulatorTooLarge -> Int
maxAllowed :: Int
maxAllowed} <- ClientInput tx -> Either AccumulatorTooLarge (ClientInput tx)
forall tx.
IsTx tx =>
ClientInput tx -> Either AccumulatorTooLarge (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
$sel:currentSlot:ChainPointTime :: ChainPointTime -> ChainSlot
currentSlot :: 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, MultiSignature (Snapshot tx)
signatures :: MultiSignature (Snapshot tx)
$sel:signatures:OnInitTx :: forall tx. OnChainTx tx -> MultiSignature (Snapshot tx)
signatures}, 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
-> MultiSignature (Snapshot tx)
-> Outcome tx
forall tx.
IsTx tx =>
OpenState tx
-> ChainStateType tx
-> SnapshotNumber
-> UTCTime
-> MultiSignature (Snapshot tx)
-> Outcome tx
onOpenChainCloseTx OpenState tx
openState ChainStateType tx
newChainState SnapshotNumber
closedSnapshotNumber UTCTime
contestationDeadline MultiSignature (Snapshot tx)
signatures
      | 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
scopedDeposits 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, SnapshotNumber
$sel:snapshotNumber:OnInitTx :: forall tx. OnChainTx tx -> SnapshotNumber
snapshotNumber :: SnapshotNumber
snapshotNumber, MultiSignature (Snapshot tx)
$sel:signatures:OnInitTx :: forall tx. OnChainTx tx -> MultiSignature (Snapshot tx)
signatures :: MultiSignature (Snapshot tx)
signatures}, 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
-> PendingDeposits tx
-> OpenState tx
-> ChainStateType tx
-> SnapshotVersion
-> TxIdType tx
-> SnapshotNumber
-> MultiSignature (Snapshot tx)
-> Outcome tx
forall tx.
IsTx tx =>
Environment
-> PendingDeposits tx
-> OpenState tx
-> ChainStateType tx
-> SnapshotVersion
-> TxIdType tx
-> SnapshotNumber
-> MultiSignature (Snapshot tx)
-> Outcome tx
onOpenChainIncrementTx Environment
env (OpenState tx -> PendingDeposits tx -> PendingDeposits tx
forall tx.
IsTx tx =>
OpenState tx -> PendingDeposits tx -> PendingDeposits tx
scopedDeposits OpenState tx
openState PendingDeposits tx
pendingDeposits) OpenState tx
openState ChainStateType tx
newChainState SnapshotVersion
newVersion TxIdType tx
depositTxId SnapshotNumber
snapshotNumber MultiSignature (Snapshot tx)
signatures
    | 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, SnapshotNumber
$sel:snapshotNumber:OnInitTx :: forall tx. OnChainTx tx -> SnapshotNumber
snapshotNumber :: SnapshotNumber
snapshotNumber, MultiSignature (Snapshot tx)
$sel:signatures:OnInitTx :: forall tx. OnChainTx tx -> MultiSignature (Snapshot tx)
signatures :: MultiSignature (Snapshot tx)
signatures}, 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
-> SnapshotNumber
-> MultiSignature (Snapshot tx)
-> Outcome tx
forall tx.
IsTx tx =>
Environment
-> PendingDeposits tx
-> OpenState tx
-> ChainStateType tx
-> SnapshotVersion
-> UTxOType tx
-> SnapshotNumber
-> MultiSignature (Snapshot tx)
-> Outcome tx
onOpenChainDecrementTx Environment
env (OpenState tx -> PendingDeposits tx -> PendingDeposits tx
forall tx.
IsTx tx =>
OpenState tx -> PendingDeposits tx -> PendingDeposits tx
scopedDeposits OpenState tx
openState PendingDeposits tx
pendingDeposits) OpenState tx
openState ChainStateType tx
newChainState SnapshotVersion
newVersion UTxOType tx
distributedUTxO SnapshotNumber
snapshotNumber MultiSignature (Snapshot tx)
signatures
    | 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, MultiSignature (Snapshot tx)
$sel:signatures:OnInitTx :: forall tx. OnChainTx tx -> MultiSignature (Snapshot tx)
signatures :: MultiSignature (Snapshot tx)
signatures}, 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
-> MultiSignature (Snapshot tx)
-> Outcome tx
forall tx.
IsTx tx =>
ClosedState tx
-> ChainStateType tx
-> SnapshotNumber
-> UTCTime
-> MultiSignature (Snapshot tx)
-> Outcome tx
onClosedChainContestTx ClosedState tx
closedState ChainStateType tx
newChainState SnapshotNumber
snapshotNumber UTCTime
contestationDeadline MultiSignature (Snapshot tx)
signatures
    | 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
chainPointTime 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
-> ChainPointTime
-> OpenState tx
-> TTL
-> PendingDeposits tx
-> tx
-> Outcome tx
forall tx.
IsTx tx =>
Environment
-> Ledger tx
-> ChainPointTime
-> OpenState tx
-> TTL
-> PendingDeposits tx
-> tx
-> Outcome tx
onOpenNetworkReqTx Environment
env Ledger tx
ledger ChainPointTime
chainPointTime OpenState tx
openState TTL
ttl (OpenState tx -> PendingDeposits tx -> PendingDeposits tx
forall tx.
IsTx tx =>
OpenState tx -> PendingDeposits tx -> PendingDeposits tx
scopedDeposits 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
-> ChainPointTime
-> OpenState tx
-> TTL
-> Party
-> SnapshotVersion
-> SnapshotNumber
-> [TxIdType tx]
-> Maybe tx
-> Maybe (TxIdType tx)
-> Outcome tx
forall tx.
IsTx tx =>
Environment
-> Ledger tx
-> PendingDeposits tx
-> ChainPointTime
-> 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) ChainPointTime
chainPointTime 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
-> ChainPointTime
-> PendingDeposits tx
-> OpenState tx
-> Party
-> Signature (Snapshot tx)
-> SnapshotNumber
-> Outcome tx
forall tx.
IsTx tx =>
Environment
-> ChainPointTime
-> PendingDeposits tx
-> OpenState tx
-> Party
-> Signature (Snapshot tx)
-> SnapshotNumber
-> Outcome tx
onOpenNetworkAckSn Environment
env ChainPointTime
chainPointTime (OpenState tx -> PendingDeposits tx -> PendingDeposits tx
forall tx.
IsTx tx =>
OpenState tx -> PendingDeposits tx -> PendingDeposits tx
scopedDeposits 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
-> ChainPointTime
-> PendingDeposits tx
-> OpenState tx
-> tx
-> Outcome tx
forall tx.
IsTx tx =>
Environment
-> Ledger tx
-> TTL
-> ChainPointTime
-> PendingDeposits tx
-> OpenState tx
-> tx
-> Outcome tx
onOpenNetworkReqDec Environment
env Ledger tx
ledger TTL
ttl ChainPointTime
chainPointTime (OpenState tx -> PendingDeposits tx -> PendingDeposits tx
forall tx.
IsTx tx =>
OpenState tx -> PendingDeposits tx -> PendingDeposits tx
scopedDeposits 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}
  Network.BroadcastStalled{TTL
pendingBroadcasts :: TTL
$sel:pendingBroadcasts:PeerConnected :: Connectivity -> TTL
pendingBroadcasts, StallReason
stallReason :: StallReason
$sel:stallReason:PeerConnected :: Connectivity -> StallReason
stallReason} ->
    StateChanged tx -> Outcome tx
forall tx. StateChanged tx -> Outcome tx
newState NetworkBroadcastStalled{TTL
pendingBroadcasts :: TTL
$sel:pendingBroadcasts:NetworkConnected :: TTL
pendingBroadcasts, StallReason
stallReason :: StallReason
$sel:stallReason:NetworkConnected :: StallReason
stallReason}
  Connectivity
Network.BroadcastResumed ->
    StateChanged tx -> Outcome tx
forall tx. StateChanged tx -> Outcome tx
newState StateChanged tx
forall tx. StateChanged tx
NetworkBroadcastResumed

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}}
                  -- 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 -> CoordinatedHeadState tx -> Bool
forall tx. SnapshotVersion -> CoordinatedHeadState tx -> Bool
isReobservation SnapshotVersion
newVersion CoordinatedHeadState tx
chs ->
                      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)
                                      , seenSnapshot = seenSnapshotAfterVersionBump confirmedSnapshot seenSnapshot
                                      , 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

-- | Whether a finalized increment or decrement at 'newVersion' was applied
-- before and re-landed after a rollback. The local version never rolls back.
isReobservation :: SnapshotVersion -> CoordinatedHeadState tx -> Bool
isReobservation :: forall tx. SnapshotVersion -> CoordinatedHeadState tx -> Bool
isReobservation SnapshotVersion
newVersion CoordinatedHeadState{SnapshotVersion
$sel:version:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> SnapshotVersion
version :: SnapshotVersion
version} = SnapshotVersion
newVersion SnapshotVersion -> SnapshotVersion -> Bool
forall a. Ord a => a -> a -> Bool
<= SnapshotVersion
version

-- | The 'SeenSnapshot' after a version bump. A snapshot already in flight is
-- kept: every party has processed its 'ReqSn', so it can still complete and
-- chain the next one with the bumped version.
seenSnapshotAfterVersionBump :: IsTx tx => ConfirmedSnapshot tx -> SeenSnapshot tx -> SeenSnapshot tx
seenSnapshotAfterVersionBump :: forall tx.
IsTx tx =>
ConfirmedSnapshot tx -> SeenSnapshot tx -> SeenSnapshot tx
seenSnapshotAfterVersionBump ConfirmedSnapshot tx
confirmedSnapshot = \case
  seen :: SeenSnapshot tx
seen@SeenSnapshot{} -> SeenSnapshot tx
seen
  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}

-- | The spendable UTxO of a snapshot, given the head's current 'SnapshotVersion'.
-- A pending commit only becomes spendable once its increment has landed on
-- chain, which bumps the version past the snapshot's.
settledUTxO :: IsTx tx => SnapshotVersion -> Snapshot tx -> UTxOType tx
settledUTxO :: forall tx. IsTx tx => SnapshotVersion -> Snapshot tx -> UTxOType tx
settledUTxO SnapshotVersion
headVersion 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, SnapshotVersion
$sel:version:Snapshot :: forall tx. Snapshot tx -> SnapshotVersion
version :: SnapshotVersion
version}
  | SnapshotVersion
headVersion SnapshotVersion -> SnapshotVersion -> Bool
forall a. Ord a => a -> a -> Bool
> SnapshotVersion
version = UTxOType tx
utxo UTxOType tx -> UTxOType tx -> UTxOType tx
forall a. Semigroup a => a -> a -> a
<> UTxOType tx -> Maybe (UTxOType tx) -> UTxOType tx
forall a. a -> Maybe a -> a
fromMaybe UTxOType tx
forall a. Monoid a => a
mempty Maybe (UTxOType tx)
utxoToCommit
  | Bool
otherwise = UTxOType tx
utxo

-- | 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
  NetworkBroadcastStalled{} -> Maybe HeadId
forall a. Maybe a
Nothing
  StateChanged tx
NetworkBroadcastResumed -> 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
  NetworkBroadcastStalled{} -> HeadState tx
st
  StateChanged tx
NetworkBroadcastResumed -> 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.
                    localUTxO = foldl' (flip applyTxTo) (settledUTxO version snapshot) 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
                          }
                    }
          -- Nothing to confirm: leave the state as it is rather than crashing
          -- the node, which would also happen on every replay of the event.
          Maybe (Snapshot tx)
Nothing -> HeadState tx
st
      -- Only emitted, with the snapshot, for the 'unconfirmedSnapshot' adopted
      -- from the multisignature of an observed contest. Anything else leaves
      -- the closed head as it is, as it did before this case existed.
      Closed ClosedState tx
cst ->
        case Maybe (Snapshot tx)
mSnapshot of
          Just Snapshot tx
snapshot ->
            ClosedState tx -> HeadState tx
forall tx. ClosedState tx -> HeadState tx
Closed
              ClosedState tx
cst
                { confirmedSnapshot = ConfirmedSnapshot{snapshot, signatures}
                , unconfirmedSnapshot = Nothing
                }
          Maybe (Snapshot tx)
Nothing -> HeadState tx
st
      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 :: Snapshot tx
snapshot@Snapshot{Maybe (UTxOType tx)
$sel:utxoToDecommit:Snapshot :: forall tx. Snapshot tx -> Maybe (UTxOType tx)
utxoToDecommit :: Maybe (UTxOType tx)
utxoToDecommit}} ->
                    CoordinatedHeadState tx
coordinatedHeadState
                      { localUTxO = settledUTxO currentVersion snapshot
                      , localTxs = mempty
                      , allTxs = mempty
                      , seenSnapshot = LastSeenSnapshot snapshotNumber
                      , -- A decommit the snapshot still settles is kept: every
                        -- request at this version must carry it (see
                        -- 'onOpenNetworkReqSn'), and a side-load cannot change
                        -- the pending decommit, so the recorded tx is the one
                        -- producing it. Any other is pruned like the pending txs.
                        decommitTx = do
                          tx <- coordinatedHeadState.decommitTx
                          guard (currentVersion == snapshot.version && Just (utxoFromTx tx) == utxoToDecommit)
                          pure tx
                      , 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
              -- Also do not park a deposit the next snapshot request cannot
              -- include, see 'absorbable'.
              | Bool -> Bool
not (UTxOType tx -> [tx] -> UTxOType tx -> Bool
forall tx. IsTx tx => UTxOType tx -> [tx] -> UTxOType tx -> Bool
absorbable (CoordinatedHeadState tx -> UTxOType tx
forall tx. IsTx tx => CoordinatedHeadState tx -> UTxOType tx
nextRequestUTxO CoordinatedHeadState tx
chs) (Seq tx -> [tx]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Int -> Seq tx -> Seq tx
forall a. Int -> Seq a -> Seq a
Seq.take Int
maxTxsPerSnapshot CoordinatedHeadState tx
chs.localTxs)) Deposit tx
deposit.deposited) -> 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}}
        -- Only convergence bookkeeping: in particular an unrelated newer
        -- decommit may already be in flight and must be left alone. See #2741.
        | SnapshotVersion -> CoordinatedHeadState tx -> Bool
forall tx. SnapshotVersion -> CoordinatedHeadState tx -> Bool
isReobservation SnapshotVersion
newVersion CoordinatedHeadState tx
chs ->
            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
                      , seenSnapshot = seenSnapshotAfterVersionBump confirmedSnapshot seenSnapshot
                      , -- 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
              , 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
              }
          , 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
              , -- Keep the snapshot still collecting AckSns: a later contest
                -- may carry its full multisignature.
                $sel:unconfirmedSnapshot:ClosedState :: Maybe (Snapshot tx)
unconfirmedSnapshot = case SeenSnapshot tx
seenSnapshot of
                  SeenSnapshot{Snapshot tx
$sel:snapshot:NoSeenSnapshot :: forall tx. SeenSnapshot tx -> Snapshot tx
snapshot :: Snapshot tx
snapshot} -> Snapshot tx -> Maybe (Snapshot tx)
forall a. a -> Maybe a
Just Snapshot tx
snapshot
                  SeenSnapshot tx
_ -> Maybe (Snapshot tx)
forall a. Maybe a
Nothing
              }
      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, Maybe (Snapshot tx)
$sel:unconfirmedSnapshot:ClosedState :: forall tx. ClosedState tx -> Maybe (Snapshot tx)
unconfirmedSnapshot :: Maybe (Snapshot tx)
unconfirmedSnapshot} ->
        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
            , Maybe (Snapshot tx)
$sel:unconfirmedSnapshot:ClosedState :: Maybe (Snapshot tx)
unconfirmedSnapshot :: Maybe (Snapshot tx)
unconfirmedSnapshot
            }
      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
  NetworkBroadcastStalled{} -> ChainStateHistory tx
history
  StateChanged tx
NetworkBroadcastResumed -> 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