{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# OPTIONS_GHC -Wno-ambiguous-fields #-}
{-# OPTIONS_GHC -Wno-unused-do-bind #-}

-- | Unit tests of the protocol logic in 'HeadLogic'. These are very fine
-- grained and specific to individual steps in the protocol. More high-level of
-- the protocol logic, especially between multiple parties can be found in
-- 'Hydra.BehaviorSpec'.
module Hydra.HeadLogicSpec where

import Hydra.Prelude
import Hydra.Tx.Secret (Secret, mkSecret)
import Test.Hydra.Prelude

import Cardano.Api.UTxO qualified as UTxO
import Cardano.Ledger.Api (bodyTxL, inputsTxBodyL)
import Cardano.Slotting.Time (SystemStart (SystemStart))
import Control.Lens ((.~))
import Control.Monad (foldM)
import Data.Aeson (Result (Success), Value (..), fromJSON)
import Data.Aeson.KeyMap qualified as KeyMap
import Data.List qualified as List
import Data.Map.Strict (notMember)
import Data.Map.Strict qualified as Map
import Data.Sequence qualified as Seq
import Data.Set qualified as Set
import Hydra.API.ClientInput (ClientInput (Fanout, PartialFanout, Recover, SideLoadSnapshot))
import Hydra.API.ServerOutput (ClientMessage (..), DecommitInvalidReason (..))
import Hydra.Cardano.Api (ChainPoint (..), SlotNo (..), forceUTxO, fromLedgerTx, mkVkAddress, toLedgerTx, txOutValue, unSlotNo, pattern TxValidityUpperBound)
import Hydra.Cardano.Api.Gen (genTxIn)
import Hydra.Chain (
  ChainEvent (..),
  OnChainTx (..),
  PostChainTx (..),
  PostTxError (..),
 )
import Hydra.Chain.ChainState (ChainSlot (..), IsChainState)
import Hydra.Chain.Direct.State (ChainStateAt (..))
import Hydra.Chain.Direct.TimeHandle (TimeHandle, mkTimeHandle, slotToUTCTime)
import Hydra.HeadLogic (ClosedState (..), CoordinatedHeadState (..), Effect (..), FanoutMode (..), HeadState (..), Input (..), LogicError (..), OpenState (..), Outcome (..), PartialFanoutState (..), RequirementFailure (..), SideLoadRequirementFailure (..), StateChanged (..), TTL, WaitReason (..), aggregateState, cause, maxTxsPerSnapshot, newState, noop, selectNextIncrementalAction, setExistingDeposit, update)
import Hydra.HeadLogic.State (IdleState (..), SeenSnapshot (..), getHeadParameters, mkSeenSnapshot)
import Hydra.Ledger (Ledger (..), ValidationError (..))
import Hydra.Ledger.Cardano (cardanoLedger, mkSimpleTx)
import Hydra.Ledger.Cardano.TimeSpec (genUTCTime)
import Hydra.Ledger.Simple (SimpleChainState (..), SimpleTx (..), SimpleTxOut (..), simpleLedger)
import Hydra.Network (Connectivity)
import Hydra.Network.Message (Message (..), NetworkEvent (..))
import Hydra.Node (mkNetworkInput)
import Hydra.Node.Environment (Environment (..))
import Hydra.Node.State (ChainPointTime (..), Deposit (..), DepositStatus (Active, Expired), NodeState (..), SyncedStatus (..), initNodeState, initialChainTime)
import Hydra.Node.UnsyncedPeriod (UnsyncedPeriod (..), unsyncedPeriodToNominalDiffTime)
import Hydra.Options (defaultContestationPeriod, defaultDepositActivation, defaultDepositPeriod, defaultUnsyncedPeriod)
import Hydra.Prelude qualified as Prelude
import Hydra.Tx (HeadId)
import Hydra.Tx.Accumulator qualified as Accumulator
import Hydra.Tx.ContestationPeriod qualified as CP
import Hydra.Tx.Crypto (aggregate, generateSigningKey, sign)
import Hydra.Tx.Crypto qualified as Crypto
import Hydra.Tx.DepositPeriod (toNominalDiffTime)
import Hydra.Tx.HeadParameters (HeadParameters (..))
import Hydra.Tx.IsTx (IsTx (..))
import Hydra.Tx.Party (Party (..), deriveParty)
import Hydra.Tx.Snapshot (ConfirmedSnapshot (..), Snapshot (..), SnapshotNumber, SnapshotVersion, getSnapshot)
import Test.Gen.Cardano.Api.Typed (genBlockHeaderHash)
import Test.Hydra.API.ClientInput ()
import Test.Hydra.Chain ()
import Test.Hydra.Chain.Direct.TimeHandle (safeZone)
import Test.Hydra.HeadLogic.Input ()
import Test.Hydra.HeadLogic.State ()
import Test.Hydra.Ledger.Cardano (mkRangedTx)
import Test.Hydra.Ledger.Cardano.Fixtures (eraHistoryWithHorizonAt)
import Test.Hydra.Ledger.Simple (aValidTx, utxoRef, utxoRefs)
import Test.Hydra.Network.Message ()
import Test.Hydra.Node.Environment ()
import Test.Hydra.Node.Fixture qualified as Fixture
import Test.Hydra.Node.State ()
import Test.Hydra.Tx.Fixture (alice, aliceSk, bob, bobSk, carol, carolSk, deriveOnChainId, fanoutChunkSize, fanoutOutputThreshold, testHeadId, testHeadSeed)
import Test.Hydra.Tx.Gen (genKeyPair, genOutputFor)
import Test.QuickCheck (Property, counterexample, elements, forAll, forAllShrink, oneof, shuffle, suchThat)
import Test.QuickCheck.Gen (generate)
import Test.QuickCheck.Hedgehog (hedgehog)
import Test.QuickCheck.Monadic (assert, monadicIO, monitor, pick, run)
import Test.Util (utxoNoThunks)

spec :: Spec
spec :: Spec
spec =
  Spec -> Spec
forall a. SpecWith a -> SpecWith a
parallel (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
    let threeParties :: [Party]
threeParties = [Party
alice, Party
bob, Party
carol]
        bobEnv :: Environment
bobEnv =
          Environment
            { $sel:party:Environment :: Party
party = Party
bob
            , $sel:signingKey:Environment :: Secret (SigningKey HydraKey)
signingKey = Secret (SigningKey HydraKey)
bobSk
            , $sel:otherParties:Environment :: [Party]
otherParties = [Party
alice, Party
carol]
            , $sel:contestationPeriod:Environment :: ContestationPeriod
contestationPeriod = ContestationPeriod
defaultContestationPeriod
            , $sel:depositPeriod:Environment :: DepositPeriod
depositPeriod = DepositPeriod
defaultDepositPeriod
            , $sel:depositActivation:Environment :: DepositPeriod
depositActivation = DepositPeriod
defaultDepositActivation
            , $sel:unsyncedPeriod:Environment :: UnsyncedPeriod
unsyncedPeriod = UnsyncedPeriod
defaultUnsyncedPeriod
            , $sel:participants:Environment :: [OnChainId]
participants = Party -> OnChainId
deriveOnChainId (Party -> OnChainId) -> [Party] -> [OnChainId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Party]
threeParties
            , $sel:configuredPeers:Environment :: Text
configuredPeers = Text
""
            }
        aliceEnv :: Environment
aliceEnv =
          Environment
            { $sel:party:Environment :: Party
party = Party
alice
            , $sel:signingKey:Environment :: Secret (SigningKey HydraKey)
signingKey = Secret (SigningKey HydraKey)
aliceSk
            , $sel:otherParties:Environment :: [Party]
otherParties = [Party
bob, Party
carol]
            , $sel:contestationPeriod:Environment :: ContestationPeriod
contestationPeriod = ContestationPeriod
defaultContestationPeriod
            , $sel:depositPeriod:Environment :: DepositPeriod
depositPeriod = DepositPeriod
defaultDepositPeriod
            , $sel:depositActivation:Environment :: DepositPeriod
depositActivation = DepositPeriod
defaultDepositActivation
            , $sel:unsyncedPeriod:Environment :: UnsyncedPeriod
unsyncedPeriod = UnsyncedPeriod
defaultUnsyncedPeriod
            , $sel:participants:Environment :: [OnChainId]
participants = Party -> OnChainId
deriveOnChainId (Party -> OnChainId) -> [Party] -> [OnChainId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Party]
threeParties
            , $sel:configuredPeers:Environment :: Text
configuredPeers = Text
""
            }

    String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Coordinated Head Protocol" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
      let ledger :: Ledger SimpleTx
ledger = Ledger SimpleTx
simpleLedger

      let coordinatedHeadState :: CoordinatedHeadState SimpleTx
coordinatedHeadState =
            CoordinatedHeadState
              { $sel:localUTxO:CoordinatedHeadState :: UTxOType SimpleTx
localUTxO = UTxOType SimpleTx
forall a. Monoid a => a
mempty
              , $sel:allTxs:CoordinatedHeadState :: Map (TxIdType SimpleTx) SimpleTx
allTxs = Map (TxIdType SimpleTx) SimpleTx
forall a. Monoid a => a
mempty
              , $sel:localTxs:CoordinatedHeadState :: Seq SimpleTx
localTxs = Seq SimpleTx
forall a. Monoid a => a
mempty
              , $sel:confirmedSnapshot:CoordinatedHeadState :: ConfirmedSnapshot SimpleTx
confirmedSnapshot = HeadId -> ConfirmedSnapshot SimpleTx
forall tx. HeadId -> ConfirmedSnapshot tx
InitialSnapshot HeadId
testHeadId
              , $sel:seenSnapshot:CoordinatedHeadState :: SeenSnapshot SimpleTx
seenSnapshot = SeenSnapshot SimpleTx
forall tx. SeenSnapshot tx
NoSeenSnapshot
              , $sel:currentDepositTxId:CoordinatedHeadState :: Maybe (TxIdType SimpleTx)
currentDepositTxId = Maybe (TxIdType SimpleTx)
forall a. Maybe a
Nothing
              , $sel:decommitTx:CoordinatedHeadState :: Maybe SimpleTx
decommitTx = Maybe SimpleTx
forall a. Maybe a
Nothing
              , $sel:version:CoordinatedHeadState :: SnapshotVersion
version = SnapshotVersion
0
              }

      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"reports if a requested tx is expired" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        let inputs :: UTxOType SimpleTx
inputs = SimpleId -> UTxOType SimpleTx
utxoRef SimpleId
1
            tx :: SimpleTx
tx = SimpleId -> UTxOType SimpleTx -> UTxOType SimpleTx -> SimpleTx
SimpleTx SimpleId
2 Set SimpleTxOut
UTxOType SimpleTx
inputs Set SimpleTxOut
UTxOType SimpleTx
forall a. Monoid a => a
mempty
            ttl :: Natural
ttl = Natural
0
            reqTx :: Input SimpleTx
reqTx = Natural -> NetworkEvent (Message SimpleTx) -> Input SimpleTx
forall tx. Natural -> NetworkEvent (Message tx) -> Input tx
NetworkInput Natural
ttl (NetworkEvent (Message SimpleTx) -> Input SimpleTx)
-> NetworkEvent (Message SimpleTx) -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ ReceivedMessage{$sel:sender:ConnectivityEvent :: Party
sender = Party
alice, $sel:msg:ConnectivityEvent :: Message SimpleTx
msg = SimpleTx -> Message SimpleTx
forall tx. tx -> Message tx
ReqTx SimpleTx
tx}
            s0 :: NodeState SimpleTx
s0 = [Party] -> NodeState SimpleTx
inOpenState [Party]
threeParties

        UTCTime
now <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
s0.chainPointTime.currentSlot
        Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
s0 Input SimpleTx
reqTx Outcome SimpleTx -> (StateChanged SimpleTx -> Bool) -> IO ()
forall tx.
(HasCallStack, IsChainState tx) =>
Outcome tx -> (StateChanged tx -> Bool) -> IO ()
`hasStateChangedSatisfying` \case
          TxInvalid{SimpleTx
transaction :: SimpleTx
$sel:transaction:NetworkConnected :: forall tx. StateChanged tx -> tx
transaction} -> SimpleTx
transaction SimpleTx -> SimpleTx -> Bool
forall a. Eq a => a -> a -> Bool
== SimpleTx
tx
          StateChanged SimpleTx
_ -> Bool
False

      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"waits if a requested tx is not (yet) applicable" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        let reqTx :: Input SimpleTx
reqTx = Message SimpleTx -> Input SimpleTx
forall tx. Message tx -> Input tx
receiveMessage (Message SimpleTx -> Input SimpleTx)
-> Message SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ SimpleTx -> Message SimpleTx
forall tx. tx -> Message tx
ReqTx (SimpleTx -> Message SimpleTx) -> SimpleTx -> Message SimpleTx
forall a b. (a -> b) -> a -> b
$ SimpleId -> UTxOType SimpleTx -> UTxOType SimpleTx -> SimpleTx
SimpleTx SimpleId
2 Set SimpleTxOut
UTxOType SimpleTx
inputs Set SimpleTxOut
UTxOType SimpleTx
forall a. Monoid a => a
mempty
            inputs :: UTxOType SimpleTx
inputs = SimpleId -> UTxOType SimpleTx
utxoRef SimpleId
1
            s0 :: NodeState SimpleTx
s0 = [Party] -> NodeState SimpleTx
inOpenState [Party]
threeParties

        UTCTime
now <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
s0.chainPointTime.currentSlot
        Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
s0 Input SimpleTx
reqTx
          Outcome SimpleTx -> WaitReason SimpleTx -> IO ()
forall tx.
(HasCallStack, IsChainState tx) =>
Outcome tx -> WaitReason tx -> IO ()
`assertWait` ValidationError -> WaitReason SimpleTx
forall tx. ValidationError -> WaitReason tx
WaitOnNotApplicableTx (Text -> ValidationError
ValidationError Text
"cannot apply transaction")

      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"accepts a ReqSn with more transactions than maxTxsPerSnapshot" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        -- The cap only limits what a leader puts into a ReqSn; followers must
        -- accept larger requests, so the constant can be changed without a
        -- coordinated upgrade.
        let n :: SimpleId
n = Int -> SimpleId
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> SimpleId) -> Int -> SimpleId
forall a b. (a -> b) -> a -> b
$ Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
maxTxsPerSnapshot
            txs :: [SimpleTx]
txs = [SimpleId -> UTxOType SimpleTx -> UTxOType SimpleTx -> SimpleTx
SimpleTx SimpleId
i (SimpleId -> UTxOType SimpleTx
utxoRef SimpleId
i) (SimpleId -> UTxOType SimpleTx
utxoRef (SimpleId
i SimpleId -> SimpleId -> SimpleId
forall a. Num a => a -> a -> a
+ SimpleId
10000)) | SimpleId
i <- [SimpleId
1 .. SimpleId
n]]
            u0 :: UTxOType SimpleTx
u0 = [SimpleId] -> UTxOType SimpleTx
utxoRefs [SimpleId
1 .. SimpleId
n]
            s0 :: NodeState SimpleTx
s0 =
              [Party] -> CoordinatedHeadState SimpleTx -> NodeState SimpleTx
inOpenState' [Party]
threeParties (CoordinatedHeadState SimpleTx -> NodeState SimpleTx)
-> CoordinatedHeadState SimpleTx -> NodeState SimpleTx
forall a b. (a -> b) -> a -> b
$
                CoordinatedHeadState SimpleTx
coordinatedHeadState
                  { localUTxO = u0
                  , allTxs = Map.fromList [(txId tx, tx) | tx <- txs]
                  , localTxs = Seq.fromList txs
                  , confirmedSnapshot = ConfirmedSnapshot{snapshot = testSnapshot 0 0 [] u0, signatures = mempty}
                  }
            reqSn :: Input SimpleTx
reqSn = Message SimpleTx -> Input SimpleTx
forall tx. Message tx -> Input tx
receiveMessage (Message SimpleTx -> Input SimpleTx)
-> Message SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ SnapshotVersion
-> SnapshotNumber
-> [TxIdType SimpleTx]
-> Maybe SimpleTx
-> Maybe (TxIdType SimpleTx)
-> Message SimpleTx
forall tx.
SnapshotVersion
-> SnapshotNumber
-> [TxIdType tx]
-> Maybe tx
-> Maybe (TxIdType tx)
-> Message tx
ReqSn SnapshotVersion
0 SnapshotNumber
1 (SimpleTx -> SimpleId
SimpleTx -> TxIdType SimpleTx
forall tx. IsTx tx => tx -> TxIdType tx
txId (SimpleTx -> SimpleId) -> [SimpleTx] -> [SimpleId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [SimpleTx]
txs) Maybe SimpleTx
forall a. Maybe a
Nothing Maybe SimpleId
Maybe (TxIdType SimpleTx)
forall a. Maybe a
Nothing
        UTCTime
now <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
s0.chainPointTime.currentSlot
        Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
s0 Input SimpleTx
reqSn Outcome SimpleTx -> (Effect SimpleTx -> Bool) -> IO ()
forall tx.
(HasCallStack, IsChainState tx) =>
Outcome tx -> (Effect tx -> Bool) -> IO ()
`hasEffectSatisfying` \case
          NetworkEffect AckSn{} -> Bool
True
          Effect SimpleTx
_ -> Bool
False

      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"confirms snapshot given it receives AckSn from all parties" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        let reqSn :: Input tx
            reqSn :: forall tx. Input tx
reqSn = Message tx -> Input tx
forall tx. Message tx -> Input tx
receiveMessage (Message tx -> Input tx) -> Message tx -> Input 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
0 SnapshotNumber
1 [] Maybe tx
forall a. Maybe a
Nothing Maybe (TxIdType tx)
forall a. Maybe a
Nothing
            snapshot1 :: Snapshot SimpleTx
snapshot1 = SnapshotNumber
-> SnapshotVersion
-> [SimpleTx]
-> UTxOType SimpleTx
-> Snapshot SimpleTx
forall tx.
IsTx tx =>
SnapshotNumber
-> SnapshotVersion -> [tx] -> UTxOType tx -> Snapshot tx
testSnapshot SnapshotNumber
1 SnapshotVersion
0 [] UTxOType SimpleTx
forall a. Monoid a => a
mempty
            ackFrom :: Secret (SigningKey HydraKey) -> Party -> Input SimpleTx
ackFrom Secret (SigningKey HydraKey)
sk Party
vk = Party -> Message SimpleTx -> Input SimpleTx
forall tx. Party -> Message tx -> Input tx
receiveMessageFrom Party
vk (Message SimpleTx -> Input SimpleTx)
-> Message SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ Signature (Snapshot SimpleTx) -> SnapshotNumber -> Message SimpleTx
forall tx. Signature (Snapshot tx) -> SnapshotNumber -> Message tx
AckSn (Secret (SigningKey HydraKey)
-> Snapshot SimpleTx -> Signature (Snapshot SimpleTx)
forall a.
SignableRepresentation a =>
Secret (SigningKey HydraKey) -> a -> Signature a
sign Secret (SigningKey HydraKey)
sk Snapshot SimpleTx
snapshot1) SnapshotNumber
1
        NodeState SimpleTx
snapshotInProgress <- Environment
-> Ledger SimpleTx
-> NodeState SimpleTx
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall (m :: * -> *) tx a.
Monad m =>
Environment
-> Ledger tx -> NodeState tx -> StateT (StepState tx) m a -> m a
runHeadLogic Environment
bobEnv Ledger SimpleTx
ledger ([Party] -> NodeState SimpleTx
inOpenState [Party]
threeParties) (StateT (StepState SimpleTx) IO (NodeState SimpleTx)
 -> IO (NodeState SimpleTx))
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall a b. (a -> b) -> a -> b
$ do
          Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step Input SimpleTx
forall tx. Input tx
reqSn
          Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step (Secret (SigningKey HydraKey) -> Party -> Input SimpleTx
ackFrom Secret (SigningKey HydraKey)
carolSk Party
carol)
          Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step (Secret (SigningKey HydraKey) -> Party -> Input SimpleTx
ackFrom Secret (SigningKey HydraKey)
aliceSk Party
alice)
          StateT (StepState SimpleTx) IO (NodeState SimpleTx)
forall tx (m :: * -> *).
MonadState (StepState tx) m =>
m (NodeState tx)
getState

        NodeState SimpleTx -> Maybe (Snapshot SimpleTx)
forall tx. IsTx tx => NodeState tx -> Maybe (Snapshot tx)
getConfirmedSnapshot NodeState SimpleTx
snapshotInProgress Maybe (Snapshot SimpleTx) -> Maybe (Snapshot SimpleTx) -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Snapshot SimpleTx -> Maybe (Snapshot SimpleTx)
forall a. a -> Maybe a
Just (SnapshotNumber
-> SnapshotVersion
-> [SimpleTx]
-> UTxOType SimpleTx
-> Snapshot SimpleTx
forall tx.
IsTx tx =>
SnapshotNumber
-> SnapshotVersion -> [tx] -> UTxOType tx -> Snapshot tx
testSnapshot SnapshotNumber
0 SnapshotVersion
0 [] Set SimpleTxOut
UTxOType SimpleTx
forall a. Monoid a => a
mempty)

        NodeState SimpleTx
snapshotConfirmed <-
          Environment
-> Ledger SimpleTx
-> NodeState SimpleTx
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall (m :: * -> *) tx a.
Monad m =>
Environment
-> Ledger tx -> NodeState tx -> StateT (StepState tx) m a -> m a
runHeadLogic Environment
bobEnv Ledger SimpleTx
ledger NodeState SimpleTx
snapshotInProgress (StateT (StepState SimpleTx) IO (NodeState SimpleTx)
 -> IO (NodeState SimpleTx))
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall a b. (a -> b) -> a -> b
$ do
            Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step (Secret (SigningKey HydraKey) -> Party -> Input SimpleTx
ackFrom Secret (SigningKey HydraKey)
bobSk Party
bob)
            StateT (StepState SimpleTx) IO (NodeState SimpleTx)
forall tx (m :: * -> *).
MonadState (StepState tx) m =>
m (NodeState tx)
getState
        NodeState SimpleTx -> Maybe (Snapshot SimpleTx)
forall tx. IsTx tx => NodeState tx -> Maybe (Snapshot tx)
getConfirmedSnapshot NodeState SimpleTx
snapshotConfirmed Maybe (Snapshot SimpleTx) -> Maybe (Snapshot SimpleTx) -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Snapshot SimpleTx -> Maybe (Snapshot SimpleTx)
forall a. a -> Maybe a
Just Snapshot SimpleTx
snapshot1

      String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"ReqSn" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
        String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"prunes local txs in order" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
          -- Given a list of transactions each depending on the previous. If a
          -- prefix gets snapshotted, the suffix still stays in the local txs.
          let tx1 :: SimpleTx
tx1 = SimpleId -> UTxOType SimpleTx -> UTxOType SimpleTx -> SimpleTx
SimpleTx SimpleId
1 Set SimpleTxOut
UTxOType SimpleTx
forall a. Monoid a => a
mempty (SimpleId -> UTxOType SimpleTx
utxoRef SimpleId
2) -- No inputs, requires no specific starting state
              tx2 :: SimpleTx
tx2 = SimpleId -> UTxOType SimpleTx -> UTxOType SimpleTx -> SimpleTx
SimpleTx SimpleId
2 (SimpleId -> UTxOType SimpleTx
utxoRef SimpleId
2) (SimpleId -> UTxOType SimpleTx
utxoRef SimpleId
3)
              tx3 :: SimpleTx
tx3 = SimpleId -> UTxOType SimpleTx -> UTxOType SimpleTx -> SimpleTx
SimpleTx SimpleId
3 (SimpleId -> UTxOType SimpleTx
utxoRef SimpleId
3) (SimpleId -> UTxOType SimpleTx
utxoRef SimpleId
4)
              s0 :: NodeState SimpleTx
s0 = [Party] -> NodeState SimpleTx
inOpenState [Party]
threeParties

          -- XXX: this is hiding unexpected 'Error' outcomes
          NodeState SimpleTx
s <- Environment
-> Ledger SimpleTx
-> NodeState SimpleTx
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall (m :: * -> *) tx a.
Monad m =>
Environment
-> Ledger tx -> NodeState tx -> StateT (StepState tx) m a -> m a
runHeadLogic Environment
bobEnv Ledger SimpleTx
ledger NodeState SimpleTx
s0 (StateT (StepState SimpleTx) IO (NodeState SimpleTx)
 -> IO (NodeState SimpleTx))
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall a b. (a -> b) -> a -> b
$ do
            Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step (Input SimpleTx
 -> StateT (StepState SimpleTx) IO (Outcome SimpleTx))
-> Input SimpleTx
-> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall a b. (a -> b) -> a -> b
$ Message SimpleTx -> Input SimpleTx
forall tx. Message tx -> Input tx
receiveMessage (Message SimpleTx -> Input SimpleTx)
-> Message SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ SimpleTx -> Message SimpleTx
forall tx. tx -> Message tx
ReqTx SimpleTx
tx1
            Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step (Input SimpleTx
 -> StateT (StepState SimpleTx) IO (Outcome SimpleTx))
-> Input SimpleTx
-> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall a b. (a -> b) -> a -> b
$ Message SimpleTx -> Input SimpleTx
forall tx. Message tx -> Input tx
receiveMessage (Message SimpleTx -> Input SimpleTx)
-> Message SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ SimpleTx -> Message SimpleTx
forall tx. tx -> Message tx
ReqTx SimpleTx
tx2
            Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step (Input SimpleTx
 -> StateT (StepState SimpleTx) IO (Outcome SimpleTx))
-> Input SimpleTx
-> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall a b. (a -> b) -> a -> b
$ Message SimpleTx -> Input SimpleTx
forall tx. Message tx -> Input tx
receiveMessage (Message SimpleTx -> Input SimpleTx)
-> Message SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ SimpleTx -> Message SimpleTx
forall tx. tx -> Message tx
ReqTx SimpleTx
tx3
            Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step (Input SimpleTx
 -> StateT (StepState SimpleTx) IO (Outcome SimpleTx))
-> Input SimpleTx
-> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall a b. (a -> b) -> a -> b
$ Message SimpleTx -> Input SimpleTx
forall tx. Message tx -> Input tx
receiveMessage (Message SimpleTx -> Input SimpleTx)
-> Message SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ SnapshotVersion
-> SnapshotNumber
-> [TxIdType SimpleTx]
-> Maybe SimpleTx
-> Maybe (TxIdType SimpleTx)
-> Message SimpleTx
forall tx.
SnapshotVersion
-> SnapshotNumber
-> [TxIdType tx]
-> Maybe tx
-> Maybe (TxIdType tx)
-> Message tx
ReqSn SnapshotVersion
0 SnapshotNumber
1 [TxIdType SimpleTx
1] Maybe SimpleTx
forall a. Maybe a
Nothing Maybe (TxIdType SimpleTx)
forall a. Maybe a
Nothing
            StateT (StepState SimpleTx) IO (NodeState SimpleTx)
forall tx (m :: * -> *).
MonadState (StepState tx) m =>
m (NodeState tx)
getState

          case NodeState SimpleTx -> HeadState SimpleTx
forall tx. NodeState tx -> HeadState tx
headState NodeState SimpleTx
s of
            Open OpenState{$sel:coordinatedHeadState:OpenState :: forall tx. OpenState tx -> CoordinatedHeadState tx
coordinatedHeadState = CoordinatedHeadState{Seq SimpleTx
$sel:localTxs:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> Seq tx
localTxs :: Seq SimpleTx
localTxs}} -> do
              Seq SimpleTx
localTxs Seq SimpleTx -> Seq SimpleTx -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` [SimpleTx] -> Seq SimpleTx
forall a. [a] -> Seq a
Seq.fromList [SimpleTx
tx2, SimpleTx
tx3]
            HeadState SimpleTx
_ -> String -> IO ()
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"expected Open state"

      String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Deposit" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
        let 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
        String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"on tick, ignores deposits from other heads when picking the next active deposit for ReqSn" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
          UTCTime
now <- IO UTCTime
forall (m :: * -> *). MonadTime m => m UTCTime
getCurrentTime
          HeadId
otherHeadId :: HeadId <- Gen HeadId -> IO HeadId
forall a. Gen a -> IO a
generate Gen HeadId
forall a. Arbitrary a => Gen a
arbitrary
          let depositTime :: NominalDiffTime -> UTCTime
depositTime = UTCTime -> NominalDiffTime -> UTCTime
plusTime UTCTime
now
              deadline :: UTCTime
deadline = NominalDiffTime -> UTCTime
depositTime NominalDiffTime
5 UTCTime -> NominalDiffTime -> UTCTime
`plusTime` DepositPeriod -> NominalDiffTime
toNominalDiffTime Environment
aliceEnv.depositPeriod UTCTime -> NominalDiffTime -> UTCTime
`plusTime` DepositPeriod -> NominalDiffTime
toNominalDiffTime Environment
aliceEnv.depositPeriod
              deposit1 :: Deposit SimpleTx
deposit1 = Deposit{$sel:headId:Deposit :: HeadId
headId = HeadId
otherHeadId, $sel:deposited:Deposit :: UTxOType SimpleTx
deposited = SimpleId -> UTxOType SimpleTx
utxoRef SimpleId
1, $sel:created:Deposit :: UTCTime
created = NominalDiffTime -> UTCTime
depositTime NominalDiffTime
1, UTCTime
deadline :: UTCTime
$sel:deadline:Deposit :: UTCTime
deadline, $sel:status:Deposit :: DepositStatus
status = DepositStatus
Active}
              deposit2 :: Deposit SimpleTx
deposit2 = Deposit{$sel:headId:Deposit :: HeadId
headId = HeadId
testHeadId, $sel:deposited:Deposit :: UTxOType SimpleTx
deposited = SimpleId -> UTxOType SimpleTx
utxoRef SimpleId
2, $sel:created:Deposit :: UTCTime
created = NominalDiffTime -> UTCTime
depositTime NominalDiffTime
2, UTCTime
deadline :: UTCTime
$sel:deadline:Deposit :: UTCTime
deadline, $sel:status:Deposit :: DepositStatus
status = DepositStatus
Active}
              -- open state with pending deposits from another head
              party :: [Party]
party = [Party
alice]
              openState :: NodeState SimpleTx
openState = ([Party] -> NodeState SimpleTx
inOpenState [Party]
party){pendingDeposits = Map.fromList [(1, deposit1), (2, deposit2)]}
          let input :: Input SimpleTx
input = ChainEvent SimpleTx -> Input SimpleTx
forall tx. ChainEvent tx -> Input tx
ChainInput (ChainEvent SimpleTx -> Input SimpleTx)
-> ChainEvent SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ Tick{$sel:chainTime:Observation :: UTCTime
chainTime = NominalDiffTime -> UTCTime
depositTime NominalDiffTime
3, $sel:chainPoint:Observation :: ChainPointType SimpleTx
chainPoint = ChainSlot
ChainPointType SimpleTx
3}

          let outcome :: Outcome SimpleTx
outcome = Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
aliceEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
openState Input SimpleTx
input

          Outcome SimpleTx
outcome Outcome SimpleTx -> (Effect SimpleTx -> Bool) -> IO ()
forall tx.
(HasCallStack, IsChainState tx) =>
Outcome tx -> (Effect tx -> Bool) -> IO ()
`hasEffectSatisfying` \case
            NetworkEffect ReqSn{Maybe (TxIdType SimpleTx)
depositTxId :: Maybe (TxIdType SimpleTx)
$sel:depositTxId:ReqTx :: forall tx. Message tx -> Maybe (TxIdType tx)
depositTxId} -> Maybe SimpleId
Maybe (TxIdType SimpleTx)
depositTxId Maybe SimpleId -> Maybe SimpleId -> Bool
forall a. Eq a => a -> a -> Bool
== SimpleId -> Maybe SimpleId
forall a. a -> Maybe a
Just SimpleId
2
            Effect SimpleTx
_ -> Bool
False

        String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"makes a deposit spendable on L2 only after its on-chain increment" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
          -- Regression: a deposit committed via an increment snapshot lives in
          -- 'utxoToCommit' until the on-chain increment (CommitFinalized). It must
          -- not be spendable on L2 before then; otherwise the same deposit UTxO can
          -- be spent once per snapshot round (it is re-injected into localUTxO on
          -- every SnapshotRequested), inflating the L2 balance. It must become
          -- spendable once the increment is observed. We use the SAME tx for both
          -- checks so the pre-increment rejection is clearly about the deposit's
          -- availability, not a malformed tx.
          UTCTime
now <- IO UTCTime
forall (m :: * -> *). MonadTime m => m UTCTime
getCurrentTime
          let aliceEnv' :: Environment
aliceEnv' =
                Environment
aliceEnv
                  { depositPeriod = 60
                  , depositActivation = 60
                  , otherParties = []
                  , participants = deriveOnChainId <$> [alice]
                  }
              depositTime :: NominalDiffTime -> UTCTime
depositTime = UTCTime -> NominalDiffTime -> UTCTime
plusTime UTCTime
now
              depositTxId :: SimpleId
depositTxId = SimpleId
42 :: Integer
              depositedUtxo :: UTxOType SimpleTx
depositedUtxo = SimpleId -> UTxOType SimpleTx
utxoRef SimpleId
depositTxId
              deposit :: OnChainTx SimpleTx
deposit =
                OnDepositTx
                  { $sel:headId:OnInitTx :: HeadId
headId = HeadId
testHeadId
                  , SimpleId
TxIdType SimpleTx
depositTxId :: SimpleId
$sel:depositTxId:OnInitTx :: TxIdType SimpleTx
depositTxId
                  , $sel:deposited:OnInitTx :: UTxOType SimpleTx
deposited = Set SimpleTxOut
UTxOType SimpleTx
depositedUtxo
                  , $sel:created:OnInitTx :: UTCTime
created = NominalDiffTime -> UTCTime
depositTime NominalDiffTime
1
                  , $sel:deadline:OnInitTx :: UTCTime
deadline = NominalDiffTime -> UTCTime
depositTime NominalDiffTime
600
                  }
              activateTick :: Input SimpleTx
activateTick =
                ChainEvent SimpleTx -> Input SimpleTx
forall tx. ChainEvent tx -> Input tx
ChainInput (ChainEvent SimpleTx -> Input SimpleTx)
-> ChainEvent SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$
                  Tick
                    { $sel:chainTime:Observation :: UTCTime
chainTime = NominalDiffTime -> UTCTime
depositTime NominalDiffTime
2 UTCTime -> NominalDiffTime -> UTCTime
`plusTime` DepositPeriod -> NominalDiffTime
toNominalDiffTime Environment
aliceEnv'.depositPeriod
                    , $sel:chainPoint:Observation :: ChainPointType SimpleTx
chainPoint = ChainPointType SimpleTx
2
                    }
              -- Spends the deposited UTxO; applicable iff that UTxO is spendable.
              spendDeposit :: SimpleTx
spendDeposit = SimpleId -> UTxOType SimpleTx -> UTxOType SimpleTx -> SimpleTx
SimpleTx SimpleId
100 Set SimpleTxOut
UTxOType SimpleTx
depositedUtxo (SimpleId -> UTxOType SimpleTx
utxoRef SimpleId
100)

          -- Observe + activate the deposit, then request the increment snapshot
          -- (this is where localUTxO is rebuilt).
          NodeState SimpleTx
s <- Environment
-> Ledger SimpleTx
-> NodeState SimpleTx
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall (m :: * -> *) tx a.
Monad m =>
Environment
-> Ledger tx -> NodeState tx -> StateT (StepState tx) m a -> m a
runHeadLogic Environment
aliceEnv' Ledger SimpleTx
ledger ([Party] -> NodeState SimpleTx
inOpenState [Party
alice]) (StateT (StepState SimpleTx) IO (NodeState SimpleTx)
 -> IO (NodeState SimpleTx))
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall a b. (a -> b) -> a -> b
$ do
            Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step (ChainSlot -> OnChainTx SimpleTx -> Input SimpleTx
observeTxAtSlot ChainSlot
1 OnChainTx SimpleTx
deposit)
            Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step Input SimpleTx
activateTick
            Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step (Message SimpleTx -> Input SimpleTx
forall tx. Message tx -> Input tx
receiveMessage (Message SimpleTx -> Input SimpleTx)
-> Message SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ SnapshotVersion
-> SnapshotNumber
-> [TxIdType SimpleTx]
-> Maybe SimpleTx
-> Maybe (TxIdType SimpleTx)
-> Message SimpleTx
forall tx.
SnapshotVersion
-> SnapshotNumber
-> [TxIdType tx]
-> Maybe tx
-> Maybe (TxIdType tx)
-> Message tx
ReqSn SnapshotVersion
0 SnapshotNumber
1 [] Maybe SimpleTx
forall a. Maybe a
Nothing (SimpleId -> Maybe SimpleId
forall a. a -> Maybe a
Just SimpleId
depositTxId))
            StateT (StepState SimpleTx) IO (NodeState SimpleTx)
forall tx (m :: * -> *).
MonadState (StepState tx) m =>
m (NodeState tx)
getState

          -- Before the on-chain increment lands, the deposit is NOT spendable: the
          -- tx is deferred as not-yet-applicable (it would apply if the deposit were
          -- available, as the post-increment check below shows).
          UTCTime
now' <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
s.chainPointTime.currentSlot
          Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
aliceEnv' Ledger SimpleTx
ledger UTCTime
now' NodeState SimpleTx
s (Message SimpleTx -> Input SimpleTx
forall tx. Message tx -> Input tx
receiveMessage (Message SimpleTx -> Input SimpleTx)
-> Message SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ SimpleTx -> Message SimpleTx
forall tx. tx -> Message tx
ReqTx SimpleTx
spendDeposit)
            Outcome SimpleTx -> WaitReason SimpleTx -> IO ()
forall tx.
(HasCallStack, IsChainState tx) =>
Outcome tx -> WaitReason tx -> IO ()
`assertWait` ValidationError -> WaitReason SimpleTx
forall tx. ValidationError -> WaitReason tx
WaitOnNotApplicableTx (Text -> ValidationError
ValidationError Text
"cannot apply transaction")

          -- Once the increment is observed on-chain (CommitFinalized), the SAME tx
          -- becomes applicable.
          NodeState SimpleTx
sIncremented <- Environment
-> Ledger SimpleTx
-> NodeState SimpleTx
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall (m :: * -> *) tx a.
Monad m =>
Environment
-> Ledger tx -> NodeState tx -> StateT (StepState tx) m a -> m a
runHeadLogic Environment
aliceEnv' Ledger SimpleTx
ledger NodeState SimpleTx
s (StateT (StepState SimpleTx) IO (NodeState SimpleTx)
 -> IO (NodeState SimpleTx))
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall a b. (a -> b) -> a -> b
$ do
            Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step (ChainSlot -> OnChainTx SimpleTx -> Input SimpleTx
observeTxAtSlot ChainSlot
3 OnIncrementTx{$sel:headId:OnInitTx :: HeadId
headId = HeadId
testHeadId, $sel:newVersion:OnInitTx :: SnapshotVersion
newVersion = SnapshotVersion
1, SimpleId
TxIdType SimpleTx
depositTxId :: SimpleId
$sel:depositTxId:OnInitTx :: TxIdType SimpleTx
depositTxId})
            StateT (StepState SimpleTx) IO (NodeState SimpleTx)
forall tx (m :: * -> *).
MonadState (StepState tx) m =>
m (NodeState tx)
getState
          UTCTime
now'' <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
sIncremented.chainPointTime.currentSlot
          Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
aliceEnv' Ledger SimpleTx
ledger UTCTime
now'' NodeState SimpleTx
sIncremented (Message SimpleTx -> Input SimpleTx
forall tx. Message tx -> Input tx
receiveMessage (Message SimpleTx -> Input SimpleTx)
-> Message SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ SimpleTx -> Message SimpleTx
forall tx. tx -> Message tx
ReqTx SimpleTx
spendDeposit)
            Outcome SimpleTx -> (StateChanged SimpleTx -> Bool) -> IO ()
forall tx.
(HasCallStack, IsChainState tx) =>
Outcome tx -> (StateChanged tx -> Bool) -> IO ()
`hasStateChangedSatisfying` \case
              TransactionAppliedToLocalUTxO{SimpleTx
tx :: SimpleTx
$sel:tx:NetworkConnected :: forall tx. StateChanged tx -> tx
tx} -> SimpleTx
tx SimpleTx -> SimpleTx -> Bool
forall a. Eq a => a -> a -> Bool
== SimpleTx
spendDeposit
              StateChanged SimpleTx
_ -> Bool
False

        String -> (HeadId -> IO ()) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"does not track depositTx of another head" ((HeadId -> IO ()) -> Spec) -> (HeadId -> IO ()) -> Spec
forall a b. (a -> b) -> a -> b
$ \HeadId
otherHeadId -> do
          let depositOtherHead :: Input SimpleTx
depositOtherHead =
                OnChainTx SimpleTx -> Input SimpleTx
observeTx (OnChainTx SimpleTx -> Input SimpleTx)
-> OnChainTx SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$
                  OnDepositTx
                    { $sel:headId:OnInitTx :: HeadId
headId = HeadId
otherHeadId
                    , $sel:deposited:OnInitTx :: UTxOType SimpleTx
deposited = Set SimpleTxOut
UTxOType SimpleTx
forall a. Monoid a => a
mempty
                    , $sel:depositTxId:OnInitTx :: TxIdType SimpleTx
depositTxId = SimpleId
TxIdType SimpleTx
1
                    , $sel:created:OnInitTx :: UTCTime
created = Gen UTCTime
genUTCTime Gen UTCTime -> Int -> UTCTime
forall a. Gen a -> Int -> a
`generateWith` Int
41
                    , $sel:deadline:OnInitTx :: UTCTime
deadline = Gen UTCTime
genUTCTime Gen UTCTime -> Int -> UTCTime
forall a. Gen a -> Int -> a
`generateWith` Int
42
                    }
              s0 :: NodeState SimpleTx
s0 = [Party] -> NodeState SimpleTx
inOpenState [Party]
threeParties
          UTCTime
now <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
s0.chainPointTime.currentSlot
          Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
s0 Input SimpleTx
depositOtherHead Outcome SimpleTx -> (StateChanged SimpleTx -> Bool) -> IO ()
forall tx.
(HasCallStack, IsChainState tx) =>
Outcome tx -> (StateChanged tx -> Bool) -> IO ()
`hasNoStateChangedSatisfying` \case
            DepositRecorded{HeadId
headId :: HeadId
$sel:headId:NetworkConnected :: forall tx. StateChanged tx -> HeadId
headId} -> HeadId
headId HeadId -> HeadId -> Bool
forall a. Eq a => a -> a -> Bool
== HeadId
otherHeadId
            StateChanged SimpleTx
_ -> Bool
False

        String -> (HeadId -> IO ()) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"does not emit DepositRecovered for OnRecoverTx of another head while Open" ((HeadId -> IO ()) -> Spec) -> (HeadId -> IO ()) -> Spec
forall a b. (a -> b) -> a -> b
$ \HeadId
otherHeadId -> do
          let recoverOtherHead :: Input SimpleTx
recoverOtherHead =
                OnChainTx SimpleTx -> Input SimpleTx
observeTx (OnChainTx SimpleTx -> Input SimpleTx)
-> OnChainTx SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$
                  OnRecoverTx
                    { $sel:headId:OnInitTx :: HeadId
headId = HeadId
otherHeadId
                    , $sel:recoveredTxId:OnInitTx :: TxIdType SimpleTx
recoveredTxId = SimpleId
TxIdType SimpleTx
1
                    , $sel:recoveredUTxO:OnInitTx :: UTxOType SimpleTx
recoveredUTxO = Set SimpleTxOut
UTxOType SimpleTx
forall a. Monoid a => a
mempty
                    }
              s0 :: NodeState SimpleTx
s0 = [Party] -> NodeState SimpleTx
inOpenState [Party]
threeParties
          UTCTime
now <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
s0.chainPointTime.currentSlot
          Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
s0 Input SimpleTx
recoverOtherHead Outcome SimpleTx -> (StateChanged SimpleTx -> Bool) -> IO ()
forall tx.
(HasCallStack, IsChainState tx) =>
Outcome tx -> (StateChanged tx -> Bool) -> IO ()
`hasNoStateChangedSatisfying` \case
            DepositRecovered{HeadId
$sel:headId:NetworkConnected :: forall tx. StateChanged tx -> HeadId
headId :: HeadId
headId} -> HeadId
headId HeadId -> HeadId -> Bool
forall a. Eq a => a -> a -> Bool
== HeadId
otherHeadId
            StateChanged SimpleTx
_ -> Bool
False

        String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"emits DepositRecovered for OnRecoverTx of previous head's deposit while new head is Open" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
          UTCTime
now <- IO UTCTime
forall (m :: * -> *). MonadTime m => m UTCTime
getCurrentTime
          let depositTxId' :: SimpleId
depositTxId' = SimpleId
1
              depositedUtxo :: UTxOType SimpleTx
depositedUtxo = SimpleId -> UTxOType SimpleTx
utxoRef SimpleId
1
              deposit :: Deposit SimpleTx
deposit =
                Deposit
                  { $sel:headId:Deposit :: HeadId
headId = HeadId
testHeadId
                  , $sel:deposited:Deposit :: UTxOType SimpleTx
deposited = Set SimpleTxOut
UTxOType SimpleTx
depositedUtxo
                  , $sel:created:Deposit :: UTCTime
created = UTCTime
now
                  , $sel:deadline:Deposit :: UTCTime
deadline = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
3600 UTCTime
now
                  , $sel:status:Deposit :: DepositStatus
status = DepositStatus
Active
                  }
              s0 :: NodeState SimpleTx
s0 = ([Party] -> NodeState SimpleTx
inOpenState [Party]
threeParties){pendingDeposits = Map.singleton depositTxId' deposit}
              recoverOldHead :: Input SimpleTx
recoverOldHead = OnChainTx SimpleTx -> Input SimpleTx
observeTx OnRecoverTx{$sel:headId:OnInitTx :: HeadId
headId = HeadId
testHeadId, $sel:recoveredTxId:OnInitTx :: TxIdType SimpleTx
recoveredTxId = SimpleId
TxIdType SimpleTx
depositTxId', $sel:recoveredUTxO:OnInitTx :: UTxOType SimpleTx
recoveredUTxO = Set SimpleTxOut
UTxOType SimpleTx
depositedUtxo}
          UTCTime
now' <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
s0.chainPointTime.currentSlot
          Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger UTCTime
now' NodeState SimpleTx
s0 Input SimpleTx
recoverOldHead
            Outcome SimpleTx -> (StateChanged SimpleTx -> Bool) -> IO ()
forall tx.
(HasCallStack, IsChainState tx) =>
Outcome tx -> (StateChanged tx -> Bool) -> IO ()
`hasStateChangedSatisfying` \case
              DepositRecovered{HeadId
$sel:headId:NetworkConnected :: forall tx. StateChanged tx -> HeadId
headId :: HeadId
headId, TxIdType SimpleTx
depositTxId :: TxIdType SimpleTx
$sel:depositTxId:NetworkConnected :: forall tx. StateChanged tx -> TxIdType tx
depositTxId, UTxOType SimpleTx
recovered :: UTxOType SimpleTx
$sel:recovered:NetworkConnected :: forall tx. StateChanged tx -> UTxOType tx
recovered} ->
                HeadId
headId HeadId -> HeadId -> Bool
forall a. Eq a => a -> a -> Bool
== HeadId
testHeadId Bool -> Bool -> Bool
&& SimpleId
TxIdType SimpleTx
depositTxId SimpleId -> SimpleId -> Bool
forall a. Eq a => a -> a -> Bool
== SimpleId
depositTxId' Bool -> Bool -> Bool
&& Set SimpleTxOut
UTxOType SimpleTx
recovered Set SimpleTxOut -> Set SimpleTxOut -> Bool
forall a. Eq a => a -> a -> Bool
== Set SimpleTxOut
depositedUtxo
              StateChanged SimpleTx
_ -> Bool
False

        String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"emits DepositRecorded for own head while Closed" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
          let depositTxId' :: SimpleId
depositTxId' = SimpleId
1
              depositedUtxo :: UTxOType SimpleTx
depositedUtxo = SimpleId -> UTxOType SimpleTx
utxoRef SimpleId
1
          let depositOwnHead :: Input SimpleTx
depositOwnHead =
                OnChainTx SimpleTx -> Input SimpleTx
observeTx (OnChainTx SimpleTx -> Input SimpleTx)
-> OnChainTx SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$
                  OnDepositTx
                    { $sel:headId:OnInitTx :: HeadId
headId = HeadId
testHeadId
                    , $sel:deposited:OnInitTx :: UTxOType SimpleTx
deposited = Set SimpleTxOut
UTxOType SimpleTx
depositedUtxo
                    , $sel:depositTxId:OnInitTx :: TxIdType SimpleTx
depositTxId = SimpleId
TxIdType SimpleTx
depositTxId'
                    , $sel:created:OnInitTx :: UTCTime
created = Gen UTCTime
genUTCTime Gen UTCTime -> Int -> UTCTime
forall a. Gen a -> Int -> a
`generateWith` Int
41
                    , $sel:deadline:OnInitTx :: UTCTime
deadline = Gen UTCTime
genUTCTime Gen UTCTime -> Int -> UTCTime
forall a. Gen a -> Int -> a
`generateWith` Int
42
                    }
              s0 :: NodeState SimpleTx
s0 = [Party] -> NodeState SimpleTx
inClosedState [Party]
threeParties
          UTCTime
now <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
s0.chainPointTime.currentSlot
          Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
aliceEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
s0 Input SimpleTx
depositOwnHead Outcome SimpleTx -> (StateChanged SimpleTx -> Bool) -> IO ()
forall tx.
(HasCallStack, IsChainState tx) =>
Outcome tx -> (StateChanged tx -> Bool) -> IO ()
`hasStateChangedSatisfying` \case
            DepositRecorded{HeadId
$sel:headId:NetworkConnected :: forall tx. StateChanged tx -> HeadId
headId :: HeadId
headId, TxIdType SimpleTx
$sel:depositTxId:NetworkConnected :: forall tx. StateChanged tx -> TxIdType tx
depositTxId :: TxIdType SimpleTx
depositTxId, UTxOType SimpleTx
deposited :: UTxOType SimpleTx
$sel:deposited:NetworkConnected :: forall tx. StateChanged tx -> UTxOType tx
deposited} -> HeadId
headId HeadId -> HeadId -> Bool
forall a. Eq a => a -> a -> Bool
== HeadId
testHeadId Bool -> Bool -> Bool
&& SimpleId
TxIdType SimpleTx
depositTxId SimpleId -> SimpleId -> Bool
forall a. Eq a => a -> a -> Bool
== SimpleId
depositTxId' Bool -> Bool -> Bool
&& Set SimpleTxOut
UTxOType SimpleTx
deposited Set SimpleTxOut -> Set SimpleTxOut -> Bool
forall a. Eq a => a -> a -> Bool
== Set SimpleTxOut
depositedUtxo
            StateChanged SimpleTx
_ -> Bool
False

        String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"emits DepositRecovered for own head while Closed" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
          UTCTime
now <- IO UTCTime
forall (m :: * -> *). MonadTime m => m UTCTime
getCurrentTime
          let ownDepositId :: SimpleId
ownDepositId = SimpleId
1
              recoveredUtxo :: UTxOType SimpleTx
recoveredUtxo = SimpleId -> UTxOType SimpleTx
utxoRef SimpleId
1
              ownDeposit :: Deposit SimpleTx
ownDeposit =
                Deposit
                  { $sel:headId:Deposit :: HeadId
headId = HeadId
testHeadId
                  , $sel:deposited:Deposit :: UTxOType SimpleTx
deposited = Set SimpleTxOut
UTxOType SimpleTx
recoveredUtxo
                  , $sel:created:Deposit :: UTCTime
created = UTCTime
now
                  , $sel:deadline:Deposit :: UTCTime
deadline = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
3600 UTCTime
now
                  , $sel:status:Deposit :: DepositStatus
status = DepositStatus
Active
                  }
              s0 :: NodeState SimpleTx
s0 = ([Party] -> NodeState SimpleTx
inClosedState [Party]
threeParties){pendingDeposits = Map.singleton ownDepositId ownDeposit}
              recoverOwnDeposit :: Input SimpleTx
recoverOwnDeposit =
                OnChainTx SimpleTx -> Input SimpleTx
observeTx (OnChainTx SimpleTx -> Input SimpleTx)
-> OnChainTx SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$
                  OnRecoverTx
                    { $sel:headId:OnInitTx :: HeadId
headId = HeadId
testHeadId
                    , $sel:recoveredTxId:OnInitTx :: TxIdType SimpleTx
recoveredTxId = SimpleId
TxIdType SimpleTx
ownDepositId
                    , $sel:recoveredUTxO:OnInitTx :: UTxOType SimpleTx
recoveredUTxO = Set SimpleTxOut
UTxOType SimpleTx
recoveredUtxo
                    }
          UTCTime
now' <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
s0.chainPointTime.currentSlot
          Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
aliceEnv Ledger SimpleTx
ledger UTCTime
now' NodeState SimpleTx
s0 Input SimpleTx
recoverOwnDeposit Outcome SimpleTx -> (StateChanged SimpleTx -> Bool) -> IO ()
forall tx.
(HasCallStack, IsChainState tx) =>
Outcome tx -> (StateChanged tx -> Bool) -> IO ()
`hasStateChangedSatisfying` \case
            DepositRecovered{HeadId
$sel:headId:NetworkConnected :: forall tx. StateChanged tx -> HeadId
headId :: HeadId
headId, TxIdType SimpleTx
$sel:depositTxId:NetworkConnected :: forall tx. StateChanged tx -> TxIdType tx
depositTxId :: TxIdType SimpleTx
depositTxId, UTxOType SimpleTx
$sel:recovered:NetworkConnected :: forall tx. StateChanged tx -> UTxOType tx
recovered :: UTxOType SimpleTx
recovered} -> HeadId
headId HeadId -> HeadId -> Bool
forall a. Eq a => a -> a -> Bool
== HeadId
testHeadId Bool -> Bool -> Bool
&& SimpleId
TxIdType SimpleTx
depositTxId SimpleId -> SimpleId -> Bool
forall a. Eq a => a -> a -> Bool
== SimpleId
ownDepositId Bool -> Bool -> Bool
&& Set SimpleTxOut
UTxOType SimpleTx
recovered Set SimpleTxOut -> Set SimpleTxOut -> Bool
forall a. Eq a => a -> a -> Bool
== Set SimpleTxOut
recoveredUtxo
            StateChanged SimpleTx
_ -> Bool
False

        String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"emits DepositRecovered while Idle (post-fanout recovery)" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
          UTCTime
now <- IO UTCTime
forall (m :: * -> *). MonadTime m => m UTCTime
getCurrentTime
          let ownDepositId :: SimpleId
ownDepositId = SimpleId
1
              recoveredUtxo :: UTxOType SimpleTx
recoveredUtxo = SimpleId -> UTxOType SimpleTx
utxoRef SimpleId
1
              deposit :: Deposit SimpleTx
deposit =
                Deposit
                  { $sel:headId:Deposit :: HeadId
headId = HeadId
testHeadId
                  , $sel:deposited:Deposit :: UTxOType SimpleTx
deposited = Set SimpleTxOut
UTxOType SimpleTx
recoveredUtxo
                  , $sel:created:Deposit :: UTCTime
created = UTCTime
now
                  , $sel:deadline:Deposit :: UTCTime
deadline = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
3600 UTCTime
now
                  , $sel:status:Deposit :: DepositStatus
status = DepositStatus
Active
                  }
              s0 :: NodeState SimpleTx
s0 = NodeState SimpleTx
inIdleState{pendingDeposits = Map.singleton ownDepositId deposit}
              recoverDeposit :: Input SimpleTx
recoverDeposit =
                OnChainTx SimpleTx -> Input SimpleTx
observeTx (OnChainTx SimpleTx -> Input SimpleTx)
-> OnChainTx SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$
                  OnRecoverTx
                    { $sel:headId:OnInitTx :: HeadId
headId = HeadId
testHeadId
                    , $sel:recoveredTxId:OnInitTx :: TxIdType SimpleTx
recoveredTxId = SimpleId
TxIdType SimpleTx
ownDepositId
                    , $sel:recoveredUTxO:OnInitTx :: UTxOType SimpleTx
recoveredUTxO = Set SimpleTxOut
UTxOType SimpleTx
recoveredUtxo
                    }
          UTCTime
now' <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
s0.chainPointTime.currentSlot
          Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
aliceEnv Ledger SimpleTx
ledger UTCTime
now' NodeState SimpleTx
s0 Input SimpleTx
recoverDeposit Outcome SimpleTx -> (StateChanged SimpleTx -> Bool) -> IO ()
forall tx.
(HasCallStack, IsChainState tx) =>
Outcome tx -> (StateChanged tx -> Bool) -> IO ()
`hasStateChangedSatisfying` \case
            DepositRecovered{HeadId
$sel:headId:NetworkConnected :: forall tx. StateChanged tx -> HeadId
headId :: HeadId
headId, TxIdType SimpleTx
$sel:depositTxId:NetworkConnected :: forall tx. StateChanged tx -> TxIdType tx
depositTxId :: TxIdType SimpleTx
depositTxId, UTxOType SimpleTx
$sel:recovered:NetworkConnected :: forall tx. StateChanged tx -> UTxOType tx
recovered :: UTxOType SimpleTx
recovered} -> HeadId
headId HeadId -> HeadId -> Bool
forall a. Eq a => a -> a -> Bool
== HeadId
testHeadId Bool -> Bool -> Bool
&& SimpleId
TxIdType SimpleTx
depositTxId SimpleId -> SimpleId -> Bool
forall a. Eq a => a -> a -> Bool
== SimpleId
ownDepositId Bool -> Bool -> Bool
&& Set SimpleTxOut
UTxOType SimpleTx
recovered Set SimpleTxOut -> Set SimpleTxOut -> Bool
forall a. Eq a => a -> a -> Bool
== Set SimpleTxOut
recoveredUtxo
            StateChanged SimpleTx
_ -> Bool
False

        String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"allows ClientInput Recover in Idle state for deposit surviving from previous head" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
          UTCTime
now <- IO UTCTime
forall (m :: * -> *). MonadTime m => m UTCTime
getCurrentTime
          let depositTxId' :: SimpleId
depositTxId' = SimpleId
1
              deposit :: Deposit SimpleTx
deposit =
                Deposit
                  { $sel:headId:Deposit :: HeadId
headId = HeadId
testHeadId
                  , $sel:deposited:Deposit :: UTxOType SimpleTx
deposited = SimpleId -> UTxOType SimpleTx
utxoRef SimpleId
1
                  , $sel:created:Deposit :: UTCTime
created = UTCTime
now
                  , $sel:deadline:Deposit :: UTCTime
deadline = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
3600 UTCTime
now
                  , $sel:status:Deposit :: DepositStatus
status = DepositStatus
Active
                  }
              -- Deposits from a previous head are never cleared on fanout, so they
              -- remain in pendingDeposits when the node transitions to Idle.
              s0 :: NodeState SimpleTx
s0 = (HeadState SimpleTx -> NodeState SimpleTx
forall tx. IsTx tx => HeadState tx -> NodeState tx
inSync (IdleState SimpleTx -> HeadState SimpleTx
forall tx. IdleState tx -> HeadState tx
Idle IdleState{$sel:chainState:IdleState :: ChainStateType SimpleTx
chainState = ChainStateType SimpleTx
SimpleChainState
0})){pendingDeposits = Map.singleton depositTxId' deposit}
          UTCTime
now' <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
s0.chainPointTime.currentSlot
          Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
aliceEnv Ledger SimpleTx
ledger UTCTime
now' NodeState SimpleTx
s0 (ClientInput SimpleTx -> Input SimpleTx
forall tx. ClientInput tx -> Input tx
ClientInput (TxIdType SimpleTx -> ClientInput SimpleTx
forall tx. TxIdType tx -> ClientInput tx
Recover SimpleId
TxIdType SimpleTx
depositTxId'))
            Outcome SimpleTx -> (Effect SimpleTx -> Bool) -> IO ()
forall tx.
(HasCallStack, IsChainState tx) =>
Outcome tx -> (Effect tx -> Bool) -> IO ()
`hasEffectSatisfying` \case
              OnChainEffect{$sel:postChainTx:ClientEffect :: forall tx. Effect tx -> PostChainTx tx
postChainTx = RecoverTx{HeadId
headId :: HeadId
$sel:headId:InitTx :: forall tx. PostChainTx tx -> HeadId
headId, TxIdType SimpleTx
recoverTxId :: TxIdType SimpleTx
$sel:recoverTxId:InitTx :: forall tx. PostChainTx tx -> TxIdType tx
recoverTxId}} -> HeadId
headId HeadId -> HeadId -> Bool
forall a. Eq a => a -> a -> Bool
== HeadId
testHeadId Bool -> Bool -> Bool
&& SimpleId
TxIdType SimpleTx
recoverTxId SimpleId -> SimpleId -> Bool
forall a. Eq a => a -> a -> Bool
== SimpleId
depositTxId'
              Effect SimpleTx
_ -> Bool
False

        String -> (HeadId -> IO ()) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"ignores OnDepositTx while Idle" ((HeadId -> IO ()) -> Spec) -> (HeadId -> IO ()) -> Spec
forall a b. (a -> b) -> a -> b
$ \HeadId
anyHeadId -> do
          let depositedUtxo :: UTxOType SimpleTx
depositedUtxo = SimpleId -> UTxOType SimpleTx
utxoRef SimpleId
1
              depositAnyHead :: Input SimpleTx
depositAnyHead =
                OnChainTx SimpleTx -> Input SimpleTx
observeTx (OnChainTx SimpleTx -> Input SimpleTx)
-> OnChainTx SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$
                  OnDepositTx
                    { $sel:headId:OnInitTx :: HeadId
headId = HeadId
anyHeadId
                    , $sel:deposited:OnInitTx :: UTxOType SimpleTx
deposited = Set SimpleTxOut
UTxOType SimpleTx
depositedUtxo
                    , $sel:depositTxId:OnInitTx :: TxIdType SimpleTx
depositTxId = SimpleId
TxIdType SimpleTx
1
                    , $sel:created:OnInitTx :: UTCTime
created = Gen UTCTime
genUTCTime Gen UTCTime -> Int -> UTCTime
forall a. Gen a -> Int -> a
`generateWith` Int
41
                    , $sel:deadline:OnInitTx :: UTCTime
deadline = Gen UTCTime
genUTCTime Gen UTCTime -> Int -> UTCTime
forall a. Gen a -> Int -> a
`generateWith` Int
42
                    }
          UTCTime
now <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
inIdleState.chainPointTime.currentSlot
          Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
aliceEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
inIdleState Input SimpleTx
depositAnyHead Outcome SimpleTx -> (StateChanged SimpleTx -> Bool) -> IO ()
forall tx.
(HasCallStack, IsChainState tx) =>
Outcome tx -> (StateChanged tx -> Bool) -> IO ()
`hasNoStateChangedSatisfying` \case
            DepositRecorded{HeadId
$sel:headId:NetworkConnected :: forall tx. StateChanged tx -> HeadId
headId :: HeadId
headId, UTxOType SimpleTx
$sel:deposited:NetworkConnected :: forall tx. StateChanged tx -> UTxOType tx
deposited :: UTxOType SimpleTx
deposited} -> HeadId
headId HeadId -> HeadId -> Bool
forall a. Eq a => a -> a -> Bool
== HeadId
anyHeadId Bool -> Bool -> Bool
&& Set SimpleTxOut
UTxOType SimpleTx
deposited Set SimpleTxOut -> Set SimpleTxOut -> Bool
forall a. Eq a => a -> a -> Bool
== Set SimpleTxOut
depositedUtxo
            StateChanged SimpleTx
_ -> Bool
False

        String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"on tick, picks the next active deposit in arrival when in Open state order for ReqSn" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
          UTCTime
now <- IO UTCTime
forall (m :: * -> *). MonadTime m => m UTCTime
getCurrentTime
          let party :: [Party]
party = [Party
alice]
              depositTime :: NominalDiffTime -> UTCTime
depositTime = UTCTime -> NominalDiffTime -> UTCTime
plusTime UTCTime
now
          let deadline :: UTCTime
deadline = NominalDiffTime -> UTCTime
depositTime NominalDiffTime
5 UTCTime -> NominalDiffTime -> UTCTime
`plusTime` DepositPeriod -> NominalDiffTime
toNominalDiffTime Environment
aliceEnv.depositPeriod UTCTime -> NominalDiffTime -> UTCTime
`plusTime` DepositPeriod -> NominalDiffTime
toNominalDiffTime Environment
aliceEnv.depositPeriod
              deposit1 :: OnChainTx SimpleTx
deposit1 = OnDepositTx{$sel:headId:OnInitTx :: HeadId
headId = HeadId
testHeadId, $sel:depositTxId:OnInitTx :: TxIdType SimpleTx
depositTxId = SimpleId
TxIdType SimpleTx
1, $sel:deposited:OnInitTx :: UTxOType SimpleTx
deposited = SimpleId -> UTxOType SimpleTx
utxoRef SimpleId
1, $sel:created:OnInitTx :: UTCTime
created = NominalDiffTime -> UTCTime
depositTime NominalDiffTime
1, UTCTime
$sel:deadline:OnInitTx :: UTCTime
deadline :: UTCTime
deadline}
              deposit2 :: OnChainTx SimpleTx
deposit2 = OnDepositTx{$sel:headId:OnInitTx :: HeadId
headId = HeadId
testHeadId, $sel:depositTxId:OnInitTx :: TxIdType SimpleTx
depositTxId = SimpleId
TxIdType SimpleTx
2, $sel:deposited:OnInitTx :: UTxOType SimpleTx
deposited = SimpleId -> UTxOType SimpleTx
utxoRef SimpleId
2, $sel:created:OnInitTx :: UTCTime
created = NominalDiffTime -> UTCTime
depositTime NominalDiffTime
2, UTCTime
$sel:deadline:OnInitTx :: UTCTime
deadline :: UTCTime
deadline}
              deposit3 :: OnChainTx SimpleTx
deposit3 = OnDepositTx{$sel:headId:OnInitTx :: HeadId
headId = HeadId
testHeadId, $sel:depositTxId:OnInitTx :: TxIdType SimpleTx
depositTxId = SimpleId
TxIdType SimpleTx
3, $sel:deposited:OnInitTx :: UTxOType SimpleTx
deposited = SimpleId -> UTxOType SimpleTx
utxoRef SimpleId
3, $sel:created:OnInitTx :: UTCTime
created = NominalDiffTime -> UTCTime
depositTime NominalDiffTime
3, UTCTime
$sel:deadline:OnInitTx :: UTCTime
deadline :: UTCTime
deadline}

          NodeState SimpleTx
nodeState <- Environment
-> Ledger SimpleTx
-> NodeState SimpleTx
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall (m :: * -> *) tx a.
Monad m =>
Environment
-> Ledger tx -> NodeState tx -> StateT (StepState tx) m a -> m a
runHeadLogic Environment
aliceEnv Ledger SimpleTx
ledger ([Party] -> NodeState SimpleTx
inOpenState [Party]
party) (StateT (StepState SimpleTx) IO (NodeState SimpleTx)
 -> IO (NodeState SimpleTx))
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall a b. (a -> b) -> a -> b
$ do
            Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step (ChainSlot -> OnChainTx SimpleTx -> Input SimpleTx
observeTxAtSlot ChainSlot
1 OnChainTx SimpleTx
deposit1)
            Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step (ChainSlot -> OnChainTx SimpleTx -> Input SimpleTx
observeTxAtSlot ChainSlot
2 OnChainTx SimpleTx
deposit2)
            Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step (ChainSlot -> OnChainTx SimpleTx -> Input SimpleTx
observeTxAtSlot ChainSlot
3 OnChainTx SimpleTx
deposit3)
            StateT (StepState SimpleTx) IO (NodeState SimpleTx)
forall tx (m :: * -> *).
MonadState (StepState tx) m =>
m (NodeState tx)
getState

          -- XXX: chainTime should be > created + depositPeriod && < deadline - depositPeriod
          -- so deposits are considered Active
          let chainTime :: UTCTime
chainTime = NominalDiffTime -> UTCTime
depositTime NominalDiffTime
4 UTCTime -> NominalDiffTime -> UTCTime
`plusTime` DepositPeriod -> NominalDiffTime
toNominalDiffTime Environment
aliceEnv.depositPeriod
          let input :: Input SimpleTx
input = ChainEvent SimpleTx -> Input SimpleTx
forall tx. ChainEvent tx -> Input tx
ChainInput (ChainEvent SimpleTx -> Input SimpleTx)
-> ChainEvent SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ Tick{UTCTime
$sel:chainTime:Observation :: UTCTime
chainTime :: UTCTime
chainTime, $sel:chainPoint:Observation :: ChainPointType SimpleTx
chainPoint = ChainSlot
ChainPointType SimpleTx
4}

          let outcome :: Outcome SimpleTx
outcome = Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
aliceEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
nodeState Input SimpleTx
input

          [SimpleId] -> (SimpleId -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [SimpleId
1, SimpleId
2, SimpleId
3] ((SimpleId -> IO ()) -> IO ()) -> (SimpleId -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \SimpleId
depositId ->
            Outcome SimpleTx
outcome Outcome SimpleTx -> (StateChanged SimpleTx -> Bool) -> IO ()
forall tx.
(HasCallStack, IsChainState tx) =>
Outcome tx -> (StateChanged tx -> Bool) -> IO ()
`hasStateChangedSatisfying` \case
              DepositActivated{TxIdType SimpleTx
$sel:depositTxId:NetworkConnected :: forall tx. StateChanged tx -> TxIdType tx
depositTxId :: TxIdType SimpleTx
depositTxId} -> SimpleId
TxIdType SimpleTx
depositTxId SimpleId -> SimpleId -> Bool
forall a. Eq a => a -> a -> Bool
== SimpleId
depositId
              StateChanged SimpleTx
_ -> Bool
False

          Outcome SimpleTx
outcome Outcome SimpleTx -> (Effect SimpleTx -> Bool) -> IO ()
forall tx.
(HasCallStack, IsChainState tx) =>
Outcome tx -> (Effect tx -> Bool) -> IO ()
`hasEffectSatisfying` \case
            NetworkEffect ReqSn{Maybe (TxIdType SimpleTx)
$sel:depositTxId:ReqTx :: forall tx. Message tx -> Maybe (TxIdType tx)
depositTxId :: Maybe (TxIdType SimpleTx)
depositTxId} -> Maybe SimpleId
Maybe (TxIdType SimpleTx)
depositTxId Maybe SimpleId -> Maybe SimpleId -> Bool
forall a. Eq a => a -> a -> Bool
== SimpleId -> Maybe SimpleId
forall a. a -> Maybe a
Just SimpleId
1
            Effect SimpleTx
_ -> Bool
False

        String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"does not carry an expired deposit into the next ReqSn" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
          -- Requesting an expired deposit makes every receiving party hard-error
          -- with RequestedDepositExpired, so a deposit that became unclaimable would
          -- stall snapshots for the whole head. Dropping it downgrades that to a
          -- commit its depositor recovers after the deadline.
          UTCTime
now <- IO UTCTime
forall (m :: * -> *). MonadTime m => m UTCTime
getCurrentTime
          let depositId :: SimpleId
depositId = SimpleId
4711
              mkDeposit :: DepositStatus -> Deposit SimpleTx
mkDeposit DepositStatus
status =
                Deposit
                  { $sel:headId:Deposit :: HeadId
headId = HeadId
testHeadId
                  , $sel:deposited:Deposit :: UTxOType SimpleTx
deposited = SimpleId -> UTxOType SimpleTx
utxoRef SimpleId
50
                  , $sel:created:Deposit :: UTCTime
created = UTCTime
now
                  , $sel:deadline:Deposit :: UTCTime
deadline = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
3600 UTCTime
now
                  , DepositStatus
$sel:status:Deposit :: DepositStatus
status :: DepositStatus
status
                  }
          Map (TxIdType SimpleTx) (Deposit SimpleTx)
-> Maybe (TxIdType SimpleTx) -> Maybe (TxIdType SimpleTx)
forall tx.
IsTx tx =>
PendingDeposits tx -> Maybe (TxIdType tx) -> Maybe (TxIdType tx)
setExistingDeposit (SimpleId -> Deposit SimpleTx -> Map SimpleId (Deposit SimpleTx)
forall k a. k -> a -> Map k a
Map.singleton SimpleId
depositId (DepositStatus -> Deposit SimpleTx
mkDeposit DepositStatus
Expired)) (SimpleId -> Maybe SimpleId
forall a. a -> Maybe a
Just SimpleId
depositId)
            Maybe SimpleId -> Maybe SimpleId -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` (Maybe SimpleId
forall a. Maybe a
Nothing :: Maybe Integer)
          Map (TxIdType SimpleTx) (Deposit SimpleTx)
-> Maybe (TxIdType SimpleTx) -> Maybe (TxIdType SimpleTx)
forall tx.
IsTx tx =>
PendingDeposits tx -> Maybe (TxIdType tx) -> Maybe (TxIdType tx)
setExistingDeposit (SimpleId -> Deposit SimpleTx -> Map SimpleId (Deposit SimpleTx)
forall k a. k -> a -> Map k a
Map.singleton SimpleId
depositId (DepositStatus -> Deposit SimpleTx
mkDeposit DepositStatus
Active)) (SimpleId -> Maybe SimpleId
forall a. a -> Maybe a
Just SimpleId
depositId)
            Maybe SimpleId -> Maybe SimpleId -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` SimpleId -> Maybe SimpleId
forall a. a -> Maybe a
Just SimpleId
depositId

        String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"deposit activated while snapshot in-flight is picked up by next chained snapshot" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
          -- Regression: a deposit that becomes Active while a snapshot is in-flight
          -- (so the tick cannot request a snapshot for it) must be included in the
          -- next chained ReqSn once the in-flight snapshot confirms.
          --
          -- After DepositActivated is aggregated the deposit sits in pendingDeposits
          -- with status=Active, but currentDepositTxId stays Nothing (the bug).
          -- When maybeRequestNextSnapshot fires it calls
          --   setExistingDeposit pendingDeposits Nothing = Nothing
          -- so the deposit is silently dropped from every subsequent ReqSn.
          UTCTime
now <- IO UTCTime
forall (m :: * -> *). MonadTime m => m UTCTime
getCurrentTime
          let
            depositId :: SimpleId
depositId = SimpleId
999
            deposit :: Deposit SimpleTx
deposit =
              Deposit
                { $sel:headId:Deposit :: HeadId
headId = HeadId
testHeadId
                , $sel:deposited:Deposit :: UTxOType SimpleTx
deposited = SimpleId -> UTxOType SimpleTx
utxoRef SimpleId
50
                , $sel:created:Deposit :: UTCTime
created = UTCTime
now
                , $sel:deadline:Deposit :: UTCTime
deadline = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
3600 UTCTime
now
                , $sel:status:Deposit :: DepositStatus
status = DepositStatus
Active
                }
            -- Single-party head: alice is always leader, so maybeRequestNextSnapshot
            -- fires for sn=2 when she receives her own AckSn for sn=1.
            singleParty :: [Party]
singleParty = [Party
alice]
            -- sn=1 in SeenSnapshot — no deposit was included (activated too late).
            snapshot1 :: Snapshot SimpleTx
snapshot1 = SnapshotNumber
-> SnapshotVersion
-> [SimpleTx]
-> UTxOType SimpleTx
-> Snapshot SimpleTx
forall tx.
IsTx tx =>
SnapshotNumber
-> SnapshotVersion -> [tx] -> UTxOType tx -> Snapshot tx
testSnapshot SnapshotNumber
1 SnapshotVersion
0 [] UTxOType SimpleTx
forall a. Monoid a => a
mempty
            -- Pending L2 tx ensures not (null localTxs) → maybeRequestNextSnapshot fires.
            tx2 :: SimpleTx
tx2 = SimpleId -> SimpleTx
aValidTx SimpleId
2
            -- State as it would be after DepositActivated was processed:
            -- pendingDeposits has the Active deposit, currentDepositTxId is still Nothing.
            s0 :: NodeState SimpleTx
s0 =
              ( [Party] -> CoordinatedHeadState SimpleTx -> NodeState SimpleTx
inOpenState' [Party]
singleParty (CoordinatedHeadState SimpleTx -> NodeState SimpleTx)
-> CoordinatedHeadState SimpleTx -> NodeState SimpleTx
forall a b. (a -> b) -> a -> b
$
                  CoordinatedHeadState SimpleTx
coordinatedHeadState
                    { seenSnapshot = mkSeenSnapshot snapshot1 Map.empty
                    , localTxs = pure tx2
                    , currentDepositTxId = Nothing
                    }
              )
                { pendingDeposits = Map.singleton depositId deposit
                }

          -- Alice's AckSn confirms sn=1; maybeRequestNextSnapshot fires for sn=2.
          UTCTime
now' <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
s0.chainPointTime.currentSlot
          let ackSn :: Input SimpleTx
ackSn = Party -> Message SimpleTx -> Input SimpleTx
forall tx. Party -> Message tx -> Input tx
receiveMessageFrom Party
alice (Message SimpleTx -> Input SimpleTx)
-> Message SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ Signature (Snapshot SimpleTx) -> SnapshotNumber -> Message SimpleTx
forall tx. Signature (Snapshot tx) -> SnapshotNumber -> Message tx
AckSn (Secret (SigningKey HydraKey)
-> Snapshot SimpleTx -> Signature (Snapshot SimpleTx)
forall a.
SignableRepresentation a =>
Secret (SigningKey HydraKey) -> a -> Signature a
sign Secret (SigningKey HydraKey)
aliceSk Snapshot SimpleTx
snapshot1) SnapshotNumber
1
          let outcome :: Outcome SimpleTx
outcome = Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
aliceEnv Ledger SimpleTx
ledger UTCTime
now' NodeState SimpleTx
s0 Input SimpleTx
ackSn

          -- The chained ReqSn for sn=2 must include the active deposit.
          Outcome SimpleTx
outcome Outcome SimpleTx -> (Effect SimpleTx -> Bool) -> IO ()
forall tx.
(HasCallStack, IsChainState tx) =>
Outcome tx -> (Effect tx -> Bool) -> IO ()
`hasEffectSatisfying` \case
            NetworkEffect ReqSn{Maybe (TxIdType SimpleTx)
$sel:depositTxId:ReqTx :: forall tx. Message tx -> Maybe (TxIdType tx)
depositTxId :: Maybe (TxIdType SimpleTx)
depositTxId} -> Maybe SimpleId
Maybe (TxIdType SimpleTx)
depositTxId Maybe SimpleId -> Maybe SimpleId -> Bool
forall a. Eq a => a -> a -> Bool
== SimpleId -> Maybe SimpleId
forall a. a -> Maybe a
Just SimpleId
depositId
            Effect SimpleTx
_ -> Bool
False

        String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"DepositActivated from another head does not set currentDepositTxId" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
          UTCTime
now <- IO UTCTime
forall (m :: * -> *). MonadTime m => m UTCTime
getCurrentTime
          HeadId
otherHeadId :: HeadId <- Gen HeadId -> IO HeadId
forall a. Gen a -> IO a
generate Gen HeadId
forall a. Arbitrary a => Gen a
arbitrary
          let foreignDeposit :: Deposit SimpleTx
foreignDeposit =
                Deposit
                  { $sel:headId:Deposit :: HeadId
headId = HeadId
otherHeadId
                  , $sel:deposited:Deposit :: UTxOType SimpleTx
deposited = SimpleId -> UTxOType SimpleTx
utxoRef SimpleId
99
                  , $sel:created:Deposit :: UTCTime
created = UTCTime
now
                  , $sel:deadline:Deposit :: UTCTime
deadline = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
3600 UTCTime
now
                  , $sel:status:Deposit :: DepositStatus
status = DepositStatus
Active
                  }
              s0 :: NodeState SimpleTx
s0 = [Party] -> NodeState SimpleTx
inOpenState [Party]
threeParties
          let s1 :: NodeState SimpleTx
s1 = NodeState SimpleTx -> Outcome SimpleTx -> NodeState SimpleTx
forall tx.
IsChainState tx =>
NodeState tx -> Outcome tx -> NodeState tx
aggregateState NodeState SimpleTx
s0 (Outcome SimpleTx -> NodeState SimpleTx)
-> Outcome SimpleTx -> NodeState SimpleTx
forall a b. (a -> b) -> a -> b
$ [StateChanged SimpleTx] -> [Effect SimpleTx] -> Outcome SimpleTx
forall tx. [StateChanged tx] -> [Effect tx] -> Outcome tx
Continue [DepositActivated{$sel:depositTxId:NetworkConnected :: TxIdType SimpleTx
depositTxId = SimpleId
TxIdType SimpleTx
99, $sel:chainTime:NetworkConnected :: UTCTime
chainTime = UTCTime
now, $sel:deposit:NetworkConnected :: Deposit SimpleTx
deposit = Deposit SimpleTx
foreignDeposit}] []
          case NodeState SimpleTx
s1 of
            NodeInSync{$sel:headState:NodeInSync :: forall tx. NodeState tx -> HeadState tx
headState = Open OpenState{$sel:coordinatedHeadState:OpenState :: forall tx. OpenState tx -> CoordinatedHeadState tx
coordinatedHeadState = CoordinatedHeadState SimpleTx
chs}} ->
              CoordinatedHeadState SimpleTx
chs.currentDepositTxId Maybe (TxIdType SimpleTx) -> Maybe (TxIdType SimpleTx) -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Maybe (TxIdType SimpleTx)
forall a. Maybe a
Nothing
            NodeState SimpleTx
_ -> String -> IO ()
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"expected Open state"

        String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"DepositRecovered from another head does not clear currentDepositTxId" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
          UTCTime
now <- IO UTCTime
forall (m :: * -> *). MonadTime m => m UTCTime
getCurrentTime
          HeadId
otherHeadId :: HeadId <- Gen HeadId -> IO HeadId
forall a. Gen a -> IO a
generate Gen HeadId
forall a. Arbitrary a => Gen a
arbitrary
          let ownDepositId :: SimpleId
ownDepositId = SimpleId
1
              foreignDepositId :: SimpleId
foreignDepositId = SimpleId
99
              foreignDeposit :: Deposit SimpleTx
foreignDeposit =
                Deposit
                  { $sel:headId:Deposit :: HeadId
headId = HeadId
otherHeadId
                  , $sel:deposited:Deposit :: UTxOType SimpleTx
deposited = SimpleId -> UTxOType SimpleTx
utxoRef SimpleId
99
                  , $sel:created:Deposit :: UTCTime
created = UTCTime
now
                  , $sel:deadline:Deposit :: UTCTime
deadline = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
3600 UTCTime
now
                  , $sel:status:Deposit :: DepositStatus
status = DepositStatus
Active
                  }
              s0 :: NodeState SimpleTx
s0 =
                ([Party] -> CoordinatedHeadState SimpleTx -> NodeState SimpleTx
inOpenState' [Party]
threeParties CoordinatedHeadState SimpleTx
coordinatedHeadState{currentDepositTxId = Just ownDepositId})
                  { pendingDeposits = Map.singleton foreignDepositId foreignDeposit
                  }
          let s1 :: NodeState SimpleTx
s1 = NodeState SimpleTx -> Outcome SimpleTx -> NodeState SimpleTx
forall tx.
IsChainState tx =>
NodeState tx -> Outcome tx -> NodeState tx
aggregateState NodeState SimpleTx
s0 (Outcome SimpleTx -> NodeState SimpleTx)
-> Outcome SimpleTx -> NodeState SimpleTx
forall a b. (a -> b) -> a -> b
$ [StateChanged SimpleTx] -> [Effect SimpleTx] -> Outcome SimpleTx
forall tx. [StateChanged tx] -> [Effect tx] -> Outcome tx
Continue [DepositRecovered{$sel:chainState:NetworkConnected :: ChainStateType SimpleTx
chainState = ChainStateType SimpleTx
SimpleChainState
0, $sel:headId:NetworkConnected :: HeadId
headId = HeadId
otherHeadId, $sel:depositTxId:NetworkConnected :: TxIdType SimpleTx
depositTxId = SimpleId
TxIdType SimpleTx
foreignDepositId, $sel:recovered:NetworkConnected :: UTxOType SimpleTx
recovered = Set SimpleTxOut
UTxOType SimpleTx
forall a. Monoid a => a
mempty}] []
          case NodeState SimpleTx
s1 of
            NodeInSync{$sel:headState:NodeInSync :: forall tx. NodeState tx -> HeadState tx
headState = Open OpenState{$sel:coordinatedHeadState:OpenState :: forall tx. OpenState tx -> CoordinatedHeadState tx
coordinatedHeadState = CoordinatedHeadState SimpleTx
chs}, Map (TxIdType SimpleTx) (Deposit SimpleTx)
$sel:pendingDeposits:NodeInSync :: forall tx. NodeState tx -> PendingDeposits tx
pendingDeposits :: Map (TxIdType SimpleTx) (Deposit SimpleTx)
pendingDeposits} -> do
              CoordinatedHeadState SimpleTx
chs.currentDepositTxId Maybe SimpleId -> Maybe SimpleId -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` SimpleId -> Maybe SimpleId
forall a. a -> Maybe a
Just SimpleId
ownDepositId
              Map SimpleId (Deposit SimpleTx)
Map (TxIdType SimpleTx) (Deposit SimpleTx)
pendingDeposits Map SimpleId (Deposit SimpleTx)
-> Map SimpleId (Deposit SimpleTx) -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Map SimpleId (Deposit SimpleTx)
forall a. Monoid a => a
mempty
            NodeState SimpleTx
_ -> String -> IO ()
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"expected Open state"

        String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"DepositRecovered while Idle removes deposit from pendingDeposits" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
          UTCTime
now <- IO UTCTime
forall (m :: * -> *). MonadTime m => m UTCTime
getCurrentTime
          let depositTxId' :: SimpleId
depositTxId' = SimpleId
1
              deposit :: Deposit SimpleTx
deposit =
                Deposit
                  { $sel:headId:Deposit :: HeadId
headId = HeadId
testHeadId
                  , $sel:deposited:Deposit :: UTxOType SimpleTx
deposited = SimpleId -> UTxOType SimpleTx
utxoRef SimpleId
1
                  , $sel:created:Deposit :: UTCTime
created = UTCTime
now
                  , $sel:deadline:Deposit :: UTCTime
deadline = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
3600 UTCTime
now
                  , $sel:status:Deposit :: DepositStatus
status = DepositStatus
Active
                  }
              s0 :: NodeState SimpleTx
s0 = (HeadState SimpleTx -> NodeState SimpleTx
forall tx. IsTx tx => HeadState tx -> NodeState tx
inSync (IdleState SimpleTx -> HeadState SimpleTx
forall tx. IdleState tx -> HeadState tx
Idle IdleState{$sel:chainState:IdleState :: ChainStateType SimpleTx
chainState = ChainStateType SimpleTx
SimpleChainState
0})){pendingDeposits = Map.singleton depositTxId' deposit}
          let s1 :: NodeState SimpleTx
s1 = NodeState SimpleTx -> Outcome SimpleTx -> NodeState SimpleTx
forall tx.
IsChainState tx =>
NodeState tx -> Outcome tx -> NodeState tx
aggregateState NodeState SimpleTx
s0 (Outcome SimpleTx -> NodeState SimpleTx)
-> Outcome SimpleTx -> NodeState SimpleTx
forall a b. (a -> b) -> a -> b
$ [StateChanged SimpleTx] -> [Effect SimpleTx] -> Outcome SimpleTx
forall tx. [StateChanged tx] -> [Effect tx] -> Outcome tx
Continue [DepositRecovered{$sel:chainState:NetworkConnected :: ChainStateType SimpleTx
chainState = ChainStateType SimpleTx
SimpleChainState
0, $sel:headId:NetworkConnected :: HeadId
headId = HeadId
testHeadId, $sel:depositTxId:NetworkConnected :: TxIdType SimpleTx
depositTxId = SimpleId
TxIdType SimpleTx
depositTxId', $sel:recovered:NetworkConnected :: UTxOType SimpleTx
recovered = SimpleId -> UTxOType SimpleTx
utxoRef SimpleId
1}] []
          case NodeState SimpleTx
s1 of
            NodeInSync{Map (TxIdType SimpleTx) (Deposit SimpleTx)
$sel:pendingDeposits:NodeInSync :: forall tx. NodeState tx -> PendingDeposits tx
pendingDeposits :: Map (TxIdType SimpleTx) (Deposit SimpleTx)
pendingDeposits} -> Map SimpleId (Deposit SimpleTx)
Map (TxIdType SimpleTx) (Deposit SimpleTx)
pendingDeposits Map SimpleId (Deposit SimpleTx)
-> Map SimpleId (Deposit SimpleTx) -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Map SimpleId (Deposit SimpleTx)
forall a. Monoid a => a
mempty
            NodeState SimpleTx
_ -> String -> IO ()
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"expected NodeInSync"

        String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"CommitFinalized from another head does not update version or localUTxO" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
          HeadId
otherHeadId :: HeadId <- Gen HeadId -> IO HeadId
forall a. Gen a -> IO a
generate Gen HeadId
forall a. Arbitrary a => Gen a
arbitrary
          let ownUTxO :: UTxOType SimpleTx
ownUTxO = [SimpleId] -> UTxOType SimpleTx
utxoRefs [SimpleId
1, SimpleId
2]
              s0 :: NodeState SimpleTx
s0 =
                [Party] -> CoordinatedHeadState SimpleTx -> NodeState SimpleTx
inOpenState'
                  [Party]
threeParties
                  CoordinatedHeadState SimpleTx
coordinatedHeadState
                    { localUTxO = ownUTxO
                    , version = 3
                    }
          let s1 :: NodeState SimpleTx
s1 = NodeState SimpleTx -> Outcome SimpleTx -> NodeState SimpleTx
forall tx.
IsChainState tx =>
NodeState tx -> Outcome tx -> NodeState tx
aggregateState NodeState SimpleTx
s0 (Outcome SimpleTx -> NodeState SimpleTx)
-> Outcome SimpleTx -> NodeState SimpleTx
forall a b. (a -> b) -> a -> b
$ [StateChanged SimpleTx] -> [Effect SimpleTx] -> Outcome SimpleTx
forall tx. [StateChanged tx] -> [Effect tx] -> Outcome tx
Continue [CommitFinalized{$sel:chainState:NetworkConnected :: ChainStateType SimpleTx
chainState = ChainStateType SimpleTx
SimpleChainState
0, $sel:headId:NetworkConnected :: HeadId
headId = HeadId
otherHeadId, $sel:newVersion:NetworkConnected :: SnapshotVersion
newVersion = SnapshotVersion
99, $sel:depositTxId:NetworkConnected :: TxIdType SimpleTx
depositTxId = SimpleId
TxIdType SimpleTx
42}] []
          case NodeState SimpleTx
s1 of
            NodeInSync{$sel:headState:NodeInSync :: forall tx. NodeState tx -> HeadState tx
headState = Open OpenState{$sel:coordinatedHeadState:OpenState :: forall tx. OpenState tx -> CoordinatedHeadState tx
coordinatedHeadState = CoordinatedHeadState SimpleTx
chs}} -> do
              CoordinatedHeadState SimpleTx
chs.version SnapshotVersion -> SnapshotVersion -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` SnapshotVersion
3
              CoordinatedHeadState SimpleTx
chs.localUTxO Set SimpleTxOut -> Set SimpleTxOut -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Set SimpleTxOut
ownUTxO
            NodeState SimpleTx
_ -> String -> IO ()
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"expected Open state"

        String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"HeadClosed from another head does not transition Open to Closed during replay" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
          HeadId
otherHeadId :: HeadId <- Gen HeadId -> IO HeadId
forall a. Gen a -> IO a
generate Gen HeadId
forall a. Arbitrary a => Gen a
arbitrary
          let s0 :: NodeState SimpleTx
s0 = [Party] -> NodeState SimpleTx
inOpenState [Party]
threeParties
              closedEvent :: StateChanged SimpleTx
closedEvent =
                HeadClosed
                  { $sel:headId:NetworkConnected :: HeadId
headId = HeadId
otherHeadId
                  , $sel:snapshotNumber:NetworkConnected :: SnapshotNumber
snapshotNumber = SnapshotNumber
0
                  , $sel:chainState:NetworkConnected :: ChainStateType SimpleTx
chainState = ChainStateType SimpleTx
SimpleChainState
0
                  , $sel:contestationDeadline:NetworkConnected :: UTCTime
contestationDeadline = Gen UTCTime
forall a. Arbitrary a => Gen a
arbitrary Gen UTCTime -> Int -> UTCTime
forall a. Gen a -> Int -> a
`generateWith` Int
42
                  }
          let s1 :: NodeState SimpleTx
s1 = NodeState SimpleTx -> Outcome SimpleTx -> NodeState SimpleTx
forall tx.
IsChainState tx =>
NodeState tx -> Outcome tx -> NodeState tx
aggregateState NodeState SimpleTx
s0 (Outcome SimpleTx -> NodeState SimpleTx)
-> Outcome SimpleTx -> NodeState SimpleTx
forall a b. (a -> b) -> a -> b
$ [StateChanged SimpleTx] -> [Effect SimpleTx] -> Outcome SimpleTx
forall tx. [StateChanged tx] -> [Effect tx] -> Outcome tx
Continue [StateChanged SimpleTx
closedEvent] []
          case NodeState SimpleTx
s1 of
            NodeInSync{$sel:headState:NodeInSync :: forall tx. NodeState tx -> HeadState tx
headState = Open OpenState SimpleTx
_} -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            NodeState SimpleTx
other -> String -> IO ()
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"expected Open state, got: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> NodeState SimpleTx -> String
forall b a. (Show a, IsString b) => a -> b
show NodeState SimpleTx
other

        String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"HeadFannedOut from another head does not transition Closed to Idle during replay" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
          HeadId
otherHeadId :: HeadId <- Gen HeadId -> IO HeadId
forall a. Gen a -> IO a
generate Gen HeadId
forall a. Arbitrary a => Gen a
arbitrary
          let s0 :: NodeState SimpleTx
s0 = [Party] -> NodeState SimpleTx
inClosedState [Party]
threeParties
              fanoutEvent :: StateChanged SimpleTx
fanoutEvent =
                HeadFannedOut
                  { $sel:headId:NetworkConnected :: HeadId
headId = HeadId
otherHeadId
                  , $sel:finalizedOutputs:NetworkConnected :: UTxOType SimpleTx
finalizedOutputs = Set SimpleTxOut
UTxOType SimpleTx
forall a. Monoid a => a
mempty
                  , $sel:chainState:NetworkConnected :: ChainStateType SimpleTx
chainState = ChainStateType SimpleTx
SimpleChainState
0
                  }
          let s1 :: NodeState SimpleTx
s1 = NodeState SimpleTx -> Outcome SimpleTx -> NodeState SimpleTx
forall tx.
IsChainState tx =>
NodeState tx -> Outcome tx -> NodeState tx
aggregateState NodeState SimpleTx
s0 (Outcome SimpleTx -> NodeState SimpleTx)
-> Outcome SimpleTx -> NodeState SimpleTx
forall a b. (a -> b) -> a -> b
$ [StateChanged SimpleTx] -> [Effect SimpleTx] -> Outcome SimpleTx
forall tx. [StateChanged tx] -> [Effect tx] -> Outcome tx
Continue [StateChanged SimpleTx
fanoutEvent] []
          case NodeState SimpleTx
s1 of
            NodeInSync{$sel:headState:NodeInSync :: forall tx. NodeState tx -> HeadState tx
headState = Closed ClosedState SimpleTx
_} -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            NodeState SimpleTx
other -> String -> IO ()
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"expected Closed state, got: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> NodeState SimpleTx -> String
forall b a. (Show a, IsString b) => a -> b
show NodeState SimpleTx
other

        String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"posts IncrementTx using the snapshot's deposit txid, not the current one" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
          -- Regression for #2681 and for the deposit binding: with two pending
          -- deposits sharing 'deposited' content but differing in txid, only the
          -- deposit bound into the signed snapshot may be claimed on-chain.
          -- 'currentDepositTxId' deliberately points at the *other* deposit here,
          -- as 'DepositActivated' can move it after a snapshot was confirmed.
          UTCTime
now <- IO UTCTime
forall (m :: * -> *). MonadTime m => m UTCTime
getCurrentTime
          let depositTime :: NominalDiffTime -> UTCTime
depositTime = (NominalDiffTime -> UTCTime -> UTCTime)
-> UTCTime -> NominalDiffTime -> UTCTime
forall a b c. (a -> b -> c) -> b -> a -> c
flip NominalDiffTime -> UTCTime -> UTCTime
addUTCTime UTCTime
now
              deadline :: UTCTime
deadline = NominalDiffTime -> UTCTime
depositTime NominalDiffTime
600
              depositedUtxo :: UTxOType SimpleTx
depositedUtxo = SimpleId -> UTxOType SimpleTx
utxoRef SimpleId
50
              txid1 :: SimpleId
txid1 = SimpleId
41 :: Integer
              txid2 :: SimpleId
txid2 = SimpleId
42 :: Integer
              mkDeposit :: NominalDiffTime -> Deposit SimpleTx
mkDeposit NominalDiffTime
ts =
                Deposit
                  { $sel:headId:Deposit :: HeadId
headId = HeadId
testHeadId
                  , $sel:deposited:Deposit :: UTxOType SimpleTx
deposited = Set SimpleTxOut
UTxOType SimpleTx
depositedUtxo
                  , $sel:created:Deposit :: UTCTime
created = NominalDiffTime -> UTCTime
depositTime NominalDiffTime
ts
                  , UTCTime
$sel:deadline:Deposit :: UTCTime
deadline :: UTCTime
deadline
                  , $sel:status:Deposit :: DepositStatus
status = DepositStatus
Active
                  }
              snapshot1 :: Snapshot SimpleTx
snapshot1 =
                Snapshot
                  { $sel:headId:Snapshot :: HeadId
headId = HeadId
testHeadId
                  , $sel:version:Snapshot :: SnapshotVersion
version = SnapshotVersion
0
                  , $sel:number:Snapshot :: SnapshotNumber
number = SnapshotNumber
1
                  , $sel:confirmed:Snapshot :: [SimpleTx]
confirmed = []
                  , $sel:utxo:Snapshot :: UTxOType SimpleTx
utxo = UTxOType SimpleTx
forall a. Monoid a => a
mempty
                  , $sel:utxoToCommit:Snapshot :: Maybe (UTxOType SimpleTx)
utxoToCommit = Set SimpleTxOut -> Maybe (Set SimpleTxOut)
forall a. a -> Maybe a
Just Set SimpleTxOut
depositedUtxo
                  , $sel:utxoToDecommit:Snapshot :: Maybe (UTxOType SimpleTx)
utxoToDecommit = Maybe (Set SimpleTxOut)
Maybe (UTxOType SimpleTx)
forall a. Maybe a
Nothing
                  , $sel:depositTxId:Snapshot :: Maybe (TxIdType SimpleTx)
depositTxId = SimpleId -> Maybe SimpleId
forall a. a -> Maybe a
Just SimpleId
txid2
                  , $sel:accumulator:Snapshot :: HydraAccumulator
accumulator = UTxOType SimpleTx
-> Maybe (UTxOType SimpleTx)
-> Maybe (UTxOType SimpleTx)
-> HydraAccumulator
forall tx.
IsTx tx =>
UTxOType tx
-> Maybe (UTxOType tx) -> Maybe (UTxOType tx) -> HydraAccumulator
Accumulator.buildFromSnapshotUTxOs UTxOType SimpleTx
forall a. Monoid a => a
mempty (Set SimpleTxOut -> Maybe (Set SimpleTxOut)
forall a. a -> Maybe a
Just Set SimpleTxOut
depositedUtxo) Maybe (Set SimpleTxOut)
Maybe (UTxOType SimpleTx)
forall a. Maybe a
Nothing
                  }
              s0 :: NodeState SimpleTx
s0 =
                ( [Party] -> CoordinatedHeadState SimpleTx -> NodeState SimpleTx
inOpenState'
                    [Party
alice]
                    CoordinatedHeadState SimpleTx
coordinatedHeadState
                      { seenSnapshot = mkSeenSnapshot snapshot1 Map.empty
                      , -- NOTE: diverges from the snapshot's own depositTxId on
                        -- purpose, so this test fails if the posted transaction
                        -- ever keys off state instead of the signed snapshot.
                        currentDepositTxId = Just txid1
                      }
                )
                  { pendingDeposits = Map.fromList [(txid1, mkDeposit 1), (txid2, mkDeposit 2)]
                  }
              ackSn :: Input SimpleTx
ackSn = Message SimpleTx -> Input SimpleTx
forall tx. Message tx -> Input tx
receiveMessage (Message SimpleTx -> Input SimpleTx)
-> Message SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ Signature (Snapshot SimpleTx) -> SnapshotNumber -> Message SimpleTx
forall tx. Signature (Snapshot tx) -> SnapshotNumber -> Message tx
AckSn (Secret (SigningKey HydraKey)
-> Snapshot SimpleTx -> Signature (Snapshot SimpleTx)
forall a.
SignableRepresentation a =>
Secret (SigningKey HydraKey) -> a -> Signature a
sign Secret (SigningKey HydraKey)
aliceSk Snapshot SimpleTx
snapshot1) SnapshotNumber
1
              outcome :: Outcome SimpleTx
outcome = Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
aliceEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
s0 Input SimpleTx
ackSn
          Outcome SimpleTx
outcome Outcome SimpleTx -> (Effect SimpleTx -> Bool) -> IO ()
forall tx.
(HasCallStack, IsChainState tx) =>
Outcome tx -> (Effect tx -> Bool) -> IO ()
`hasEffectSatisfying` \case
            OnChainEffect{$sel:postChainTx:ClientEffect :: forall tx. Effect tx -> PostChainTx tx
postChainTx = IncrementTx{TxIdType SimpleTx
depositTxId :: TxIdType SimpleTx
$sel:depositTxId:InitTx :: forall tx. PostChainTx tx -> TxIdType tx
depositTxId}} -> SimpleId
TxIdType SimpleTx
depositTxId SimpleId -> SimpleId -> Bool
forall a. Eq a => a -> a -> Bool
== SimpleId
txid2
            Effect SimpleTx
_ -> Bool
False

        String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"does not post IncrementTx when DepositActivated fires for a non-commit snapshot mid-ack" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
          -- Regression: 'DepositActivated' can set 'currentDepositTxId' via
          -- '<|>' while a snapshot with no 'utxoToCommit' is in-flight. The
          -- gate on 'snapshot.utxoToCommit = Just _' prevents posting a
          -- malformed IncrementTx in that case.
          UTCTime
now <- IO UTCTime
forall (m :: * -> *). MonadTime m => m UTCTime
getCurrentTime
          let depositTime :: NominalDiffTime -> UTCTime
depositTime = (NominalDiffTime -> UTCTime -> UTCTime)
-> UTCTime -> NominalDiffTime -> UTCTime
forall a b c. (a -> b -> c) -> b -> a -> c
flip NominalDiffTime -> UTCTime -> UTCTime
addUTCTime UTCTime
now
              deadline :: UTCTime
deadline = NominalDiffTime -> UTCTime
depositTime NominalDiffTime
600
              depositTxId' :: SimpleId
depositTxId' = SimpleId
99 :: Integer
              deposit :: Deposit SimpleTx
deposit =
                Deposit
                  { $sel:headId:Deposit :: HeadId
headId = HeadId
testHeadId
                  , $sel:deposited:Deposit :: UTxOType SimpleTx
deposited = SimpleId -> UTxOType SimpleTx
utxoRef SimpleId
99
                  , $sel:created:Deposit :: UTCTime
created = NominalDiffTime -> UTCTime
depositTime NominalDiffTime
1
                  , UTCTime
$sel:deadline:Deposit :: UTCTime
deadline :: UTCTime
deadline
                  , $sel:status:Deposit :: DepositStatus
status = DepositStatus
Active
                  }
              snapshot1 :: Snapshot SimpleTx
snapshot1 = SnapshotNumber
-> SnapshotVersion
-> [SimpleTx]
-> UTxOType SimpleTx
-> Snapshot SimpleTx
forall tx.
IsTx tx =>
SnapshotNumber
-> SnapshotVersion -> [tx] -> UTxOType tx -> Snapshot tx
testSnapshot SnapshotNumber
1 SnapshotVersion
0 [] UTxOType SimpleTx
forall a. Monoid a => a
mempty
              s0 :: NodeState SimpleTx
s0 =
                ( [Party] -> CoordinatedHeadState SimpleTx -> NodeState SimpleTx
inOpenState'
                    [Party
alice]
                    CoordinatedHeadState SimpleTx
coordinatedHeadState
                      { seenSnapshot = mkSeenSnapshot snapshot1 Map.empty
                      , currentDepositTxId = Just depositTxId'
                      }
                )
                  { pendingDeposits = Map.singleton depositTxId' deposit
                  }
              ackSn :: Input SimpleTx
ackSn = Message SimpleTx -> Input SimpleTx
forall tx. Message tx -> Input tx
receiveMessage (Message SimpleTx -> Input SimpleTx)
-> Message SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ Signature (Snapshot SimpleTx) -> SnapshotNumber -> Message SimpleTx
forall tx. Signature (Snapshot tx) -> SnapshotNumber -> Message tx
AckSn (Secret (SigningKey HydraKey)
-> Snapshot SimpleTx -> Signature (Snapshot SimpleTx)
forall a.
SignableRepresentation a =>
Secret (SigningKey HydraKey) -> a -> Signature a
sign Secret (SigningKey HydraKey)
aliceSk Snapshot SimpleTx
snapshot1) SnapshotNumber
1
              outcome :: Outcome SimpleTx
outcome = Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
aliceEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
s0 Input SimpleTx
ackSn
          Outcome SimpleTx
outcome Outcome SimpleTx -> (Effect SimpleTx -> Bool) -> IO ()
forall tx.
(HasCallStack, IsChainState tx) =>
Outcome tx -> (Effect tx -> Bool) -> IO ()
`hasNoEffectSatisfying` \case
            OnChainEffect{$sel:postChainTx:ClientEffect :: forall tx. Effect tx -> PostChainTx tx
postChainTx = IncrementTx{}} -> Bool
True
            Effect SimpleTx
_ -> Bool
False

      String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Decommit" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
        String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"observes DecommitRecorded and ReqDec in an Open state" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
          let outputs :: UTxOType SimpleTx
outputs = SimpleId -> UTxOType SimpleTx
utxoRef SimpleId
1
              transaction :: SimpleTx
transaction = SimpleId -> UTxOType SimpleTx -> UTxOType SimpleTx -> SimpleTx
SimpleTx SimpleId
1 Set SimpleTxOut
UTxOType SimpleTx
forall a. Monoid a => a
mempty Set SimpleTxOut
UTxOType SimpleTx
outputs
              input :: Input SimpleTx
input = Message SimpleTx -> Input SimpleTx
forall tx. Message tx -> Input tx
receiveMessage ReqDec{SimpleTx
transaction :: SimpleTx
$sel:transaction:ReqTx :: SimpleTx
transaction}
              st :: NodeState SimpleTx
st = [Party] -> NodeState SimpleTx
inOpenState [Party]
threeParties
          UTCTime
now <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
st.chainPointTime.currentSlot
          Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
aliceEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
st Input SimpleTx
input Outcome SimpleTx -> (StateChanged SimpleTx -> Bool) -> IO ()
forall tx.
(HasCallStack, IsChainState tx) =>
Outcome tx -> (StateChanged tx -> Bool) -> IO ()
`hasStateChangedSatisfying` \case
            DecommitRecorded{HeadId
$sel:headId:NetworkConnected :: forall tx. StateChanged tx -> HeadId
headId :: HeadId
headId, SimpleTx
decommitTx :: SimpleTx
$sel:decommitTx:NetworkConnected :: forall tx. StateChanged tx -> tx
decommitTx} -> HeadId
headId HeadId -> HeadId -> Bool
forall a. Eq a => a -> a -> Bool
== HeadId
testHeadId Bool -> Bool -> Bool
&& SimpleTx -> UTxOType SimpleTx
forall tx. IsTx tx => tx -> UTxOType tx
utxoFromTx SimpleTx
decommitTx Set SimpleTxOut -> Set SimpleTxOut -> Bool
forall a. Eq a => a -> a -> Bool
== Set SimpleTxOut
outputs
            StateChanged SimpleTx
_ -> Bool
False

        String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"rejects a decommit tx that materializes no output" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
          -- 'Hydra.Contract.Head.checkDecrement' requires at least one decommit
          -- output, so such a decommit could never settle on-chain. Recording it
          -- would block every later snapshot, which cannot carry another one.
          let decommitTx :: SimpleTx
decommitTx = SimpleId -> UTxOType SimpleTx -> UTxOType SimpleTx -> SimpleTx
SimpleTx SimpleId
1 Set SimpleTxOut
UTxOType SimpleTx
forall a. Monoid a => a
mempty Set SimpleTxOut
UTxOType SimpleTx
forall a. Monoid a => a
mempty
              st :: NodeState SimpleTx
st = [Party] -> NodeState SimpleTx
inOpenState [Party]
threeParties
          UTCTime
now <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
st.chainPointTime.currentSlot
          Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
aliceEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
st (Message SimpleTx -> Input SimpleTx
forall tx. Message tx -> Input tx
receiveMessage ReqDec{$sel:transaction:ReqTx :: SimpleTx
transaction = SimpleTx
decommitTx})
            Outcome SimpleTx -> (StateChanged SimpleTx -> Bool) -> IO ()
forall tx.
(HasCallStack, IsChainState tx) =>
Outcome tx -> (StateChanged tx -> Bool) -> IO ()
`hasStateChangedSatisfying` \case
              DecommitInvalid{$sel:decommitTx:NetworkConnected :: forall tx. StateChanged tx -> tx
decommitTx = SimpleTx
invalidTx} -> SimpleTx
invalidTx SimpleTx -> SimpleTx -> Bool
forall a. Eq a => a -> a -> Bool
== SimpleTx
decommitTx
              StateChanged SimpleTx
_ -> Bool
False

        String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"rejects a ReqSn whose decommit tx materializes no output" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
          let decommitTx :: SimpleTx
decommitTx = SimpleId -> UTxOType SimpleTx -> UTxOType SimpleTx -> SimpleTx
SimpleTx SimpleId
1 Set SimpleTxOut
UTxOType SimpleTx
forall a. Monoid a => a
mempty Set SimpleTxOut
UTxOType SimpleTx
forall a. Monoid a => a
mempty
              st :: NodeState SimpleTx
st = [Party] -> NodeState SimpleTx
inOpenState [Party]
threeParties
          UTCTime
now <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
st.chainPointTime.currentSlot
          Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
aliceEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
st (Message SimpleTx -> Input SimpleTx
forall tx. Message tx -> Input tx
receiveMessage (Message SimpleTx -> Input SimpleTx)
-> Message SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ SnapshotVersion
-> SnapshotNumber
-> [TxIdType SimpleTx]
-> Maybe SimpleTx
-> Maybe (TxIdType SimpleTx)
-> Message SimpleTx
forall tx.
SnapshotVersion
-> SnapshotNumber
-> [TxIdType tx]
-> Maybe tx
-> Maybe (TxIdType tx)
-> Message tx
ReqSn SnapshotVersion
0 SnapshotNumber
1 [] (SimpleTx -> Maybe SimpleTx
forall a. a -> Maybe a
Just SimpleTx
decommitTx) Maybe SimpleId
Maybe (TxIdType SimpleTx)
forall a. Maybe a
Nothing)
            Outcome SimpleTx -> Outcome SimpleTx -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` LogicError SimpleTx -> Outcome SimpleTx
forall tx. LogicError tx -> Outcome tx
Error (RequirementFailure SimpleTx -> LogicError SimpleTx
forall tx. RequirementFailure tx -> LogicError tx
RequireFailed ReqSnDecommitNoOutputs{$sel:decommitTxId:ReqSnNumberInvalid :: TxIdType SimpleTx
decommitTxId = SimpleTx -> TxIdType SimpleTx
forall tx. IsTx tx => tx -> TxIdType tx
txId SimpleTx
decommitTx})

        String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"rejects a ReqSn carrying both a commit and a decommit" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
          -- Close and fanout express a single incremental action, so a confirmed
          -- snapshot settling both could never be closed.
          let decommitTx :: SimpleTx
decommitTx = SimpleId -> UTxOType SimpleTx -> UTxOType SimpleTx -> SimpleTx
SimpleTx SimpleId
1 (SimpleId -> UTxOType SimpleTx
utxoRef SimpleId
1) (SimpleId -> UTxOType SimpleTx
utxoRef SimpleId
2)
              depositTxId :: SimpleId
depositTxId = SimpleId
42
              st :: NodeState SimpleTx
st = [Party] -> NodeState SimpleTx
inOpenState [Party]
threeParties
          UTCTime
now <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
st.chainPointTime.currentSlot
          Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
aliceEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
st (Message SimpleTx -> Input SimpleTx
forall tx. Message tx -> Input tx
receiveMessage (Message SimpleTx -> Input SimpleTx)
-> Message SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ SnapshotVersion
-> SnapshotNumber
-> [TxIdType SimpleTx]
-> Maybe SimpleTx
-> Maybe (TxIdType SimpleTx)
-> Message SimpleTx
forall tx.
SnapshotVersion
-> SnapshotNumber
-> [TxIdType tx]
-> Maybe tx
-> Maybe (TxIdType tx)
-> Message tx
ReqSn SnapshotVersion
0 SnapshotNumber
1 [] (SimpleTx -> Maybe SimpleTx
forall a. a -> Maybe a
Just SimpleTx
decommitTx) (SimpleId -> Maybe SimpleId
forall a. a -> Maybe a
Just SimpleId
depositTxId))
            Outcome SimpleTx -> Outcome SimpleTx -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` LogicError SimpleTx -> Outcome SimpleTx
forall tx. LogicError tx -> Outcome tx
Error
              ( RequirementFailure SimpleTx -> LogicError SimpleTx
forall tx. RequirementFailure tx -> LogicError tx
RequireFailed
                  ReqSnBothCommitAndDecommit{SimpleId
TxIdType SimpleTx
depositTxId :: SimpleId
$sel:depositTxId:ReqSnNumberInvalid :: TxIdType SimpleTx
depositTxId, $sel:decommitTxId:ReqSnNumberInvalid :: TxIdType SimpleTx
decommitTxId = SimpleTx -> TxIdType SimpleTx
forall tx. IsTx tx => tx -> TxIdType tx
txId SimpleTx
decommitTx}
              )

        String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"never requests a commit and a decommit in the same snapshot" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
          -- An in-flight commit wins: its deposit expires on-chain while a
          -- decommit only waits. No *new* commit starts alongside a decommit, so
          -- the decommit is not starved.
          UTCTime
now <- IO UTCTime
forall (m :: * -> *). MonadTime m => m UTCTime
getCurrentTime
          let depositTxId :: SimpleId
depositTxId = SimpleId
4711
              pendingDeposits :: Map SimpleId (Deposit SimpleTx)
pendingDeposits =
                SimpleId -> Deposit SimpleTx -> Map SimpleId (Deposit SimpleTx)
forall k a. k -> a -> Map k a
Map.singleton
                  SimpleId
depositTxId
                  Deposit
                    { $sel:headId:Deposit :: HeadId
headId = HeadId
testHeadId
                    , $sel:deposited:Deposit :: UTxOType SimpleTx
deposited = SimpleId -> UTxOType SimpleTx
utxoRef SimpleId
50
                    , $sel:created:Deposit :: UTCTime
created = UTCTime
now
                    , $sel:deadline:Deposit :: UTCTime
deadline = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
3600 UTCTime
now
                    , $sel:status:Deposit :: DepositStatus
status = DepositStatus
Active
                    }
              decommitTx :: SimpleTx
decommitTx = SimpleId -> UTxOType SimpleTx -> UTxOType SimpleTx -> SimpleTx
SimpleTx SimpleId
1 (SimpleId -> UTxOType SimpleTx
utxoRef SimpleId
1) (SimpleId -> UTxOType SimpleTx
utxoRef SimpleId
2)
          Map (TxIdType SimpleTx) (Deposit SimpleTx)
-> Maybe (TxIdType SimpleTx)
-> Maybe SimpleTx
-> Maybe (UTxOType SimpleTx)
-> (Maybe SimpleTx, Maybe (TxIdType SimpleTx))
forall tx.
IsTx tx =>
PendingDeposits tx
-> Maybe (TxIdType tx)
-> Maybe tx
-> Maybe (UTxOType tx)
-> (Maybe tx, Maybe (TxIdType tx))
selectNextIncrementalAction Map SimpleId (Deposit SimpleTx)
Map (TxIdType SimpleTx) (Deposit SimpleTx)
pendingDeposits (SimpleId -> Maybe SimpleId
forall a. a -> Maybe a
Just SimpleId
depositTxId) (SimpleTx -> Maybe SimpleTx
forall a. a -> Maybe a
Just SimpleTx
decommitTx) Maybe (Set SimpleTxOut)
Maybe (UTxOType SimpleTx)
forall a. Maybe a
Nothing
            (Maybe SimpleTx, Maybe SimpleId)
-> (Maybe SimpleTx, Maybe SimpleId) -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` (Maybe SimpleTx
forall a. Maybe a
Nothing, SimpleId -> Maybe SimpleId
forall a. a -> Maybe a
Just SimpleId
depositTxId)
          Map (TxIdType SimpleTx) (Deposit SimpleTx)
-> Maybe (TxIdType SimpleTx)
-> Maybe SimpleTx
-> Maybe (UTxOType SimpleTx)
-> (Maybe SimpleTx, Maybe (TxIdType SimpleTx))
forall tx.
IsTx tx =>
PendingDeposits tx
-> Maybe (TxIdType tx)
-> Maybe tx
-> Maybe (UTxOType tx)
-> (Maybe tx, Maybe (TxIdType tx))
selectNextIncrementalAction Map SimpleId (Deposit SimpleTx)
Map (TxIdType SimpleTx) (Deposit SimpleTx)
pendingDeposits Maybe SimpleId
Maybe (TxIdType SimpleTx)
forall a. Maybe a
Nothing (SimpleTx -> Maybe SimpleTx
forall a. a -> Maybe a
Just SimpleTx
decommitTx) Maybe (Set SimpleTxOut)
Maybe (UTxOType SimpleTx)
forall a. Maybe a
Nothing
            (Maybe SimpleTx, Maybe SimpleId)
-> (Maybe SimpleTx, Maybe SimpleId) -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` (SimpleTx -> Maybe SimpleTx
forall a. a -> Maybe a
Just SimpleTx
decommitTx, Maybe SimpleId
forall a. Maybe a
Nothing)

        String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"ignores ReqDec when not in Open state" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
          let reqDec :: Message SimpleTx
reqDec = ReqDec{$sel:transaction:ReqTx :: SimpleTx
transaction = SimpleId -> UTxOType SimpleTx -> UTxOType SimpleTx -> SimpleTx
SimpleTx SimpleId
1 Set SimpleTxOut
UTxOType SimpleTx
forall a. Monoid a => a
mempty (SimpleId -> UTxOType SimpleTx
utxoRef SimpleId
1)}
          let input :: Input SimpleTx
input = Message SimpleTx -> Input SimpleTx
forall tx. Message tx -> Input tx
receiveMessage Message SimpleTx
reqDec
              st :: NodeState SimpleTx
st = [Party] -> NodeState SimpleTx
inClosedState [Party]
threeParties
          UTCTime
now <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
st.chainPointTime.currentSlot
          Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
aliceEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
st Input SimpleTx
input
            Outcome SimpleTx -> Outcome SimpleTx -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldNotBe` Effect SimpleTx -> Outcome SimpleTx
forall tx. Effect tx -> Outcome tx
cause (Message SimpleTx -> Effect SimpleTx
forall tx. Message tx -> Effect tx
NetworkEffect Message SimpleTx
reqDec)

        String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"reports if a requested decommit tx is expired" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
          let inputs :: UTxOType SimpleTx
inputs = SimpleId -> UTxOType SimpleTx
utxoRef SimpleId
1
              decommitTx :: SimpleTx
decommitTx = SimpleId -> UTxOType SimpleTx -> UTxOType SimpleTx -> SimpleTx
SimpleTx SimpleId
1 Set SimpleTxOut
UTxOType SimpleTx
forall a. Monoid a => a
mempty Set SimpleTxOut
UTxOType SimpleTx
inputs
              ttl :: Natural
ttl = Natural
0
              reqDec :: Message SimpleTx
reqDec = ReqDec{$sel:transaction:ReqTx :: SimpleTx
transaction = SimpleTx
decommitTx}
              reqDecEvent :: Input SimpleTx
reqDecEvent = Natural -> NetworkEvent (Message SimpleTx) -> Input SimpleTx
forall tx. Natural -> NetworkEvent (Message tx) -> Input tx
NetworkInput Natural
ttl (NetworkEvent (Message SimpleTx) -> Input SimpleTx)
-> NetworkEvent (Message SimpleTx) -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ ReceivedMessage{$sel:sender:ConnectivityEvent :: Party
sender = Party
alice, $sel:msg:ConnectivityEvent :: Message SimpleTx
msg = Message SimpleTx
reqDec}
              decommitTxInFlight :: SimpleTx
decommitTxInFlight = SimpleId -> UTxOType SimpleTx -> UTxOType SimpleTx -> SimpleTx
SimpleTx SimpleId
2 Set SimpleTxOut
UTxOType SimpleTx
forall a. Monoid a => a
mempty (SimpleId -> UTxOType SimpleTx
utxoRef SimpleId
2)
              s0 :: NodeState SimpleTx
s0 =
                [Party] -> CoordinatedHeadState SimpleTx -> NodeState SimpleTx
inOpenState' [Party]
threeParties (CoordinatedHeadState SimpleTx -> NodeState SimpleTx)
-> CoordinatedHeadState SimpleTx -> NodeState SimpleTx
forall a b. (a -> b) -> a -> b
$
                  CoordinatedHeadState SimpleTx
coordinatedHeadState
                    { decommitTx = Just decommitTxInFlight
                    }
          UTCTime
now <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
s0.chainPointTime.currentSlot
          Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
s0 Input SimpleTx
reqDecEvent Outcome SimpleTx -> (StateChanged SimpleTx -> Bool) -> IO ()
forall tx.
(HasCallStack, IsChainState tx) =>
Outcome tx -> (StateChanged tx -> Bool) -> IO ()
`hasStateChangedSatisfying` \case
            DecommitInvalid{$sel:decommitTx:NetworkConnected :: forall tx. StateChanged tx -> tx
decommitTx = SimpleTx
invalidTx} -> SimpleTx
invalidTx SimpleTx -> SimpleTx -> Bool
forall a. Eq a => a -> a -> Bool
== SimpleTx
decommitTx
            StateChanged SimpleTx
_ -> Bool
False

        -- Spec §6.4 reqDec: wait U_α = ∅. A decommit must wait while a commit
        -- (deposit) is pending, otherwise a later snapshot would carry both. This
        -- is the missing symmetric counterpart to the guard on 'DepositActivated'.
        --
        -- "Pending" is what 'existingDeposit' decides: registered and unexpired. The
        -- two states that are NOT pending yet still leave 'currentDepositTxId' set
        -- each get a case below, because blocking on either waits on something that
        -- can never settle.
        String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"waits on a ReqDec while a pending commit (deposit) is in flight" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
          let s0 :: NodeState SimpleTx
s0 = [Party] -> Maybe DepositStatus -> NodeState SimpleTx
reqDecStateWith [Party]
threeParties (DepositStatus -> Maybe DepositStatus
forall a. a -> Maybe a
Just DepositStatus
Active)
          UTCTime
now <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
s0.chainPointTime.currentSlot
          Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
aliceEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
s0 (Message SimpleTx -> Input SimpleTx
forall tx. Message tx -> Input tx
receiveMessage ReqDec{$sel:transaction:ReqTx :: SimpleTx
transaction = SimpleTx
reqDecDecommitTx})
            Outcome SimpleTx -> WaitReason SimpleTx -> IO ()
forall tx.
(HasCallStack, IsChainState tx) =>
Outcome tx -> WaitReason tx -> IO ()
`assertWait` WaitOnUnresolvedCommit{commitUTxO :: UTxOType SimpleTx
commitUTxO = UTxOType SimpleTx
reqDecDepositedUTxO}

        -- Once ttl is exhausted the pending-deposit wait turns into a rejection
        -- (DepositInFlight) so the client learns it must recover the deposit,
        -- rather than the ReqDec being silently dropped.
        String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"rejects a ReqDec with DepositInFlight once ttl is exhausted while a pending commit is in flight" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
          let s0 :: NodeState SimpleTx
s0 = [Party] -> Maybe DepositStatus -> NodeState SimpleTx
reqDecStateWith [Party]
threeParties (DepositStatus -> Maybe DepositStatus
forall a. a -> Maybe a
Just DepositStatus
Active)
              reqDecEvent :: Input SimpleTx
reqDecEvent = Natural -> NetworkEvent (Message SimpleTx) -> Input SimpleTx
forall tx. Natural -> NetworkEvent (Message tx) -> Input tx
NetworkInput Natural
0 (NetworkEvent (Message SimpleTx) -> Input SimpleTx)
-> NetworkEvent (Message SimpleTx) -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ ReceivedMessage{$sel:sender:ConnectivityEvent :: Party
sender = Party
alice, $sel:msg:ConnectivityEvent :: Message SimpleTx
msg = ReqDec{$sel:transaction:ReqTx :: SimpleTx
transaction = SimpleTx
reqDecDecommitTx}}
          UTCTime
now <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
s0.chainPointTime.currentSlot
          Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
aliceEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
s0 Input SimpleTx
reqDecEvent Outcome SimpleTx -> (StateChanged SimpleTx -> Bool) -> IO ()
forall tx.
(HasCallStack, IsChainState tx) =>
Outcome tx -> (StateChanged tx -> Bool) -> IO ()
`hasStateChangedSatisfying` \case
            DecommitInvalid{$sel:decommitTx:NetworkConnected :: forall tx. StateChanged tx -> tx
decommitTx = SimpleTx
invalidTx, $sel:decommitInvalidReason:NetworkConnected :: forall tx. StateChanged tx -> DecommitInvalidReason tx
decommitInvalidReason = DepositInFlight{TxIdType SimpleTx
depositTxId :: TxIdType SimpleTx
$sel:depositTxId:DecommitTxInvalid :: forall tx. DecommitInvalidReason tx -> TxIdType tx
depositTxId, UTxOType SimpleTx
commitUTxO :: UTxOType SimpleTx
$sel:commitUTxO:DecommitTxInvalid :: forall tx. DecommitInvalidReason tx -> UTxOType tx
commitUTxO}} ->
              SimpleTx
invalidTx SimpleTx -> SimpleTx -> Bool
forall a. Eq a => a -> a -> Bool
== SimpleTx
reqDecDecommitTx
                Bool -> Bool -> Bool
&& SimpleId
TxIdType SimpleTx
depositTxId SimpleId -> SimpleId -> Bool
forall a. Eq a => a -> a -> Bool
== SimpleId
TxIdType SimpleTx
reqDecDepositTxId
                Bool -> Bool -> Bool
&& Set SimpleTxOut
UTxOType SimpleTx
commitUTxO Set SimpleTxOut -> Set SimpleTxOut -> Bool
forall a. Eq a => a -> a -> Bool
== Set SimpleTxOut
UTxOType SimpleTx
reqDecDepositedUTxO
            StateChanged SimpleTx
_ -> Bool
False

        -- An expired deposit must NOT hold a decommit back. 'DepositExpired' deliberately keeps the
        -- deposit in the map so it can still be recovered, and clears nothing, so a guard reading
        -- 'currentDepositTxId' directly blocked every later decommit on a commit that can never
        -- settle: the wait never resolves and the ttl rejection repeats for every request.
        String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"records a ReqDec when the recorded deposit has expired" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
          let s0 :: NodeState SimpleTx
s0 = [Party] -> Maybe DepositStatus -> NodeState SimpleTx
reqDecStateWith [Party]
threeParties (DepositStatus -> Maybe DepositStatus
forall a. a -> Maybe a
Just DepositStatus
Expired)
          UTCTime
now <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
s0.chainPointTime.currentSlot
          Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
aliceEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
s0 (Message SimpleTx -> Input SimpleTx
forall tx. Message tx -> Input tx
receiveMessage ReqDec{$sel:transaction:ReqTx :: SimpleTx
transaction = SimpleTx
reqDecDecommitTx})
            Outcome SimpleTx -> (StateChanged SimpleTx -> Bool) -> IO ()
forall tx.
(HasCallStack, IsChainState tx) =>
Outcome tx -> (StateChanged tx -> Bool) -> IO ()
`hasStateChangedSatisfying` \case
              DecommitRecorded{$sel:decommitTx:NetworkConnected :: forall tx. StateChanged tx -> tx
decommitTx = SimpleTx
recorded} -> SimpleTx
recorded SimpleTx -> SimpleTx -> Bool
forall a. Eq a => a -> a -> Bool
== SimpleTx
reqDecDecommitTx
              StateChanged SimpleTx
_ -> Bool
False

        -- Nor may a deposit that has already been recovered: 'DepositRecovered' deletes the map
        -- entry and also leaves 'currentDepositTxId' set.
        String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"records a ReqDec when the recorded deposit was already recovered" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
          let s0 :: NodeState SimpleTx
s0 = [Party] -> Maybe DepositStatus -> NodeState SimpleTx
reqDecStateWith [Party]
threeParties Maybe DepositStatus
forall a. Maybe a
Nothing
          UTCTime
now <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
s0.chainPointTime.currentSlot
          Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
aliceEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
s0 (Message SimpleTx -> Input SimpleTx
forall tx. Message tx -> Input tx
receiveMessage ReqDec{$sel:transaction:ReqTx :: SimpleTx
transaction = SimpleTx
reqDecDecommitTx})
            Outcome SimpleTx -> (StateChanged SimpleTx -> Bool) -> IO ()
forall tx.
(HasCallStack, IsChainState tx) =>
Outcome tx -> (StateChanged tx -> Bool) -> IO ()
`hasStateChangedSatisfying` \case
              DecommitRecorded{$sel:decommitTx:NetworkConnected :: forall tx. StateChanged tx -> tx
decommitTx = SimpleTx
recorded} -> SimpleTx
recorded SimpleTx -> SimpleTx -> Bool
forall a. Eq a => a -> a -> Bool
== SimpleTx
reqDecDecommitTx
              StateChanged SimpleTx
_ -> Bool
False

        String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"wait for second decommit when another one is in flight" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$
          do
            let decommitTx1 :: SimpleTx
decommitTx1 = SimpleId -> UTxOType SimpleTx -> UTxOType SimpleTx -> SimpleTx
SimpleTx SimpleId
1 Set SimpleTxOut
UTxOType SimpleTx
forall a. Monoid a => a
mempty (SimpleId -> UTxOType SimpleTx
utxoRef SimpleId
1)
                decommitTx2 :: SimpleTx
decommitTx2 = SimpleId -> UTxOType SimpleTx -> UTxOType SimpleTx -> SimpleTx
SimpleTx SimpleId
2 Set SimpleTxOut
UTxOType SimpleTx
forall a. Monoid a => a
mempty (SimpleId -> UTxOType SimpleTx
utxoRef SimpleId
2)
                s0 :: NodeState SimpleTx
s0 = [Party] -> NodeState SimpleTx
inOpenState [Party]
threeParties

            NodeState SimpleTx
s1 <- Environment
-> Ledger SimpleTx
-> NodeState SimpleTx
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall (m :: * -> *) tx a.
Monad m =>
Environment
-> Ledger tx -> NodeState tx -> StateT (StepState tx) m a -> m a
runHeadLogic Environment
aliceEnv Ledger SimpleTx
ledger NodeState SimpleTx
s0 (StateT (StepState SimpleTx) IO (NodeState SimpleTx)
 -> IO (NodeState SimpleTx))
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall a b. (a -> b) -> a -> b
$ do
              Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step (Input SimpleTx
 -> StateT (StepState SimpleTx) IO (Outcome SimpleTx))
-> Input SimpleTx
-> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall a b. (a -> b) -> a -> b
$ Party -> Message SimpleTx -> Input SimpleTx
forall tx. Party -> Message tx -> Input tx
receiveMessageFrom Party
alice ReqDec{$sel:transaction:ReqTx :: SimpleTx
transaction = SimpleTx
decommitTx1}
              StateT (StepState SimpleTx) IO (NodeState SimpleTx)
forall tx (m :: * -> *).
MonadState (StepState tx) m =>
m (NodeState tx)
getState

            UTCTime
now <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
s1.chainPointTime.currentSlot
            Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
s1 (Party -> Message SimpleTx -> Input SimpleTx
forall tx. Party -> Message tx -> Input tx
receiveMessageFrom Party
bob ReqDec{$sel:transaction:ReqTx :: SimpleTx
transaction = SimpleTx
decommitTx2})
              Outcome SimpleTx -> WaitReason SimpleTx -> IO ()
forall tx.
(HasCallStack, IsChainState tx) =>
Outcome tx -> WaitReason tx -> IO ()
`assertWait` WaitOnNotApplicableDecommitTx
                { $sel:notApplicableReason:WaitOnNotApplicableTx :: DecommitInvalidReason SimpleTx
notApplicableReason =
                    DecommitAlreadyInFlight
                      { $sel:otherDecommitTxId:DecommitTxInvalid :: TxIdType SimpleTx
otherDecommitTxId = SimpleTx -> TxIdType SimpleTx
forall tx. IsTx tx => tx -> TxIdType tx
txId SimpleTx
decommitTx1
                      }
                }

        String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"waits if a requested decommit tx is not (yet) applicable" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
          let decommitTx :: SimpleTx
decommitTx = SimpleTx{$sel:txSimpleId:SimpleTx :: SimpleId
txSimpleId = SimpleId
1, $sel:txInputs:SimpleTx :: UTxOType SimpleTx
txInputs = [SimpleId] -> UTxOType SimpleTx
utxoRefs [SimpleId
2], $sel:txOutputs:SimpleTx :: UTxOType SimpleTx
txOutputs = [SimpleId] -> UTxOType SimpleTx
utxoRefs [SimpleId
4]}
              s0 :: NodeState SimpleTx
s0 = [Party] -> NodeState SimpleTx
inOpenState [Party]
threeParties
              reqDecEvent :: Input SimpleTx
reqDecEvent = Message SimpleTx -> Input SimpleTx
forall tx. Message tx -> Input tx
receiveMessage ReqDec{$sel:transaction:ReqTx :: SimpleTx
transaction = SimpleTx
decommitTx}

          UTCTime
now <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
s0.chainPointTime.currentSlot
          Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
aliceEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
s0 Input SimpleTx
reqDecEvent
            Outcome SimpleTx -> WaitReason SimpleTx -> IO ()
forall tx.
(HasCallStack, IsChainState tx) =>
Outcome tx -> WaitReason tx -> IO ()
`assertWait` DecommitInvalidReason SimpleTx -> WaitReason SimpleTx
forall tx. DecommitInvalidReason tx -> WaitReason tx
WaitOnNotApplicableDecommitTx (UTxOType SimpleTx
-> ValidationError -> DecommitInvalidReason SimpleTx
forall tx.
UTxOType tx -> ValidationError -> DecommitInvalidReason tx
DecommitTxInvalid Set SimpleTxOut
UTxOType SimpleTx
forall a. Monoid a => a
mempty (Text -> ValidationError
ValidationError Text
"cannot apply transaction"))

        String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"updates decommitTx on valid ReqDec" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
          let decommitTx' :: SimpleTx
decommitTx' = SimpleId -> UTxOType SimpleTx -> UTxOType SimpleTx -> SimpleTx
SimpleTx SimpleId
1 Set SimpleTxOut
UTxOType SimpleTx
forall a. Monoid a => a
mempty (SimpleId -> UTxOType SimpleTx
utxoRef SimpleId
1)
          let reqDec :: Message SimpleTx
reqDec = ReqDec{$sel:transaction:ReqTx :: SimpleTx
transaction = SimpleTx
decommitTx'}
              reqDecEvent :: Input SimpleTx
reqDecEvent = Message SimpleTx -> Input SimpleTx
forall tx. Message tx -> Input tx
receiveMessage Message SimpleTx
reqDec
              s0 :: NodeState SimpleTx
s0 = [Party] -> NodeState SimpleTx
inOpenState [Party]
threeParties

          NodeState SimpleTx -> HeadState SimpleTx
forall tx. NodeState tx -> HeadState tx
headState NodeState SimpleTx
s0 HeadState SimpleTx -> (HeadState SimpleTx -> Bool) -> IO ()
forall a. (HasCallStack, Show a) => a -> (a -> Bool) -> IO ()
`shouldSatisfy` \case
            (Open OpenState{$sel:coordinatedHeadState:OpenState :: forall tx. OpenState tx -> CoordinatedHeadState tx
coordinatedHeadState = CoordinatedHeadState{Maybe SimpleTx
$sel:decommitTx:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> Maybe tx
decommitTx :: Maybe SimpleTx
decommitTx}}) -> Maybe SimpleTx -> Bool
forall a. Maybe a -> Bool
isNothing Maybe SimpleTx
decommitTx
            HeadState SimpleTx
_ -> Bool
False

          NodeState SimpleTx
s1 <- Environment
-> Ledger SimpleTx
-> NodeState SimpleTx
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall (m :: * -> *) tx a.
Monad m =>
Environment
-> Ledger tx -> NodeState tx -> StateT (StepState tx) m a -> m a
runHeadLogic Environment
aliceEnv Ledger SimpleTx
ledger NodeState SimpleTx
s0 (StateT (StepState SimpleTx) IO (NodeState SimpleTx)
 -> IO (NodeState SimpleTx))
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall a b. (a -> b) -> a -> b
$ do
            Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step Input SimpleTx
reqDecEvent
            StateT (StepState SimpleTx) IO (NodeState SimpleTx)
forall tx (m :: * -> *).
MonadState (StepState tx) m =>
m (NodeState tx)
getState

          NodeState SimpleTx -> HeadState SimpleTx
forall tx. NodeState tx -> HeadState tx
headState NodeState SimpleTx
s1 HeadState SimpleTx -> (HeadState SimpleTx -> Bool) -> IO ()
forall a. (HasCallStack, Show a) => a -> (a -> Bool) -> IO ()
`shouldSatisfy` \case
            (Open OpenState{$sel:coordinatedHeadState:OpenState :: forall tx. OpenState tx -> CoordinatedHeadState tx
coordinatedHeadState = CoordinatedHeadState{Maybe SimpleTx
$sel:decommitTx:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> Maybe tx
decommitTx :: Maybe SimpleTx
decommitTx}}) -> Maybe SimpleTx
decommitTx Maybe SimpleTx -> Maybe SimpleTx -> Bool
forall a. Eq a => a -> a -> Bool
== SimpleTx -> Maybe SimpleTx
forall a. a -> Maybe a
Just SimpleTx
decommitTx'
            HeadState SimpleTx
_ -> Bool
False

          -- running the 'ReqDec' again should not alter the recorded state
          NodeState SimpleTx
s2 <- Environment
-> Ledger SimpleTx
-> NodeState SimpleTx
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall (m :: * -> *) tx a.
Monad m =>
Environment
-> Ledger tx -> NodeState tx -> StateT (StepState tx) m a -> m a
runHeadLogic Environment
aliceEnv Ledger SimpleTx
ledger NodeState SimpleTx
s1 (StateT (StepState SimpleTx) IO (NodeState SimpleTx)
 -> IO (NodeState SimpleTx))
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall a b. (a -> b) -> a -> b
$ do
            Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step Input SimpleTx
reqDecEvent
            StateT (StepState SimpleTx) IO (NodeState SimpleTx)
forall tx (m :: * -> *).
MonadState (StepState tx) m =>
m (NodeState tx)
getState

          NodeState SimpleTx -> HeadState SimpleTx
forall tx. NodeState tx -> HeadState tx
headState NodeState SimpleTx
s2 HeadState SimpleTx -> (HeadState SimpleTx -> Bool) -> IO ()
forall a. (HasCallStack, Show a) => a -> (a -> Bool) -> IO ()
`shouldSatisfy` \case
            (Open OpenState{$sel:coordinatedHeadState:OpenState :: forall tx. OpenState tx -> CoordinatedHeadState tx
coordinatedHeadState = CoordinatedHeadState{Maybe SimpleTx
$sel:decommitTx:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> Maybe tx
decommitTx :: Maybe SimpleTx
decommitTx}}) -> Maybe SimpleTx
decommitTx Maybe SimpleTx -> Maybe SimpleTx -> Bool
forall a. Eq a => a -> a -> Bool
== SimpleTx -> Maybe SimpleTx
forall a. a -> Maybe a
Just SimpleTx
decommitTx'
            HeadState SimpleTx
_ -> Bool
False

        String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"emits ReqSn on valid RecDec" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
          let localUTxO :: UTxOType SimpleTx
localUTxO = [SimpleId] -> UTxOType SimpleTx
utxoRefs [SimpleId
2]
          let decommitTx' :: SimpleTx
decommitTx' = SimpleTx{$sel:txSimpleId:SimpleTx :: SimpleId
txSimpleId = SimpleId
1, $sel:txInputs:SimpleTx :: UTxOType SimpleTx
txInputs = Set SimpleTxOut
UTxOType SimpleTx
localUTxO, $sel:txOutputs:SimpleTx :: UTxOType SimpleTx
txOutputs = [SimpleId] -> UTxOType SimpleTx
utxoRefs [SimpleId
4]}
          let s0 :: NodeState SimpleTx
s0 = [Party] -> CoordinatedHeadState SimpleTx -> NodeState SimpleTx
inOpenState' [Party]
threeParties (CoordinatedHeadState SimpleTx -> NodeState SimpleTx)
-> CoordinatedHeadState SimpleTx -> NodeState SimpleTx
forall a b. (a -> b) -> a -> b
$ CoordinatedHeadState SimpleTx
coordinatedHeadState{localUTxO}

          NodeState SimpleTx -> HeadState SimpleTx
forall tx. NodeState tx -> HeadState tx
headState NodeState SimpleTx
s0 HeadState SimpleTx -> (HeadState SimpleTx -> Bool) -> IO ()
forall a. (HasCallStack, Show a) => a -> (a -> Bool) -> IO ()
`shouldSatisfy` \case
            (Open OpenState{$sel:coordinatedHeadState:OpenState :: forall tx. OpenState tx -> CoordinatedHeadState tx
coordinatedHeadState = CoordinatedHeadState{Maybe SimpleTx
$sel:decommitTx:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> Maybe tx
decommitTx :: Maybe SimpleTx
decommitTx}}) -> Maybe SimpleTx -> Bool
forall a. Maybe a -> Bool
isNothing Maybe SimpleTx
decommitTx
            HeadState SimpleTx
_ -> Bool
False

          let reqDecEvent :: Input SimpleTx
reqDecEvent = Message SimpleTx -> Input SimpleTx
forall tx. Message tx -> Input tx
receiveMessage ReqDec{$sel:transaction:ReqTx :: SimpleTx
transaction = SimpleTx
decommitTx'}

          UTCTime
now <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
s0.chainPointTime.currentSlot
          let s1 :: Outcome SimpleTx
s1 = Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
aliceEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
s0 Input SimpleTx
reqDecEvent

          let reqSn :: Message SimpleTx
reqSn = ReqSn{$sel:snapshotVersion:ReqTx :: SnapshotVersion
snapshotVersion = SnapshotVersion
0, $sel:snapshotNumber:ReqTx :: SnapshotNumber
snapshotNumber = SnapshotNumber
1, $sel:transactionIds:ReqTx :: [TxIdType SimpleTx]
transactionIds = [], $sel:decommitTx:ReqTx :: Maybe SimpleTx
decommitTx = SimpleTx -> Maybe SimpleTx
forall a. a -> Maybe a
Just SimpleTx
decommitTx', $sel:depositTxId:ReqTx :: Maybe (TxIdType SimpleTx)
depositTxId = Maybe SimpleId
Maybe (TxIdType SimpleTx)
forall a. Maybe a
Nothing}
          Outcome SimpleTx
s1 Outcome SimpleTx -> Effect SimpleTx -> IO ()
forall tx.
(HasCallStack, IsChainState tx) =>
Outcome tx -> Effect tx -> IO ()
`hasEffect` Message SimpleTx -> Effect SimpleTx
forall tx. Message tx -> Effect tx
NetworkEffect Message SimpleTx
reqSn

        String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"does not get stuck when DecommitFinalized races with in-flight ReqSn" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
          let localUTxO :: UTxOType SimpleTx
localUTxO = [SimpleId] -> UTxOType SimpleTx
utxoRefs [SimpleId
1]
              confirmedSn :: ConfirmedSnapshot SimpleTx
confirmedSn =
                ConfirmedSnapshot
                  { $sel:snapshot:InitialSnapshot :: Snapshot SimpleTx
snapshot = SnapshotNumber
-> SnapshotVersion
-> [SimpleTx]
-> UTxOType SimpleTx
-> Snapshot SimpleTx
forall tx.
IsTx tx =>
SnapshotNumber
-> SnapshotVersion -> [tx] -> UTxOType tx -> Snapshot tx
testSnapshot SnapshotNumber
0 SnapshotVersion
3 [] Set SimpleTxOut
UTxOType SimpleTx
localUTxO
                  , $sel:signatures:InitialSnapshot :: MultiSignature (Snapshot SimpleTx)
signatures = [Signature (Snapshot SimpleTx)]
-> MultiSignature (Snapshot SimpleTx)
forall a. [Signature a] -> MultiSignature a
Crypto.aggregate []
                  }
              -- State just after leader sent ReqSn(v=3, sn=1): snapshot in flight
              s0 :: NodeState SimpleTx
s0 =
                [Party] -> CoordinatedHeadState SimpleTx -> NodeState SimpleTx
inOpenState' [Party]
threeParties (CoordinatedHeadState SimpleTx -> NodeState SimpleTx)
-> CoordinatedHeadState SimpleTx -> NodeState SimpleTx
forall a b. (a -> b) -> a -> b
$
                  CoordinatedHeadState SimpleTx
coordinatedHeadState
                    { localUTxO
                    , version = 3
                    , confirmedSnapshot = confirmedSn
                    , seenSnapshot = RequestedSnapshot{lastSeen = 0, requested = 1}
                    , decommitTx = Just (SimpleTx 10 mempty (utxoRef 99))
                    }

          -- 1. DecommitFinalized arrives, bumping version to 4
          let decrementObservation :: Input SimpleTx
decrementObservation = OnChainTx SimpleTx -> Input SimpleTx
observeTx (OnChainTx SimpleTx -> Input SimpleTx)
-> OnChainTx SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ OnDecrementTx{$sel:headId:OnInitTx :: HeadId
headId = HeadId
testHeadId, $sel:newVersion:OnInitTx :: SnapshotVersion
newVersion = SnapshotVersion
4, $sel:distributedUTxO:OnInitTx :: UTxOType SimpleTx
distributedUTxO = Set SimpleTxOut
UTxOType SimpleTx
forall a. Monoid a => a
mempty}
          UTCTime
now <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
s0.chainPointTime.currentSlot
          let decommitFinalizedOutcome :: Outcome SimpleTx
decommitFinalizedOutcome = Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
aliceEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
s0 Input SimpleTx
decrementObservation
          let s1 :: NodeState SimpleTx
s1 = NodeState SimpleTx -> Outcome SimpleTx -> NodeState SimpleTx
forall tx.
IsChainState tx =>
NodeState tx -> Outcome tx -> NodeState tx
aggregateState NodeState SimpleTx
s0 Outcome SimpleTx
decommitFinalizedOutcome

          -- Verify seenSnapshot was reset (not stuck as RequestedSnapshot)
          -- After DecommitFinalized, seenSnapshot resets to LastSeenSnapshot{lastSeen=confirmedSn}.
          -- This allows maybeRequestSnapshotAfterDecommit to fire a fresh ReqSn immediately.
          -- NOTE: localUTxO is already correct at this point — DecommitRecorded removed the
          -- decommit outputs from localUTxO when ReqDec was first processed, before ReqSn was sent.
          case NodeState SimpleTx
s1 of
            NodeInSync{$sel:headState:NodeInSync :: forall tx. NodeState tx -> HeadState tx
headState = Open OpenState{$sel:coordinatedHeadState:OpenState :: forall tx. OpenState tx -> CoordinatedHeadState tx
coordinatedHeadState = CoordinatedHeadState SimpleTx
chs}} -> do
              CoordinatedHeadState SimpleTx
chs.version SnapshotVersion -> SnapshotVersion -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` SnapshotVersion
4
              CoordinatedHeadState SimpleTx
chs.seenSnapshot SeenSnapshot SimpleTx -> SeenSnapshot SimpleTx -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` LastSeenSnapshot{$sel:lastSeen:NoSeenSnapshot :: SnapshotNumber
lastSeen = SnapshotNumber
0}
              CoordinatedHeadState SimpleTx
chs.decommitTx Maybe SimpleTx -> Maybe SimpleTx -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Maybe SimpleTx
forall a. Maybe a
Nothing
            NodeState SimpleTx
_ -> String -> IO ()
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"expected Open state"

          -- 2. The stale ReqSn(v=3) arrives. The receiver's version is now 4,
          --    so it cannot be processed; we wait (and TTL eventually drops it)
          --    rather than erroring, since the symmetric race where a follower
          --    is briefly behind a leader's bumped version must recover via
          --    retry.
          let staleReqSn :: Input SimpleTx
              staleReqSn :: Input SimpleTx
staleReqSn = Party -> Message SimpleTx -> Input SimpleTx
forall tx. Party -> Message tx -> Input tx
receiveMessageFrom Party
alice (Message SimpleTx -> Input SimpleTx)
-> Message SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ SnapshotVersion
-> SnapshotNumber
-> [TxIdType SimpleTx]
-> Maybe SimpleTx
-> Maybe (TxIdType SimpleTx)
-> Message SimpleTx
forall tx.
SnapshotVersion
-> SnapshotNumber
-> [TxIdType tx]
-> Maybe tx
-> Maybe (TxIdType tx)
-> Message tx
ReqSn SnapshotVersion
3 SnapshotNumber
1 [] Maybe SimpleTx
forall a. Maybe a
Nothing Maybe SimpleId
Maybe (TxIdType SimpleTx)
forall a. Maybe a
Nothing
          UTCTime
now' <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
s1.chainPointTime.currentSlot
          Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
aliceEnv Ledger SimpleTx
ledger UTCTime
now' NodeState SimpleTx
s1 Input SimpleTx
staleReqSn Outcome SimpleTx -> (Outcome SimpleTx -> Bool) -> IO ()
forall a. (HasCallStack, Show a) => a -> (a -> Bool) -> IO ()
`shouldSatisfy` \case
            Wait WaitOnSnapshotVersion{$sel:waitingForVersion:WaitOnNotApplicableTx :: forall tx. WaitReason tx -> SnapshotVersion
waitingForVersion = SnapshotVersion
3} [StateChanged SimpleTx]
_ -> Bool
True
            Outcome SimpleTx
_ -> Bool
False

          -- 3. A new ReqTx arrives — alice (leader for sn=2) can request a new
          -- snapshot because snapshotInFlight is now False after the reset
          let newTx :: SimpleTx
newTx = SimpleId -> SimpleTx
aValidTx SimpleId
42
              reqTx :: Input SimpleTx
reqTx = Message SimpleTx -> Input SimpleTx
forall tx. Message tx -> Input tx
receiveMessage (Message SimpleTx -> Input SimpleTx)
-> Message SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ SimpleTx -> Message SimpleTx
forall tx. tx -> Message tx
ReqTx SimpleTx
newTx
          NodeState SimpleTx
s2 <- Environment
-> Ledger SimpleTx
-> NodeState SimpleTx
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall (m :: * -> *) tx a.
Monad m =>
Environment
-> Ledger tx -> NodeState tx -> StateT (StepState tx) m a -> m a
runHeadLogic Environment
aliceEnv Ledger SimpleTx
ledger NodeState SimpleTx
s1 (StateT (StepState SimpleTx) IO (NodeState SimpleTx)
 -> IO (NodeState SimpleTx))
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall a b. (a -> b) -> a -> b
$ do
            Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step Input SimpleTx
reqTx
            StateT (StepState SimpleTx) IO (NodeState SimpleTx)
forall tx (m :: * -> *).
MonadState (StepState tx) m =>
m (NodeState tx)
getState

          -- Verify the head is not stuck: seenSnapshot should have advanced
          -- (snapshot number will be based on confirmedSnapshot.number, not lastSeen)
          case NodeState SimpleTx
s2 of
            NodeInSync{$sel:headState:NodeInSync :: forall tx. NodeState tx -> HeadState tx
headState = Open OpenState{$sel:coordinatedHeadState:OpenState :: forall tx. OpenState tx -> CoordinatedHeadState tx
coordinatedHeadState = CoordinatedHeadState SimpleTx
chs}} ->
              CoordinatedHeadState SimpleTx
chs.seenSnapshot SeenSnapshot SimpleTx -> (SeenSnapshot SimpleTx -> Bool) -> IO ()
forall a. (HasCallStack, Show a) => a -> (a -> Bool) -> IO ()
`shouldSatisfy` \case
                RequestedSnapshot{} -> Bool
True
                SeenSnapshot SimpleTx
_ -> Bool
False
            NodeState SimpleTx
_ -> String -> IO ()
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"expected Open state"

        String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"DecommitFinalized with RequestedSnapshot resets seenSnapshot to confirmedSn" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
          let localUTxO :: UTxOType SimpleTx
localUTxO = [SimpleId] -> UTxOType SimpleTx
utxoRefs [SimpleId
1]
              confirmedSn :: ConfirmedSnapshot SimpleTx
confirmedSn =
                ConfirmedSnapshot
                  { $sel:snapshot:InitialSnapshot :: Snapshot SimpleTx
snapshot = SnapshotNumber
-> SnapshotVersion
-> [SimpleTx]
-> UTxOType SimpleTx
-> Snapshot SimpleTx
forall tx.
IsTx tx =>
SnapshotNumber
-> SnapshotVersion -> [tx] -> UTxOType tx -> Snapshot tx
testSnapshot SnapshotNumber
0 SnapshotVersion
3 [] Set SimpleTxOut
UTxOType SimpleTx
localUTxO
                  , $sel:signatures:InitialSnapshot :: MultiSignature (Snapshot SimpleTx)
signatures = [Signature (Snapshot SimpleTx)]
-> MultiSignature (Snapshot SimpleTx)
forall a. [Signature a] -> MultiSignature a
Crypto.aggregate []
                  }
              -- State: leader sent ReqSn(v=3, sn=1) with lastSeen=0
              s0 :: NodeState SimpleTx
s0 =
                [Party] -> CoordinatedHeadState SimpleTx -> NodeState SimpleTx
inOpenState' [Party]
threeParties (CoordinatedHeadState SimpleTx -> NodeState SimpleTx)
-> CoordinatedHeadState SimpleTx -> NodeState SimpleTx
forall a b. (a -> b) -> a -> b
$
                  CoordinatedHeadState SimpleTx
coordinatedHeadState
                    { localUTxO
                    , version = 3
                    , confirmedSnapshot = confirmedSn
                    , seenSnapshot = RequestedSnapshot{lastSeen = 0, requested = 1}
                    , decommitTx = Just (SimpleTx 10 mempty (utxoRef 99))
                    }

          -- DecommitFinalized arrives before AckSn messages
          let decrementObservation :: Input SimpleTx
decrementObservation = OnChainTx SimpleTx -> Input SimpleTx
observeTx (OnChainTx SimpleTx -> Input SimpleTx)
-> OnChainTx SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ OnDecrementTx{$sel:headId:OnInitTx :: HeadId
headId = HeadId
testHeadId, $sel:newVersion:OnInitTx :: SnapshotVersion
newVersion = SnapshotVersion
4, $sel:distributedUTxO:OnInitTx :: UTxOType SimpleTx
distributedUTxO = Set SimpleTxOut
UTxOType SimpleTx
forall a. Monoid a => a
mempty}
          UTCTime
now <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
s0.chainPointTime.currentSlot
          let decommitFinalizedOutcome :: Outcome SimpleTx
decommitFinalizedOutcome = Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
aliceEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
s0 Input SimpleTx
decrementObservation
          let s1 :: NodeState SimpleTx
s1 = NodeState SimpleTx -> Outcome SimpleTx -> NodeState SimpleTx
forall tx.
IsChainState tx =>
NodeState tx -> Outcome tx -> NodeState tx
aggregateState NodeState SimpleTx
s0 Outcome SimpleTx
decommitFinalizedOutcome

          -- Verify seenSnapshot resets to confirmedSn (0), regardless of requested (1)
          case NodeState SimpleTx
s1 of
            NodeInSync{$sel:headState:NodeInSync :: forall tx. NodeState tx -> HeadState tx
headState = Open OpenState{$sel:coordinatedHeadState:OpenState :: forall tx. OpenState tx -> CoordinatedHeadState tx
coordinatedHeadState = CoordinatedHeadState SimpleTx
chs}} -> do
              CoordinatedHeadState SimpleTx
chs.version SnapshotVersion -> SnapshotVersion -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` SnapshotVersion
4
              CoordinatedHeadState SimpleTx
chs.seenSnapshot SeenSnapshot SimpleTx -> SeenSnapshot SimpleTx -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` LastSeenSnapshot{$sel:lastSeen:NoSeenSnapshot :: SnapshotNumber
lastSeen = SnapshotNumber
0}
              CoordinatedHeadState SimpleTx
chs.decommitTx Maybe SimpleTx -> Maybe SimpleTx -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Maybe SimpleTx
forall a. Maybe a
Nothing
            NodeState SimpleTx
_ -> String -> IO ()
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"expected Open state"

        String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"AckSn for decommit snapshot is noop after DecommitFinalized" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
          let localUTxO :: UTxOType SimpleTx
localUTxO = [SimpleId] -> UTxOType SimpleTx
utxoRefs [SimpleId
1]
              snapshot1 :: Snapshot SimpleTx
snapshot1 = SnapshotNumber
-> SnapshotVersion
-> [SimpleTx]
-> UTxOType SimpleTx
-> Snapshot SimpleTx
forall tx.
IsTx tx =>
SnapshotNumber
-> SnapshotVersion -> [tx] -> UTxOType tx -> Snapshot tx
testSnapshot SnapshotNumber
0 SnapshotVersion
4 [] Set SimpleTxOut
UTxOType SimpleTx
localUTxO Snapshot SimpleTx
-> (Snapshot SimpleTx -> Snapshot SimpleTx) -> Snapshot SimpleTx
forall a b. a -> (a -> b) -> b
& \Snapshot SimpleTx
s -> Snapshot SimpleTx
s{number = 1}
              confirmedSn :: ConfirmedSnapshot SimpleTx
confirmedSn =
                ConfirmedSnapshot
                  { $sel:snapshot:InitialSnapshot :: Snapshot SimpleTx
snapshot = SnapshotNumber
-> SnapshotVersion
-> [SimpleTx]
-> UTxOType SimpleTx
-> Snapshot SimpleTx
forall tx.
IsTx tx =>
SnapshotNumber
-> SnapshotVersion -> [tx] -> UTxOType tx -> Snapshot tx
testSnapshot SnapshotNumber
0 SnapshotVersion
3 [] Set SimpleTxOut
UTxOType SimpleTx
localUTxO
                  , $sel:signatures:InitialSnapshot :: MultiSignature (Snapshot SimpleTx)
signatures = [Signature (Snapshot SimpleTx)]
-> MultiSignature (Snapshot SimpleTx)
forall a. [Signature a] -> MultiSignature a
Crypto.aggregate []
                  }
              -- State after DecommitFinalized: lastSeen=1
              s0 :: NodeState SimpleTx
s0 =
                [Party] -> CoordinatedHeadState SimpleTx -> NodeState SimpleTx
inOpenState' [Party]
threeParties (CoordinatedHeadState SimpleTx -> NodeState SimpleTx)
-> CoordinatedHeadState SimpleTx -> NodeState SimpleTx
forall a b. (a -> b) -> a -> b
$
                  CoordinatedHeadState SimpleTx
coordinatedHeadState
                    { localUTxO
                    , version = 4
                    , confirmedSnapshot = confirmedSn
                    , seenSnapshot = LastSeenSnapshot{lastSeen = 1}
                    , decommitTx = Nothing
                    }

          -- AckSn for snapshot 1 arrives late
          let ackSn :: Message SimpleTx
ackSn = Signature (Snapshot SimpleTx) -> SnapshotNumber -> Message SimpleTx
forall tx. Signature (Snapshot tx) -> SnapshotNumber -> Message tx
AckSn (Secret (SigningKey HydraKey)
-> Snapshot SimpleTx -> Signature (Snapshot SimpleTx)
forall a.
SignableRepresentation a =>
Secret (SigningKey HydraKey) -> a -> Signature a
sign Secret (SigningKey HydraKey)
aliceSk Snapshot SimpleTx
snapshot1) SnapshotNumber
1
              input :: Input SimpleTx
input = Party -> Message SimpleTx -> Input SimpleTx
forall tx. Party -> Message tx -> Input tx
receiveMessageFrom Party
alice Message SimpleTx
ackSn
          UTCTime
now <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
s0.chainPointTime.currentSlot

          -- Should be noop (or error), not Wait
          Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
aliceEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
s0 Input SimpleTx
input Outcome SimpleTx -> (Outcome SimpleTx -> Bool) -> IO ()
forall a. (HasCallStack, Show a) => a -> (a -> Bool) -> IO ()
`shouldSatisfy` \case
            Continue{} -> Bool
True
            Error{} -> Bool
True
            Wait{} -> Bool
False -- Must NOT Wait (infinite AckSn requeue)
        String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"DecommitFinalized with SeenSnapshot preserves seenSnapshot so AckSns can still be collected" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
          let localUTxO :: UTxOType SimpleTx
localUTxO = [SimpleId] -> UTxOType SimpleTx
utxoRefs [SimpleId
1]
              decommitTx :: SimpleTx
decommitTx = SimpleId -> UTxOType SimpleTx -> UTxOType SimpleTx -> SimpleTx
SimpleTx SimpleId
10 Set SimpleTxOut
UTxOType SimpleTx
forall a. Monoid a => a
mempty (SimpleId -> UTxOType SimpleTx
utxoRef SimpleId
99)
              snapshot1 :: Snapshot SimpleTx
snapshot1 = SnapshotNumber
-> SnapshotVersion
-> [SimpleTx]
-> UTxOType SimpleTx
-> Snapshot SimpleTx
forall tx.
IsTx tx =>
SnapshotNumber
-> SnapshotVersion -> [tx] -> UTxOType tx -> Snapshot tx
testSnapshot SnapshotNumber
0 SnapshotVersion
3 [] Set SimpleTxOut
UTxOType SimpleTx
localUTxO Snapshot SimpleTx
-> (Snapshot SimpleTx -> Snapshot SimpleTx) -> Snapshot SimpleTx
forall a b. a -> (a -> b) -> b
& \Snapshot SimpleTx
s -> Snapshot SimpleTx
s{number = 1}
              confirmedSn :: ConfirmedSnapshot SimpleTx
confirmedSn =
                ConfirmedSnapshot
                  { $sel:snapshot:InitialSnapshot :: Snapshot SimpleTx
snapshot = SnapshotNumber
-> SnapshotVersion
-> [SimpleTx]
-> UTxOType SimpleTx
-> Snapshot SimpleTx
forall tx.
IsTx tx =>
SnapshotNumber
-> SnapshotVersion -> [tx] -> UTxOType tx -> Snapshot tx
testSnapshot SnapshotNumber
0 SnapshotVersion
3 [] Set SimpleTxOut
UTxOType SimpleTx
localUTxO
                  , $sel:signatures:InitialSnapshot :: MultiSignature (Snapshot SimpleTx)
signatures = [Signature (Snapshot SimpleTx)]
-> MultiSignature (Snapshot SimpleTx)
forall a. [Signature a] -> MultiSignature a
Crypto.aggregate []
                  }
              -- State: follower has seen ReqSn and is collecting signatures
              s0 :: NodeState SimpleTx
s0 =
                [Party] -> CoordinatedHeadState SimpleTx -> NodeState SimpleTx
inOpenState' [Party]
threeParties (CoordinatedHeadState SimpleTx -> NodeState SimpleTx)
-> CoordinatedHeadState SimpleTx -> NodeState SimpleTx
forall a b. (a -> b) -> a -> b
$
                  CoordinatedHeadState SimpleTx
coordinatedHeadState
                    { localUTxO
                    , version = 3
                    , confirmedSnapshot = confirmedSn
                    , seenSnapshot = mkSeenSnapshot snapshot1 mempty
                    , decommitTx = Just decommitTx
                    }

          -- DecommitFinalized arrives while collecting signatures
          let decrementObservation :: Input SimpleTx
decrementObservation = OnChainTx SimpleTx -> Input SimpleTx
observeTx (OnChainTx SimpleTx -> Input SimpleTx)
-> OnChainTx SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ OnDecrementTx{$sel:headId:OnInitTx :: HeadId
headId = HeadId
testHeadId, $sel:newVersion:OnInitTx :: SnapshotVersion
newVersion = SnapshotVersion
4, $sel:distributedUTxO:OnInitTx :: UTxOType SimpleTx
distributedUTxO = Set SimpleTxOut
UTxOType SimpleTx
forall a. Monoid a => a
mempty}
          UTCTime
now <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
s0.chainPointTime.currentSlot
          let decommitFinalizedOutcome :: Outcome SimpleTx
decommitFinalizedOutcome = Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
s0 Input SimpleTx
decrementObservation
          let s1 :: NodeState SimpleTx
s1 = NodeState SimpleTx -> Outcome SimpleTx -> NodeState SimpleTx
forall tx.
IsChainState tx =>
NodeState tx -> Outcome tx -> NodeState tx
aggregateState NodeState SimpleTx
s0 Outcome SimpleTx
decommitFinalizedOutcome

          -- DecommitFinalized preserves SeenSnapshot so AckSns can still be collected.
          -- seenSnapshot stays as SeenSnapshot (not reset to LastSeenSnapshot).
          case NodeState SimpleTx
s1 of
            NodeInSync{$sel:headState:NodeInSync :: forall tx. NodeState tx -> HeadState tx
headState = Open OpenState{$sel:coordinatedHeadState:OpenState :: forall tx. OpenState tx -> CoordinatedHeadState tx
coordinatedHeadState = CoordinatedHeadState SimpleTx
chs}} -> do
              CoordinatedHeadState SimpleTx
chs.version SnapshotVersion -> SnapshotVersion -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` SnapshotVersion
4
              CoordinatedHeadState SimpleTx
chs.decommitTx Maybe SimpleTx -> Maybe SimpleTx -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Maybe SimpleTx
forall a. Maybe a
Nothing
              CoordinatedHeadState SimpleTx
chs.seenSnapshot SeenSnapshot SimpleTx -> SeenSnapshot SimpleTx -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Snapshot SimpleTx
-> Map Party (Signature (Snapshot SimpleTx))
-> SeenSnapshot SimpleTx
forall tx.
IsTx tx =>
Snapshot tx
-> Map Party (Signature (Snapshot tx)) -> SeenSnapshot tx
mkSeenSnapshot Snapshot SimpleTx
snapshot1 Map Party (Signature (Snapshot SimpleTx))
forall a. Monoid a => a
mempty
            NodeState SimpleTx
_ -> String -> IO ()
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"expected Open state"

        String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"DecommitFinalized with SeenSnapshot does not re-request snapshot already in-flight" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
          let localUTxO :: UTxOType SimpleTx
localUTxO = [SimpleId] -> UTxOType SimpleTx
utxoRefs [SimpleId
1]
              decommitTx :: SimpleTx
decommitTx = SimpleId -> UTxOType SimpleTx -> UTxOType SimpleTx -> SimpleTx
SimpleTx SimpleId
10 Set SimpleTxOut
UTxOType SimpleTx
forall a. Monoid a => a
mempty (SimpleId -> UTxOType SimpleTx
utxoRef SimpleId
99)
              snapshot1 :: Snapshot SimpleTx
snapshot1 = SnapshotNumber
-> SnapshotVersion
-> [SimpleTx]
-> UTxOType SimpleTx
-> Snapshot SimpleTx
forall tx.
IsTx tx =>
SnapshotNumber
-> SnapshotVersion -> [tx] -> UTxOType tx -> Snapshot tx
testSnapshot SnapshotNumber
0 SnapshotVersion
3 [] Set SimpleTxOut
UTxOType SimpleTx
localUTxO Snapshot SimpleTx
-> (Snapshot SimpleTx -> Snapshot SimpleTx) -> Snapshot SimpleTx
forall a b. a -> (a -> b) -> b
& \Snapshot SimpleTx
s -> Snapshot SimpleTx
s{number = 1}
              confirmedSn :: ConfirmedSnapshot SimpleTx
confirmedSn =
                ConfirmedSnapshot
                  { $sel:snapshot:InitialSnapshot :: Snapshot SimpleTx
snapshot = SnapshotNumber
-> SnapshotVersion
-> [SimpleTx]
-> UTxOType SimpleTx
-> Snapshot SimpleTx
forall tx.
IsTx tx =>
SnapshotNumber
-> SnapshotVersion -> [tx] -> UTxOType tx -> Snapshot tx
testSnapshot SnapshotNumber
0 SnapshotVersion
3 [] Set SimpleTxOut
UTxOType SimpleTx
localUTxO
                  , $sel:signatures:InitialSnapshot :: MultiSignature (Snapshot SimpleTx)
signatures = [Signature (Snapshot SimpleTx)]
-> MultiSignature (Snapshot SimpleTx)
forall a. [Signature a] -> MultiSignature a
Crypto.aggregate []
                  }
              s0 :: NodeState SimpleTx
s0 =
                [Party] -> CoordinatedHeadState SimpleTx -> NodeState SimpleTx
inOpenState' [Party]
threeParties (CoordinatedHeadState SimpleTx -> NodeState SimpleTx)
-> CoordinatedHeadState SimpleTx -> NodeState SimpleTx
forall a b. (a -> b) -> a -> b
$
                  CoordinatedHeadState SimpleTx
coordinatedHeadState
                    { localUTxO
                    , version = 3
                    , confirmedSnapshot = confirmedSn
                    , seenSnapshot = mkSeenSnapshot snapshot1 mempty
                    , decommitTx = Just decommitTx
                    }

          let decrementObservation :: Input SimpleTx
decrementObservation = OnChainTx SimpleTx -> Input SimpleTx
observeTx (OnChainTx SimpleTx -> Input SimpleTx)
-> OnChainTx SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ OnDecrementTx{$sel:headId:OnInitTx :: HeadId
headId = HeadId
testHeadId, $sel:newVersion:OnInitTx :: SnapshotVersion
newVersion = SnapshotVersion
4, $sel:distributedUTxO:OnInitTx :: UTxOType SimpleTx
distributedUTxO = Set SimpleTxOut
UTxOType SimpleTx
forall a. Monoid a => a
mempty}
          UTCTime
now <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
s0.chainPointTime.currentSlot
          let outcome :: Outcome SimpleTx
outcome = Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
aliceEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
s0 Input SimpleTx
decrementObservation

          -- No new snapshot should be requested: the one in SeenSnapshot will complete
          Outcome SimpleTx
outcome Outcome SimpleTx -> (StateChanged SimpleTx -> Bool) -> IO ()
forall tx.
(HasCallStack, IsChainState tx) =>
Outcome tx -> (StateChanged tx -> Bool) -> IO ()
`hasNoStateChangedSatisfying` \case
            SnapshotRequestDecided{} -> Bool
True
            StateChanged SimpleTx
_ -> Bool
False

          -- seenSnapshot must be preserved so AckSns can still be collected
          let s1 :: NodeState SimpleTx
s1 = NodeState SimpleTx -> Outcome SimpleTx -> NodeState SimpleTx
forall tx.
IsChainState tx =>
NodeState tx -> Outcome tx -> NodeState tx
aggregateState NodeState SimpleTx
s0 Outcome SimpleTx
outcome
          case NodeState SimpleTx
s1 of
            NodeInSync{$sel:headState:NodeInSync :: forall tx. NodeState tx -> HeadState tx
headState = Open OpenState{$sel:coordinatedHeadState:OpenState :: forall tx. OpenState tx -> CoordinatedHeadState tx
coordinatedHeadState = CoordinatedHeadState SimpleTx
chs}} ->
              CoordinatedHeadState SimpleTx
chs.seenSnapshot SeenSnapshot SimpleTx -> SeenSnapshot SimpleTx -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Snapshot SimpleTx
-> Map Party (Signature (Snapshot SimpleTx))
-> SeenSnapshot SimpleTx
forall tx.
IsTx tx =>
Snapshot tx
-> Map Party (Signature (Snapshot tx)) -> SeenSnapshot tx
mkSeenSnapshot Snapshot SimpleTx
snapshot1 Map Party (Signature (Snapshot SimpleTx))
forall a. Monoid a => a
mempty
            NodeState SimpleTx
_ -> String -> IO ()
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"expected Open state"

        String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"CommitFinalized with SeenSnapshot does not re-request snapshot already in-flight" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
          let localUTxO :: UTxOType SimpleTx
localUTxO = [SimpleId] -> UTxOType SimpleTx
utxoRefs [SimpleId
1]
              snapshot1 :: Snapshot SimpleTx
snapshot1 = SnapshotNumber
-> SnapshotVersion
-> [SimpleTx]
-> UTxOType SimpleTx
-> Snapshot SimpleTx
forall tx.
IsTx tx =>
SnapshotNumber
-> SnapshotVersion -> [tx] -> UTxOType tx -> Snapshot tx
testSnapshot SnapshotNumber
0 SnapshotVersion
3 [] Set SimpleTxOut
UTxOType SimpleTx
localUTxO Snapshot SimpleTx
-> (Snapshot SimpleTx -> Snapshot SimpleTx) -> Snapshot SimpleTx
forall a b. a -> (a -> b) -> b
& \Snapshot SimpleTx
s -> Snapshot SimpleTx
s{number = 1}
              confirmedSn :: ConfirmedSnapshot SimpleTx
confirmedSn =
                ConfirmedSnapshot
                  { $sel:snapshot:InitialSnapshot :: Snapshot SimpleTx
snapshot = SnapshotNumber
-> SnapshotVersion
-> [SimpleTx]
-> UTxOType SimpleTx
-> Snapshot SimpleTx
forall tx.
IsTx tx =>
SnapshotNumber
-> SnapshotVersion -> [tx] -> UTxOType tx -> Snapshot tx
testSnapshot SnapshotNumber
0 SnapshotVersion
3 [] Set SimpleTxOut
UTxOType SimpleTx
localUTxO
                  , $sel:signatures:InitialSnapshot :: MultiSignature (Snapshot SimpleTx)
signatures = [Signature (Snapshot SimpleTx)]
-> MultiSignature (Snapshot SimpleTx)
forall a. [Signature a] -> MultiSignature a
Crypto.aggregate []
                  }
              depositTxId :: SimpleId
depositTxId = SimpleId
42
              s0 :: NodeState SimpleTx
s0 =
                [Party] -> CoordinatedHeadState SimpleTx -> NodeState SimpleTx
inOpenState' [Party]
threeParties (CoordinatedHeadState SimpleTx -> NodeState SimpleTx)
-> CoordinatedHeadState SimpleTx -> NodeState SimpleTx
forall a b. (a -> b) -> a -> b
$
                  CoordinatedHeadState SimpleTx
coordinatedHeadState
                    { localUTxO
                    , version = 3
                    , confirmedSnapshot = confirmedSn
                    , seenSnapshot = mkSeenSnapshot snapshot1 mempty
                    , currentDepositTxId = Just depositTxId
                    }

          let incrementObservation :: Input SimpleTx
incrementObservation = OnChainTx SimpleTx -> Input SimpleTx
observeTx (OnChainTx SimpleTx -> Input SimpleTx)
-> OnChainTx SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ OnIncrementTx{$sel:headId:OnInitTx :: HeadId
headId = HeadId
testHeadId, $sel:newVersion:OnInitTx :: SnapshotVersion
newVersion = SnapshotVersion
4, SimpleId
TxIdType SimpleTx
$sel:depositTxId:OnInitTx :: TxIdType SimpleTx
depositTxId :: SimpleId
depositTxId}
          UTCTime
now <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
s0.chainPointTime.currentSlot
          let outcome :: Outcome SimpleTx
outcome = Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
aliceEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
s0 Input SimpleTx
incrementObservation

          -- No new snapshot should be requested: the one in SeenSnapshot will complete
          Outcome SimpleTx
outcome Outcome SimpleTx -> (StateChanged SimpleTx -> Bool) -> IO ()
forall tx.
(HasCallStack, IsChainState tx) =>
Outcome tx -> (StateChanged tx -> Bool) -> IO ()
`hasNoStateChangedSatisfying` \case
            SnapshotRequestDecided{} -> Bool
True
            StateChanged SimpleTx
_ -> Bool
False

          -- seenSnapshot must be preserved so AckSns can still be collected
          let s1 :: NodeState SimpleTx
s1 = NodeState SimpleTx -> Outcome SimpleTx -> NodeState SimpleTx
forall tx.
IsChainState tx =>
NodeState tx -> Outcome tx -> NodeState tx
aggregateState NodeState SimpleTx
s0 Outcome SimpleTx
outcome
          case NodeState SimpleTx
s1 of
            NodeInSync{$sel:headState:NodeInSync :: forall tx. NodeState tx -> HeadState tx
headState = Open OpenState{$sel:coordinatedHeadState:OpenState :: forall tx. OpenState tx -> CoordinatedHeadState tx
coordinatedHeadState = CoordinatedHeadState SimpleTx
chs}} ->
              CoordinatedHeadState SimpleTx
chs.seenSnapshot SeenSnapshot SimpleTx -> SeenSnapshot SimpleTx -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Snapshot SimpleTx
-> Map Party (Signature (Snapshot SimpleTx))
-> SeenSnapshot SimpleTx
forall tx.
IsTx tx =>
Snapshot tx
-> Map Party (Signature (Snapshot tx)) -> SeenSnapshot tx
mkSeenSnapshot Snapshot SimpleTx
snapshot1 Map Party (Signature (Snapshot SimpleTx))
forall a. Monoid a => a
mempty
            NodeState SimpleTx
_ -> String -> IO ()
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"expected Open state"

        String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"CommitFinalized with RequestedSnapshot resets seenSnapshot to confirmedSn" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
          let localUTxO :: UTxOType SimpleTx
localUTxO = [SimpleId] -> UTxOType SimpleTx
utxoRefs [SimpleId
1]
              confirmedSn :: ConfirmedSnapshot SimpleTx
confirmedSn =
                ConfirmedSnapshot
                  { $sel:snapshot:InitialSnapshot :: Snapshot SimpleTx
snapshot = SnapshotNumber
-> SnapshotVersion
-> [SimpleTx]
-> UTxOType SimpleTx
-> Snapshot SimpleTx
forall tx.
IsTx tx =>
SnapshotNumber
-> SnapshotVersion -> [tx] -> UTxOType tx -> Snapshot tx
testSnapshot SnapshotNumber
0 SnapshotVersion
3 [] Set SimpleTxOut
UTxOType SimpleTx
localUTxO
                  , $sel:signatures:InitialSnapshot :: MultiSignature (Snapshot SimpleTx)
signatures = [Signature (Snapshot SimpleTx)]
-> MultiSignature (Snapshot SimpleTx)
forall a. [Signature a] -> MultiSignature a
Crypto.aggregate []
                  }
              depositTxId :: SimpleId
depositTxId = SimpleId
42
              -- State after leader sent ReqSn(sn=1) with pending deposit: snapshot in flight
              s0 :: NodeState SimpleTx
s0 =
                [Party] -> CoordinatedHeadState SimpleTx -> NodeState SimpleTx
inOpenState' [Party]
threeParties (CoordinatedHeadState SimpleTx -> NodeState SimpleTx)
-> CoordinatedHeadState SimpleTx -> NodeState SimpleTx
forall a b. (a -> b) -> a -> b
$
                  CoordinatedHeadState SimpleTx
coordinatedHeadState
                    { localUTxO
                    , version = 3
                    , confirmedSnapshot = confirmedSn
                    , seenSnapshot = RequestedSnapshot{lastSeen = 0, requested = 1}
                    , currentDepositTxId = Just depositTxId
                    }

          -- CommitFinalized arrives before AckSn messages (race condition)
          let incrementObservation :: Input SimpleTx
incrementObservation = OnChainTx SimpleTx -> Input SimpleTx
observeTx (OnChainTx SimpleTx -> Input SimpleTx)
-> OnChainTx SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ OnIncrementTx{$sel:headId:OnInitTx :: HeadId
headId = HeadId
testHeadId, $sel:newVersion:OnInitTx :: SnapshotVersion
newVersion = SnapshotVersion
4, SimpleId
TxIdType SimpleTx
$sel:depositTxId:OnInitTx :: TxIdType SimpleTx
depositTxId :: SimpleId
depositTxId}
          UTCTime
now <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
s0.chainPointTime.currentSlot
          let commitFinalizedOutcome :: Outcome SimpleTx
commitFinalizedOutcome = Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
aliceEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
s0 Input SimpleTx
incrementObservation
          let s1 :: NodeState SimpleTx
s1 = NodeState SimpleTx -> Outcome SimpleTx -> NodeState SimpleTx
forall tx.
IsChainState tx =>
NodeState tx -> Outcome tx -> NodeState tx
aggregateState NodeState SimpleTx
s0 Outcome SimpleTx
commitFinalizedOutcome

          -- seenSnapshot resets to confirmedSn (0), not requested (1)
          case NodeState SimpleTx
s1 of
            NodeInSync{$sel:headState:NodeInSync :: forall tx. NodeState tx -> HeadState tx
headState = Open OpenState{$sel:coordinatedHeadState:OpenState :: forall tx. OpenState tx -> CoordinatedHeadState tx
coordinatedHeadState = CoordinatedHeadState SimpleTx
chs}} -> do
              CoordinatedHeadState SimpleTx
chs.version SnapshotVersion -> SnapshotVersion -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` SnapshotVersion
4
              CoordinatedHeadState SimpleTx
chs.currentDepositTxId Maybe (TxIdType SimpleTx) -> Maybe (TxIdType SimpleTx) -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Maybe (TxIdType SimpleTx)
forall a. Maybe a
Nothing
              CoordinatedHeadState SimpleTx
chs.seenSnapshot SeenSnapshot SimpleTx -> SeenSnapshot SimpleTx -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` LastSeenSnapshot{$sel:lastSeen:NoSeenSnapshot :: SnapshotNumber
lastSeen = SnapshotNumber
0}
            NodeState SimpleTx
_ -> String -> IO ()
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"expected Open state"

      String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Tracks Transaction Ids" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
        String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"keeps transactions in allTxs given it receives a ReqTx" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
          let s0 :: NodeState SimpleTx
s0 = [Party] -> NodeState SimpleTx
inOpenState [Party]
threeParties
              t1 :: SimpleTx
t1 = SimpleId -> UTxOType SimpleTx -> UTxOType SimpleTx -> SimpleTx
SimpleTx SimpleId
1 Set SimpleTxOut
UTxOType SimpleTx
forall a. Monoid a => a
mempty (SimpleId -> UTxOType SimpleTx
utxoRef SimpleId
1)

          NodeState SimpleTx
sa <- Environment
-> Ledger SimpleTx
-> NodeState SimpleTx
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall (m :: * -> *) tx a.
Monad m =>
Environment
-> Ledger tx -> NodeState tx -> StateT (StepState tx) m a -> m a
runHeadLogic Environment
bobEnv Ledger SimpleTx
ledger NodeState SimpleTx
s0 (StateT (StepState SimpleTx) IO (NodeState SimpleTx)
 -> IO (NodeState SimpleTx))
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall a b. (a -> b) -> a -> b
$ do
            Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step (Input SimpleTx
 -> StateT (StepState SimpleTx) IO (Outcome SimpleTx))
-> Input SimpleTx
-> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall a b. (a -> b) -> a -> b
$ Message SimpleTx -> Input SimpleTx
forall tx. Message tx -> Input tx
receiveMessage (Message SimpleTx -> Input SimpleTx)
-> Message SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ SimpleTx -> Message SimpleTx
forall tx. tx -> Message tx
ReqTx SimpleTx
t1
            StateT (StepState SimpleTx) IO (NodeState SimpleTx)
forall tx (m :: * -> *).
MonadState (StepState tx) m =>
m (NodeState tx)
getState

          NodeState SimpleTx -> HeadState SimpleTx
forall tx. NodeState tx -> HeadState tx
headState NodeState SimpleTx
sa HeadState SimpleTx -> (HeadState SimpleTx -> Bool) -> IO ()
forall a. (HasCallStack, Show a) => a -> (a -> Bool) -> IO ()
`shouldSatisfy` \case
            (Open OpenState{$sel:coordinatedHeadState:OpenState :: forall tx. OpenState tx -> CoordinatedHeadState tx
coordinatedHeadState = CoordinatedHeadState{Map (TxIdType SimpleTx) SimpleTx
$sel:allTxs:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> Map (TxIdType tx) tx
allTxs :: Map (TxIdType SimpleTx) SimpleTx
allTxs}}) -> SimpleTx -> TxIdType SimpleTx
forall tx. IsTx tx => tx -> TxIdType tx
txId SimpleTx
t1 Key (Map (TxIdType SimpleTx) SimpleTx)
-> Map (TxIdType SimpleTx) SimpleTx -> Bool
forall t. StaticMap t => Key t -> t -> Bool
`member` Map (TxIdType SimpleTx) SimpleTx
allTxs
            HeadState SimpleTx
_ -> Bool
False

        String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"removes transactions in allTxs given it receives a ReqSn" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
          let s0 :: NodeState SimpleTx
s0 = [Party] -> NodeState SimpleTx
inOpenState [Party]
threeParties
              t1 :: SimpleTx
t1 = SimpleId -> UTxOType SimpleTx -> UTxOType SimpleTx -> SimpleTx
SimpleTx SimpleId
1 Set SimpleTxOut
UTxOType SimpleTx
forall a. Monoid a => a
mempty (SimpleId -> UTxOType SimpleTx
utxoRef SimpleId
1)
              reqSn :: Input SimpleTx
reqSn = Message SimpleTx -> Input SimpleTx
forall tx. Message tx -> Input tx
receiveMessage (Message SimpleTx -> Input SimpleTx)
-> Message SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ SnapshotVersion
-> SnapshotNumber
-> [TxIdType SimpleTx]
-> Maybe SimpleTx
-> Maybe (TxIdType SimpleTx)
-> Message SimpleTx
forall tx.
SnapshotVersion
-> SnapshotNumber
-> [TxIdType tx]
-> Maybe tx
-> Maybe (TxIdType tx)
-> Message tx
ReqSn SnapshotVersion
0 SnapshotNumber
1 [TxIdType SimpleTx
1] Maybe SimpleTx
forall a. Maybe a
Nothing Maybe (TxIdType SimpleTx)
forall a. Maybe a
Nothing

          NodeState SimpleTx
s1 <- Environment
-> Ledger SimpleTx
-> NodeState SimpleTx
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall (m :: * -> *) tx a.
Monad m =>
Environment
-> Ledger tx -> NodeState tx -> StateT (StepState tx) m a -> m a
runHeadLogic Environment
bobEnv Ledger SimpleTx
ledger NodeState SimpleTx
s0 (StateT (StepState SimpleTx) IO (NodeState SimpleTx)
 -> IO (NodeState SimpleTx))
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall a b. (a -> b) -> a -> b
$ do
            Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step (Input SimpleTx
 -> StateT (StepState SimpleTx) IO (Outcome SimpleTx))
-> Input SimpleTx
-> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall a b. (a -> b) -> a -> b
$ Message SimpleTx -> Input SimpleTx
forall tx. Message tx -> Input tx
receiveMessage (Message SimpleTx -> Input SimpleTx)
-> Message SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ SimpleTx -> Message SimpleTx
forall tx. tx -> Message tx
ReqTx SimpleTx
t1
            Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step Input SimpleTx
reqSn
            StateT (StepState SimpleTx) IO (NodeState SimpleTx)
forall tx (m :: * -> *).
MonadState (StepState tx) m =>
m (NodeState tx)
getState

          NodeState SimpleTx -> HeadState SimpleTx
forall tx. NodeState tx -> HeadState tx
headState NodeState SimpleTx
s1 HeadState SimpleTx -> (HeadState SimpleTx -> Bool) -> IO ()
forall a. (HasCallStack, Show a) => a -> (a -> Bool) -> IO ()
`shouldSatisfy` \case
            (Open OpenState{$sel:coordinatedHeadState:OpenState :: forall tx. OpenState tx -> CoordinatedHeadState tx
coordinatedHeadState = CoordinatedHeadState{Map (TxIdType SimpleTx) SimpleTx
$sel:allTxs:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> Map (TxIdType tx) tx
allTxs :: Map (TxIdType SimpleTx) SimpleTx
allTxs}}) -> SimpleTx -> TxIdType SimpleTx
forall tx. IsTx tx => tx -> TxIdType tx
txId SimpleTx
t1 SimpleId -> Map SimpleId SimpleTx -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`notMember` Map SimpleId SimpleTx
Map (TxIdType SimpleTx) SimpleTx
allTxs
            HeadState SimpleTx
_ -> Bool
False

        String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"removes transactions from allTxs when included in a acked snapshot even when emitting a ReqSn" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
          let t1 :: SimpleTx
t1 = SimpleId -> UTxOType SimpleTx -> UTxOType SimpleTx -> SimpleTx
SimpleTx SimpleId
1 Set SimpleTxOut
UTxOType SimpleTx
forall a. Monoid a => a
mempty (SimpleId -> UTxOType SimpleTx
utxoRef SimpleId
1)
              pendingTransaction :: SimpleTx
pendingTransaction = SimpleId -> UTxOType SimpleTx -> UTxOType SimpleTx -> SimpleTx
SimpleTx SimpleId
2 Set SimpleTxOut
UTxOType SimpleTx
forall a. Monoid a => a
mempty (SimpleId -> UTxOType SimpleTx
utxoRef SimpleId
2)
              reqSn :: Input SimpleTx
reqSn = Message SimpleTx -> Input SimpleTx
forall tx. Message tx -> Input tx
receiveMessage (Message SimpleTx -> Input SimpleTx)
-> Message SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ SnapshotVersion
-> SnapshotNumber
-> [TxIdType SimpleTx]
-> Maybe SimpleTx
-> Maybe (TxIdType SimpleTx)
-> Message SimpleTx
forall tx.
SnapshotVersion
-> SnapshotNumber
-> [TxIdType tx]
-> Maybe tx
-> Maybe (TxIdType tx)
-> Message tx
ReqSn SnapshotVersion
0 SnapshotNumber
1 [TxIdType SimpleTx
1] Maybe SimpleTx
forall a. Maybe a
Nothing Maybe (TxIdType SimpleTx)
forall a. Maybe a
Nothing
              snapshot1 :: Snapshot SimpleTx
snapshot1 = SnapshotNumber
-> SnapshotVersion
-> [SimpleTx]
-> UTxOType SimpleTx
-> Snapshot SimpleTx
forall tx.
IsTx tx =>
SnapshotNumber
-> SnapshotVersion -> [tx] -> UTxOType tx -> Snapshot tx
testSnapshot SnapshotNumber
1 SnapshotVersion
0 [SimpleTx
t1] ([SimpleId] -> UTxOType SimpleTx
utxoRefs [SimpleId
1])
              ackFrom :: Secret (SigningKey HydraKey) -> Party -> Input SimpleTx
ackFrom Secret (SigningKey HydraKey)
sk Party
vk = Party -> Message SimpleTx -> Input SimpleTx
forall tx. Party -> Message tx -> Input tx
receiveMessageFrom Party
vk (Message SimpleTx -> Input SimpleTx)
-> Message SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ Signature (Snapshot SimpleTx) -> SnapshotNumber -> Message SimpleTx
forall tx. Signature (Snapshot tx) -> SnapshotNumber -> Message tx
AckSn (Secret (SigningKey HydraKey)
-> Snapshot SimpleTx -> Signature (Snapshot SimpleTx)
forall a.
SignableRepresentation a =>
Secret (SigningKey HydraKey) -> a -> Signature a
sign Secret (SigningKey HydraKey)
sk Snapshot SimpleTx
snapshot1) SnapshotNumber
1

          NodeState SimpleTx
sa <- Environment
-> Ledger SimpleTx
-> NodeState SimpleTx
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall (m :: * -> *) tx a.
Monad m =>
Environment
-> Ledger tx -> NodeState tx -> StateT (StepState tx) m a -> m a
runHeadLogic Environment
bobEnv Ledger SimpleTx
ledger ([Party] -> NodeState SimpleTx
inOpenState [Party]
threeParties) (StateT (StepState SimpleTx) IO (NodeState SimpleTx)
 -> IO (NodeState SimpleTx))
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall a b. (a -> b) -> a -> b
$ do
            Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step (Input SimpleTx
 -> StateT (StepState SimpleTx) IO (Outcome SimpleTx))
-> Input SimpleTx
-> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall a b. (a -> b) -> a -> b
$ Message SimpleTx -> Input SimpleTx
forall tx. Message tx -> Input tx
receiveMessage (Message SimpleTx -> Input SimpleTx)
-> Message SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ SimpleTx -> Message SimpleTx
forall tx. tx -> Message tx
ReqTx SimpleTx
t1
            Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step Input SimpleTx
reqSn
            Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step (Secret (SigningKey HydraKey) -> Party -> Input SimpleTx
ackFrom Secret (SigningKey HydraKey)
carolSk Party
carol)
            Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step (Secret (SigningKey HydraKey) -> Party -> Input SimpleTx
ackFrom Secret (SigningKey HydraKey)
aliceSk Party
alice)

            Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step (Input SimpleTx
 -> StateT (StepState SimpleTx) IO (Outcome SimpleTx))
-> Input SimpleTx
-> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall a b. (a -> b) -> a -> b
$ Message SimpleTx -> Input SimpleTx
forall tx. Message tx -> Input tx
receiveMessage (Message SimpleTx -> Input SimpleTx)
-> Message SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ SimpleTx -> Message SimpleTx
forall tx. tx -> Message tx
ReqTx SimpleTx
pendingTransaction

            Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step (Secret (SigningKey HydraKey) -> Party -> Input SimpleTx
ackFrom Secret (SigningKey HydraKey)
bobSk Party
bob)
            StateT (StepState SimpleTx) IO (NodeState SimpleTx)
forall tx (m :: * -> *).
MonadState (StepState tx) m =>
m (NodeState tx)
getState

          NodeState SimpleTx -> HeadState SimpleTx
forall tx. NodeState tx -> HeadState tx
headState NodeState SimpleTx
sa HeadState SimpleTx -> (HeadState SimpleTx -> Bool) -> IO ()
forall a. (HasCallStack, Show a) => a -> (a -> Bool) -> IO ()
`shouldSatisfy` \case
            (Open OpenState{$sel:coordinatedHeadState:OpenState :: forall tx. OpenState tx -> CoordinatedHeadState tx
coordinatedHeadState = CoordinatedHeadState{Map (TxIdType SimpleTx) SimpleTx
$sel:allTxs:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> Map (TxIdType tx) tx
allTxs :: Map (TxIdType SimpleTx) SimpleTx
allTxs}}) -> SimpleTx -> TxIdType SimpleTx
forall tx. IsTx tx => tx -> TxIdType tx
txId SimpleTx
t1 SimpleId -> Map SimpleId SimpleTx -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`notMember` Map SimpleId SimpleTx
Map (TxIdType SimpleTx) SimpleTx
allTxs
            HeadState SimpleTx
_ -> Bool
False

      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"rejects last AckSn if one signature was from a different snapshot" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        let reqSn :: Input tx
            reqSn :: forall tx. Input tx
reqSn = Message tx -> Input tx
forall tx. Message tx -> Input tx
receiveMessage (Message tx -> Input tx) -> Message tx -> Input 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
0 SnapshotNumber
1 [] Maybe tx
forall a. Maybe a
Nothing Maybe (TxIdType tx)
forall a. Maybe a
Nothing
            snapshot :: Snapshot SimpleTx
snapshot = SnapshotNumber
-> SnapshotVersion
-> [SimpleTx]
-> UTxOType SimpleTx
-> Snapshot SimpleTx
forall tx.
IsTx tx =>
SnapshotNumber
-> SnapshotVersion -> [tx] -> UTxOType tx -> Snapshot tx
testSnapshot SnapshotNumber
1 SnapshotVersion
0 [] UTxOType SimpleTx
forall a. Monoid a => a
mempty
            snapshot' :: Snapshot SimpleTx
snapshot' = SnapshotNumber
-> SnapshotVersion
-> [SimpleTx]
-> UTxOType SimpleTx
-> Snapshot SimpleTx
forall tx.
IsTx tx =>
SnapshotNumber
-> SnapshotVersion -> [tx] -> UTxOType tx -> Snapshot tx
testSnapshot SnapshotNumber
2 SnapshotVersion
0 [] UTxOType SimpleTx
forall a. Monoid a => a
mempty
            ackFrom :: Secret (SigningKey HydraKey) -> Party -> Input SimpleTx
ackFrom Secret (SigningKey HydraKey)
sk Party
vk = Party -> Message SimpleTx -> Input SimpleTx
forall tx. Party -> Message tx -> Input tx
receiveMessageFrom Party
vk (Message SimpleTx -> Input SimpleTx)
-> Message SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ Signature (Snapshot SimpleTx) -> SnapshotNumber -> Message SimpleTx
forall tx. Signature (Snapshot tx) -> SnapshotNumber -> Message tx
AckSn (Secret (SigningKey HydraKey)
-> Snapshot SimpleTx -> Signature (Snapshot SimpleTx)
forall a.
SignableRepresentation a =>
Secret (SigningKey HydraKey) -> a -> Signature a
sign Secret (SigningKey HydraKey)
sk Snapshot SimpleTx
snapshot) SnapshotNumber
1
            invalidAckFrom :: Secret (SigningKey HydraKey) -> Party -> Input SimpleTx
invalidAckFrom Secret (SigningKey HydraKey)
sk Party
vk = Party -> Message SimpleTx -> Input SimpleTx
forall tx. Party -> Message tx -> Input tx
receiveMessageFrom Party
vk (Message SimpleTx -> Input SimpleTx)
-> Message SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ Signature (Snapshot SimpleTx) -> SnapshotNumber -> Message SimpleTx
forall tx. Signature (Snapshot tx) -> SnapshotNumber -> Message tx
AckSn (Secret (SigningKey HydraKey)
-> Snapshot SimpleTx -> Signature (Snapshot SimpleTx)
forall a.
SignableRepresentation a =>
Secret (SigningKey HydraKey) -> a -> Signature a
sign Secret (SigningKey HydraKey)
sk Snapshot SimpleTx
snapshot') SnapshotNumber
1
        NodeState SimpleTx
waitingForLastAck <-
          Environment
-> Ledger SimpleTx
-> NodeState SimpleTx
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall (m :: * -> *) tx a.
Monad m =>
Environment
-> Ledger tx -> NodeState tx -> StateT (StepState tx) m a -> m a
runHeadLogic Environment
bobEnv Ledger SimpleTx
ledger ([Party] -> NodeState SimpleTx
inOpenState [Party]
threeParties) (StateT (StepState SimpleTx) IO (NodeState SimpleTx)
 -> IO (NodeState SimpleTx))
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall a b. (a -> b) -> a -> b
$ do
            Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step Input SimpleTx
forall tx. Input tx
reqSn
            Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step (Secret (SigningKey HydraKey) -> Party -> Input SimpleTx
ackFrom Secret (SigningKey HydraKey)
carolSk Party
carol)
            Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step (Secret (SigningKey HydraKey) -> Party -> Input SimpleTx
ackFrom Secret (SigningKey HydraKey)
aliceSk Party
alice)
            StateT (StepState SimpleTx) IO (NodeState SimpleTx)
forall tx (m :: * -> *).
MonadState (StepState tx) m =>
m (NodeState tx)
getState

        UTCTime
now <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
waitingForLastAck.chainPointTime.currentSlot
        Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
waitingForLastAck (Secret (SigningKey HydraKey) -> Party -> Input SimpleTx
invalidAckFrom Secret (SigningKey HydraKey)
bobSk Party
bob)
          Outcome SimpleTx -> (Outcome SimpleTx -> Bool) -> IO ()
forall a. (HasCallStack, Show a) => a -> (a -> Bool) -> IO ()
`shouldSatisfy` \case
            Error (RequireFailed InvalidMultisignature{[VerificationKey HydraKey]
vkeys :: [VerificationKey HydraKey]
$sel:vkeys:ReqSnNumberInvalid :: forall tx. RequirementFailure tx -> [VerificationKey HydraKey]
vkeys}) -> [VerificationKey HydraKey]
vkeys [VerificationKey HydraKey] -> [VerificationKey HydraKey] -> Bool
forall a. Eq a => a -> a -> Bool
== [Party -> VerificationKey HydraKey
vkey Party
bob]
            Outcome SimpleTx
_ -> Bool
False

      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"rejects last AckSn if one signature was from a different key" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        let reqSn :: Input tx
            reqSn :: forall tx. Input tx
reqSn = Message tx -> Input tx
forall tx. Message tx -> Input tx
receiveMessage (Message tx -> Input tx) -> Message tx -> Input 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
0 SnapshotNumber
1 [] Maybe tx
forall a. Maybe a
Nothing Maybe (TxIdType tx)
forall a. Maybe a
Nothing
            snapshot :: Snapshot SimpleTx
snapshot = SnapshotNumber
-> SnapshotVersion
-> [SimpleTx]
-> UTxOType SimpleTx
-> Snapshot SimpleTx
forall tx.
IsTx tx =>
SnapshotNumber
-> SnapshotVersion -> [tx] -> UTxOType tx -> Snapshot tx
testSnapshot SnapshotNumber
1 SnapshotVersion
0 [] UTxOType SimpleTx
forall a. Monoid a => a
mempty
            ackFrom :: Secret (SigningKey HydraKey) -> Party -> Input SimpleTx
ackFrom Secret (SigningKey HydraKey)
sk Party
vk = Party -> Message SimpleTx -> Input SimpleTx
forall tx. Party -> Message tx -> Input tx
receiveMessageFrom Party
vk (Message SimpleTx -> Input SimpleTx)
-> Message SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ Signature (Snapshot SimpleTx) -> SnapshotNumber -> Message SimpleTx
forall tx. Signature (Snapshot tx) -> SnapshotNumber -> Message tx
AckSn (Secret (SigningKey HydraKey)
-> Snapshot SimpleTx -> Signature (Snapshot SimpleTx)
forall a.
SignableRepresentation a =>
Secret (SigningKey HydraKey) -> a -> Signature a
sign Secret (SigningKey HydraKey)
sk Snapshot SimpleTx
snapshot) SnapshotNumber
1
        NodeState SimpleTx
waitingForLastAck <-
          Environment
-> Ledger SimpleTx
-> NodeState SimpleTx
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall (m :: * -> *) tx a.
Monad m =>
Environment
-> Ledger tx -> NodeState tx -> StateT (StepState tx) m a -> m a
runHeadLogic Environment
bobEnv Ledger SimpleTx
ledger ([Party] -> NodeState SimpleTx
inOpenState [Party]
threeParties) (StateT (StepState SimpleTx) IO (NodeState SimpleTx)
 -> IO (NodeState SimpleTx))
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall a b. (a -> b) -> a -> b
$ do
            Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step Input SimpleTx
forall tx. Input tx
reqSn
            Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step (Secret (SigningKey HydraKey) -> Party -> Input SimpleTx
ackFrom Secret (SigningKey HydraKey)
carolSk Party
carol)
            Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step (Secret (SigningKey HydraKey) -> Party -> Input SimpleTx
ackFrom Secret (SigningKey HydraKey)
aliceSk Party
alice)
            StateT (StepState SimpleTx) IO (NodeState SimpleTx)
forall tx (m :: * -> *).
MonadState (StepState tx) m =>
m (NodeState tx)
getState

        UTCTime
now <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
waitingForLastAck.chainPointTime.currentSlot
        Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
waitingForLastAck (Secret (SigningKey HydraKey) -> Party -> Input SimpleTx
ackFrom (ByteString -> Secret (SigningKey HydraKey)
generateSigningKey ByteString
"foo") Party
bob)
          Outcome SimpleTx -> (Outcome SimpleTx -> Bool) -> IO ()
forall a. (HasCallStack, Show a) => a -> (a -> Bool) -> IO ()
`shouldSatisfy` \case
            Error (RequireFailed InvalidMultisignature{[VerificationKey HydraKey]
$sel:vkeys:ReqSnNumberInvalid :: forall tx. RequirementFailure tx -> [VerificationKey HydraKey]
vkeys :: [VerificationKey HydraKey]
vkeys}) -> [VerificationKey HydraKey]
vkeys [VerificationKey HydraKey] -> [VerificationKey HydraKey] -> Bool
forall a. Eq a => a -> a -> Bool
== [Party -> VerificationKey HydraKey
vkey Party
bob]
            Outcome SimpleTx
_ -> Bool
False

      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"rejects last AckSn if one signature was from a completely different message" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        let reqSn :: Input tx
            reqSn :: forall tx. Input tx
reqSn = Message tx -> Input tx
forall tx. Message tx -> Input tx
receiveMessage (Message tx -> Input tx) -> Message tx -> Input 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
0 SnapshotNumber
1 [] Maybe tx
forall a. Maybe a
Nothing Maybe (TxIdType tx)
forall a. Maybe a
Nothing
            snapshot1 :: Snapshot SimpleTx
snapshot1 = SnapshotNumber
-> SnapshotVersion
-> [SimpleTx]
-> UTxOType SimpleTx
-> Snapshot SimpleTx
forall tx.
IsTx tx =>
SnapshotNumber
-> SnapshotVersion -> [tx] -> UTxOType tx -> Snapshot tx
testSnapshot SnapshotNumber
1 SnapshotVersion
0 [] UTxOType SimpleTx
forall a. Monoid a => a
mempty
            ackFrom :: Secret (Crypto.SigningKey Crypto.HydraKey) -> Party -> Input SimpleTx
            ackFrom :: Secret (SigningKey HydraKey) -> Party -> Input SimpleTx
ackFrom Secret (SigningKey HydraKey)
sk Party
vk = Party -> Message SimpleTx -> Input SimpleTx
forall tx. Party -> Message tx -> Input tx
receiveMessageFrom Party
vk (Message SimpleTx -> Input SimpleTx)
-> Message SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ Signature (Snapshot SimpleTx) -> SnapshotNumber -> Message SimpleTx
forall tx. Signature (Snapshot tx) -> SnapshotNumber -> Message tx
AckSn (Secret (SigningKey HydraKey)
-> Snapshot SimpleTx -> Signature (Snapshot SimpleTx)
forall a.
SignableRepresentation a =>
Secret (SigningKey HydraKey) -> a -> Signature a
sign Secret (SigningKey HydraKey)
sk Snapshot SimpleTx
snapshot1) SnapshotNumber
1
            invalidAckFrom :: Secret (Crypto.SigningKey Crypto.HydraKey) -> Party -> Input SimpleTx
            invalidAckFrom :: Secret (SigningKey HydraKey) -> Party -> Input SimpleTx
invalidAckFrom Secret (SigningKey HydraKey)
sk Party
vk =
              Party -> Message SimpleTx -> Input SimpleTx
forall tx. Party -> Message tx -> Input tx
receiveMessageFrom Party
vk (Message SimpleTx -> Input SimpleTx)
-> Message SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$
                Signature (Snapshot SimpleTx) -> SnapshotNumber -> Message SimpleTx
forall tx. Signature (Snapshot tx) -> SnapshotNumber -> Message tx
AckSn (Signature ByteString -> Signature (Snapshot SimpleTx)
forall a b. Coercible a b => a -> b
coerce (Signature ByteString -> Signature (Snapshot SimpleTx))
-> Signature ByteString -> Signature (Snapshot SimpleTx)
forall a b. (a -> b) -> a -> b
$ Secret (SigningKey HydraKey) -> ByteString -> Signature ByteString
forall a.
SignableRepresentation a =>
Secret (SigningKey HydraKey) -> a -> Signature a
sign Secret (SigningKey HydraKey)
sk (ByteString
"foo" :: ByteString)) SnapshotNumber
1
        NodeState SimpleTx
waitingForLastAck <-
          Environment
-> Ledger SimpleTx
-> NodeState SimpleTx
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall (m :: * -> *) tx a.
Monad m =>
Environment
-> Ledger tx -> NodeState tx -> StateT (StepState tx) m a -> m a
runHeadLogic Environment
bobEnv Ledger SimpleTx
ledger ([Party] -> NodeState SimpleTx
inOpenState [Party]
threeParties) (StateT (StepState SimpleTx) IO (NodeState SimpleTx)
 -> IO (NodeState SimpleTx))
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall a b. (a -> b) -> a -> b
$ do
            Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step Input SimpleTx
forall tx. Input tx
reqSn
            Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step (Secret (SigningKey HydraKey) -> Party -> Input SimpleTx
ackFrom Secret (SigningKey HydraKey)
carolSk Party
carol)
            Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step (Secret (SigningKey HydraKey) -> Party -> Input SimpleTx
invalidAckFrom Secret (SigningKey HydraKey)
bobSk Party
bob)
            StateT (StepState SimpleTx) IO (NodeState SimpleTx)
forall tx (m :: * -> *).
MonadState (StepState tx) m =>
m (NodeState tx)
getState

        UTCTime
now <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
waitingForLastAck.chainPointTime.currentSlot
        Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
waitingForLastAck (Secret (SigningKey HydraKey) -> Party -> Input SimpleTx
ackFrom Secret (SigningKey HydraKey)
aliceSk Party
alice)
          Outcome SimpleTx -> (Outcome SimpleTx -> Bool) -> IO ()
forall a. (HasCallStack, Show a) => a -> (a -> Bool) -> IO ()
`shouldSatisfy` \case
            Error (RequireFailed InvalidMultisignature{[VerificationKey HydraKey]
$sel:vkeys:ReqSnNumberInvalid :: forall tx. RequirementFailure tx -> [VerificationKey HydraKey]
vkeys :: [VerificationKey HydraKey]
vkeys}) -> [VerificationKey HydraKey]
vkeys [VerificationKey HydraKey] -> [VerificationKey HydraKey] -> Bool
forall a. Eq a => a -> a -> Bool
== [Party -> VerificationKey HydraKey
vkey Party
bob]
            Outcome SimpleTx
_ -> Bool
False

      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"rejects last AckSn if already received signature from this party" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        let reqSn :: Input tx
            reqSn :: forall tx. Input tx
reqSn = Message tx -> Input tx
forall tx. Message tx -> Input tx
receiveMessage (Message tx -> Input tx) -> Message tx -> Input 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
0 SnapshotNumber
1 [] Maybe tx
forall a. Maybe a
Nothing Maybe (TxIdType tx)
forall a. Maybe a
Nothing
            snapshot1 :: Snapshot SimpleTx
snapshot1 = SnapshotNumber
-> SnapshotVersion
-> [SimpleTx]
-> UTxOType SimpleTx
-> Snapshot SimpleTx
forall tx.
IsTx tx =>
SnapshotNumber
-> SnapshotVersion -> [tx] -> UTxOType tx -> Snapshot tx
testSnapshot SnapshotNumber
1 SnapshotVersion
0 [] UTxOType SimpleTx
forall a. Monoid a => a
mempty
            ackFrom :: Secret (SigningKey HydraKey) -> Party -> Input SimpleTx
ackFrom Secret (SigningKey HydraKey)
sk Party
vk = Party -> Message SimpleTx -> Input SimpleTx
forall tx. Party -> Message tx -> Input tx
receiveMessageFrom Party
vk (Message SimpleTx -> Input SimpleTx)
-> Message SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ Signature (Snapshot SimpleTx) -> SnapshotNumber -> Message SimpleTx
forall tx. Signature (Snapshot tx) -> SnapshotNumber -> Message tx
AckSn (Secret (SigningKey HydraKey)
-> Snapshot SimpleTx -> Signature (Snapshot SimpleTx)
forall a.
SignableRepresentation a =>
Secret (SigningKey HydraKey) -> a -> Signature a
sign Secret (SigningKey HydraKey)
sk Snapshot SimpleTx
snapshot1) SnapshotNumber
1
        NodeState SimpleTx
waitingForAck <-
          Environment
-> Ledger SimpleTx
-> NodeState SimpleTx
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall (m :: * -> *) tx a.
Monad m =>
Environment
-> Ledger tx -> NodeState tx -> StateT (StepState tx) m a -> m a
runHeadLogic Environment
bobEnv Ledger SimpleTx
ledger ([Party] -> NodeState SimpleTx
inOpenState [Party]
threeParties) (StateT (StepState SimpleTx) IO (NodeState SimpleTx)
 -> IO (NodeState SimpleTx))
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall a b. (a -> b) -> a -> b
$ do
            Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step Input SimpleTx
forall tx. Input tx
reqSn
            Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step (Secret (SigningKey HydraKey) -> Party -> Input SimpleTx
ackFrom Secret (SigningKey HydraKey)
carolSk Party
carol)
            StateT (StepState SimpleTx) IO (NodeState SimpleTx)
forall tx (m :: * -> *).
MonadState (StepState tx) m =>
m (NodeState tx)
getState

        UTCTime
now <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
waitingForAck.chainPointTime.currentSlot
        Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
waitingForAck (Secret (SigningKey HydraKey) -> Party -> Input SimpleTx
ackFrom Secret (SigningKey HydraKey)
carolSk Party
carol)
          Outcome SimpleTx -> (Outcome SimpleTx -> Bool) -> IO ()
forall a. (HasCallStack, Show a) => a -> (a -> Bool) -> IO ()
`shouldSatisfy` \case
            Error (RequireFailed SnapshotAlreadySigned{Party
receivedSignature :: Party
$sel:receivedSignature:ReqSnNumberInvalid :: forall tx. RequirementFailure tx -> Party
receivedSignature}) -> Party
receivedSignature Party -> Party -> Bool
forall a. Eq a => a -> a -> Bool
== Party
carol
            Outcome SimpleTx
_ -> Bool
False

      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"ignores valid AckSn if snapshot already confirmed" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        let reqSn :: Input tx
            reqSn :: forall tx. Input tx
reqSn = Message tx -> Input tx
forall tx. Message tx -> Input tx
receiveMessage (Message tx -> Input tx) -> Message tx -> Input 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
0 SnapshotNumber
1 [] Maybe tx
forall a. Maybe a
Nothing Maybe (TxIdType tx)
forall a. Maybe a
Nothing
            snapshot1 :: Snapshot SimpleTx
snapshot1 = SnapshotNumber
-> SnapshotVersion
-> [SimpleTx]
-> UTxOType SimpleTx
-> Snapshot SimpleTx
forall tx.
IsTx tx =>
SnapshotNumber
-> SnapshotVersion -> [tx] -> UTxOType tx -> Snapshot tx
testSnapshot SnapshotNumber
1 SnapshotVersion
0 [] UTxOType SimpleTx
forall a. Monoid a => a
mempty
            ackFrom :: Secret (SigningKey HydraKey) -> Input SimpleTx
ackFrom Secret (SigningKey HydraKey)
sk = Party -> Message SimpleTx -> Input SimpleTx
forall tx. Party -> Message tx -> Input tx
receiveMessageFrom (Secret (SigningKey HydraKey) -> Party
deriveParty Secret (SigningKey HydraKey)
sk) (Message SimpleTx -> Input SimpleTx)
-> Message SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ Signature (Snapshot SimpleTx) -> SnapshotNumber -> Message SimpleTx
forall tx. Signature (Snapshot tx) -> SnapshotNumber -> Message tx
AckSn (Secret (SigningKey HydraKey)
-> Snapshot SimpleTx -> Signature (Snapshot SimpleTx)
forall a.
SignableRepresentation a =>
Secret (SigningKey HydraKey) -> a -> Signature a
sign Secret (SigningKey HydraKey)
sk Snapshot SimpleTx
snapshot1) SnapshotNumber
1

        NodeState SimpleTx
s0 <- Environment
-> Ledger SimpleTx
-> NodeState SimpleTx
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall (m :: * -> *) tx a.
Monad m =>
Environment
-> Ledger tx -> NodeState tx -> StateT (StepState tx) m a -> m a
runHeadLogic Environment
bobEnv Ledger SimpleTx
ledger ([Party] -> NodeState SimpleTx
inOpenState [Party]
threeParties) (StateT (StepState SimpleTx) IO (NodeState SimpleTx)
 -> IO (NodeState SimpleTx))
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall a b. (a -> b) -> a -> b
$ do
          Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step Input SimpleTx
forall tx. Input tx
reqSn
          Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step (Secret (SigningKey HydraKey) -> Input SimpleTx
ackFrom Secret (SigningKey HydraKey)
carolSk)
          Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step (Secret (SigningKey HydraKey) -> Input SimpleTx
ackFrom Secret (SigningKey HydraKey)
bobSk)
          Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step (Secret (SigningKey HydraKey) -> Input SimpleTx
ackFrom Secret (SigningKey HydraKey)
aliceSk)
          StateT (StepState SimpleTx) IO (NodeState SimpleTx)
forall tx (m :: * -> *).
MonadState (StepState tx) m =>
m (NodeState tx)
getState

        UTCTime
now <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
s0.chainPointTime.currentSlot
        Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
s0 (Secret (SigningKey HydraKey) -> Input SimpleTx
ackFrom Secret (SigningKey HydraKey)
carolSk)
          Outcome SimpleTx -> Outcome SimpleTx -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Outcome SimpleTx
forall tx. Outcome tx
noop

      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"rejects snapshot request with transaction not applicable to previous snapshot" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        let reqTx42 :: Input SimpleTx
reqTx42 = Message SimpleTx -> Input SimpleTx
forall tx. Message tx -> Input tx
receiveMessage (Message SimpleTx -> Input SimpleTx)
-> Message SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ SimpleTx -> Message SimpleTx
forall tx. tx -> Message tx
ReqTx (SimpleId -> UTxOType SimpleTx -> UTxOType SimpleTx -> SimpleTx
SimpleTx SimpleId
42 Set SimpleTxOut
UTxOType SimpleTx
forall a. Monoid a => a
mempty (SimpleId -> UTxOType SimpleTx
utxoRef SimpleId
1))
            reqTx1 :: Input SimpleTx
reqTx1 = Message SimpleTx -> Input SimpleTx
forall tx. Message tx -> Input tx
receiveMessage (Message SimpleTx -> Input SimpleTx)
-> Message SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ SimpleTx -> Message SimpleTx
forall tx. tx -> Message tx
ReqTx (SimpleId -> UTxOType SimpleTx -> UTxOType SimpleTx -> SimpleTx
SimpleTx SimpleId
1 (SimpleId -> UTxOType SimpleTx
utxoRef SimpleId
1) (SimpleId -> UTxOType SimpleTx
utxoRef SimpleId
2))
            input :: Input SimpleTx
input = Message SimpleTx -> Input SimpleTx
forall tx. Message tx -> Input tx
receiveMessage (Message SimpleTx -> Input SimpleTx)
-> Message SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ SnapshotVersion
-> SnapshotNumber
-> [TxIdType SimpleTx]
-> Maybe SimpleTx
-> Maybe (TxIdType SimpleTx)
-> Message SimpleTx
forall tx.
SnapshotVersion
-> SnapshotNumber
-> [TxIdType tx]
-> Maybe tx
-> Maybe (TxIdType tx)
-> Message tx
ReqSn SnapshotVersion
0 SnapshotNumber
1 [TxIdType SimpleTx
1] Maybe SimpleTx
forall a. Maybe a
Nothing Maybe (TxIdType SimpleTx)
forall a. Maybe a
Nothing
            s0 :: NodeState SimpleTx
s0 = [Party] -> NodeState SimpleTx
inOpenState [Party]
threeParties

        NodeState SimpleTx
s2 <- Environment
-> Ledger SimpleTx
-> NodeState SimpleTx
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall (m :: * -> *) tx a.
Monad m =>
Environment
-> Ledger tx -> NodeState tx -> StateT (StepState tx) m a -> m a
runHeadLogic Environment
bobEnv Ledger SimpleTx
ledger NodeState SimpleTx
s0 (StateT (StepState SimpleTx) IO (NodeState SimpleTx)
 -> IO (NodeState SimpleTx))
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall a b. (a -> b) -> a -> b
$ do
          Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step Input SimpleTx
reqTx42
          Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step Input SimpleTx
reqTx1
          StateT (StepState SimpleTx) IO (NodeState SimpleTx)
forall tx (m :: * -> *).
MonadState (StepState tx) m =>
m (NodeState tx)
getState

        UTCTime
now <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
s2.chainPointTime.currentSlot
        Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
s2 Input SimpleTx
input
          Outcome SimpleTx -> Outcome SimpleTx -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` LogicError SimpleTx -> Outcome SimpleTx
forall tx. LogicError tx -> Outcome tx
Error (RequirementFailure SimpleTx -> LogicError SimpleTx
forall tx. RequirementFailure tx -> LogicError tx
RequireFailed (SnapshotNumber
-> TxIdType SimpleTx
-> ValidationError
-> RequirementFailure SimpleTx
forall tx.
SnapshotNumber
-> TxIdType tx -> ValidationError -> RequirementFailure tx
SnapshotDoesNotApply SnapshotNumber
1 SimpleId
TxIdType SimpleTx
1 (Text -> ValidationError
ValidationError Text
"cannot apply transaction")))

      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"rejects snapshot request with UTxO set exceeding the accumulator limit" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        -- alice is leader for sn=1 (isLeader: (1-1) mod 3 = 0 = index alice)
        let bigCount :: Int
bigCount = Int
Accumulator.maxAccumulatorSize Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
            bigOutputs :: UTxOType SimpleTx
bigOutputs = [SimpleId] -> UTxOType SimpleTx
utxoRefs ((Int -> SimpleId) -> [Int] -> [SimpleId]
forall a b. (a -> b) -> [a] -> [b]
map Int -> SimpleId
forall a b. (Integral a, Num b) => a -> b
fromIntegral [Int
1 .. Int
bigCount])
            tx :: SimpleTx
tx = SimpleId -> UTxOType SimpleTx -> UTxOType SimpleTx -> SimpleTx
SimpleTx SimpleId
1 Set SimpleTxOut
UTxOType SimpleTx
forall a. Monoid a => a
mempty Set SimpleTxOut
UTxOType SimpleTx
bigOutputs
            st :: NodeState SimpleTx
st =
              [Party] -> CoordinatedHeadState SimpleTx -> NodeState SimpleTx
inOpenState' [Party]
threeParties (CoordinatedHeadState SimpleTx -> NodeState SimpleTx)
-> CoordinatedHeadState SimpleTx -> NodeState SimpleTx
forall a b. (a -> b) -> a -> b
$
                CoordinatedHeadState SimpleTx
coordinatedHeadState{allTxs = Map.fromList [(1, tx)]}
            reqSn :: Input SimpleTx
reqSn = Message SimpleTx -> Input SimpleTx
forall tx. Message tx -> Input tx
receiveMessage (Message SimpleTx -> Input SimpleTx)
-> Message SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ SnapshotVersion
-> SnapshotNumber
-> [TxIdType SimpleTx]
-> Maybe SimpleTx
-> Maybe (TxIdType SimpleTx)
-> Message SimpleTx
forall tx.
SnapshotVersion
-> SnapshotNumber
-> [TxIdType tx]
-> Maybe tx
-> Maybe (TxIdType tx)
-> Message tx
ReqSn SnapshotVersion
0 SnapshotNumber
1 [TxIdType SimpleTx
1] Maybe SimpleTx
forall a. Maybe a
Nothing Maybe (TxIdType SimpleTx)
forall a. Maybe a
Nothing
        UTCTime
now <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
st.chainPointTime.currentSlot
        Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
st Input SimpleTx
reqSn
          Outcome SimpleTx -> Outcome SimpleTx -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` LogicError SimpleTx -> Outcome SimpleTx
forall tx. LogicError tx -> Outcome tx
Error (RequirementFailure SimpleTx -> LogicError SimpleTx
forall tx. RequirementFailure tx -> LogicError tx
RequireFailed ReqSnUTxOSetTooLarge{$sel:utxoCount:ReqSnNumberInvalid :: Int
utxoCount = Int
bigCount, $sel:maxAllowed:ReqSnNumberInvalid :: Int
maxAllowed = Int
Accumulator.maxAccumulatorSize})

      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"waits if we receive a snapshot with unseen transactions" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        let s0 :: NodeState SimpleTx
s0 = [Party] -> NodeState SimpleTx
inOpenState [Party]
threeParties
            reqSn :: Input SimpleTx
reqSn = Message SimpleTx -> Input SimpleTx
forall tx. Message tx -> Input tx
receiveMessage (Message SimpleTx -> Input SimpleTx)
-> Message SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ SnapshotVersion
-> SnapshotNumber
-> [TxIdType SimpleTx]
-> Maybe SimpleTx
-> Maybe (TxIdType SimpleTx)
-> Message SimpleTx
forall tx.
SnapshotVersion
-> SnapshotNumber
-> [TxIdType tx]
-> Maybe tx
-> Maybe (TxIdType tx)
-> Message tx
ReqSn SnapshotVersion
0 SnapshotNumber
1 [TxIdType SimpleTx
1] Maybe SimpleTx
forall a. Maybe a
Nothing Maybe (TxIdType SimpleTx)
forall a. Maybe a
Nothing
        UTCTime
now <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
s0.chainPointTime.currentSlot
        Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
s0 Input SimpleTx
reqSn
          Outcome SimpleTx -> WaitReason SimpleTx -> IO ()
forall tx.
(HasCallStack, IsChainState tx) =>
Outcome tx -> WaitReason tx -> IO ()
`assertWait` [TxIdType SimpleTx] -> WaitReason SimpleTx
forall tx. [TxIdType tx] -> WaitReason tx
WaitOnTxs [SimpleId
TxIdType SimpleTx
1]

      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"waits if we receive an AckSn for an unseen snapshot" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        let snapshot :: Snapshot SimpleTx
snapshot = SnapshotNumber
-> SnapshotVersion
-> [SimpleTx]
-> UTxOType SimpleTx
-> Snapshot SimpleTx
forall tx.
IsTx tx =>
SnapshotNumber
-> SnapshotVersion -> [tx] -> UTxOType tx -> Snapshot tx
testSnapshot SnapshotNumber
1 SnapshotVersion
0 [] UTxOType SimpleTx
forall a. Monoid a => a
mempty
            input :: Input SimpleTx
input = Message SimpleTx -> Input SimpleTx
forall tx. Message tx -> Input tx
receiveMessage (Message SimpleTx -> Input SimpleTx)
-> Message SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ Signature (Snapshot SimpleTx) -> SnapshotNumber -> Message SimpleTx
forall tx. Signature (Snapshot tx) -> SnapshotNumber -> Message tx
AckSn (Secret (SigningKey HydraKey)
-> Snapshot SimpleTx -> Signature (Snapshot SimpleTx)
forall a.
SignableRepresentation a =>
Secret (SigningKey HydraKey) -> a -> Signature a
sign Secret (SigningKey HydraKey)
aliceSk Snapshot SimpleTx
snapshot) SnapshotNumber
1
            s0 :: NodeState SimpleTx
s0 = [Party] -> NodeState SimpleTx
inOpenState [Party]
threeParties
        UTCTime
now <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
s0.chainPointTime.currentSlot
        Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
s0 Input SimpleTx
input
          Outcome SimpleTx -> WaitReason SimpleTx -> IO ()
forall tx.
(HasCallStack, IsChainState tx) =>
Outcome tx -> WaitReason tx -> IO ()
`assertWait` WaitReason SimpleTx
forall tx. WaitReason tx
WaitOnSeenSnapshot

      -- TODO: Write property tests for various future / old snapshot behavior.
      -- That way we could cover variations of snapshot numbers and state of
      -- snapshot collection.

      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"rejects if we receive a too far future snapshot" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        let input :: Input tx
            input :: forall tx. Input tx
input = Party -> Message tx -> Input tx
forall tx. Party -> Message tx -> Input tx
receiveMessageFrom Party
bob (Message tx -> Input tx) -> Message tx -> Input 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
0 SnapshotNumber
2 [] Maybe tx
forall a. Maybe a
Nothing Maybe (TxIdType tx)
forall a. Maybe a
Nothing
            st :: NodeState SimpleTx
st = [Party] -> NodeState SimpleTx
inOpenState [Party]
threeParties
        UTCTime
now <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
st.chainPointTime.currentSlot
        Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
st Input SimpleTx
forall tx. Input tx
input Outcome SimpleTx -> Outcome SimpleTx -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` LogicError SimpleTx -> Outcome SimpleTx
forall tx. LogicError tx -> Outcome tx
Error (RequirementFailure SimpleTx -> LogicError SimpleTx
forall tx. RequirementFailure tx -> LogicError tx
RequireFailed (RequirementFailure SimpleTx -> LogicError SimpleTx)
-> RequirementFailure SimpleTx -> LogicError SimpleTx
forall a b. (a -> b) -> a -> b
$ SnapshotNumber -> SnapshotNumber -> RequirementFailure SimpleTx
forall tx.
SnapshotNumber -> SnapshotNumber -> RequirementFailure tx
ReqSnNumberInvalid SnapshotNumber
2 SnapshotNumber
0)

      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"waits if we receive a future snapshot while collecting signatures" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        let reqSn1 :: Input tx
            reqSn1 :: forall tx. Input tx
reqSn1 = Message tx -> Input tx
forall tx. Message tx -> Input tx
receiveMessage (Message tx -> Input tx) -> Message tx -> Input 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
0 SnapshotNumber
1 [] Maybe tx
forall a. Maybe a
Nothing Maybe (TxIdType tx)
forall a. Maybe a
Nothing
            reqSn2 :: Input tx
            reqSn2 :: forall tx. Input tx
reqSn2 = Party -> Message tx -> Input tx
forall tx. Party -> Message tx -> Input tx
receiveMessageFrom Party
bob (Message tx -> Input tx) -> Message tx -> Input 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
0 SnapshotNumber
2 [] Maybe tx
forall a. Maybe a
Nothing Maybe (TxIdType tx)
forall a. Maybe a
Nothing
        NodeState SimpleTx
st <-
          Environment
-> Ledger SimpleTx
-> NodeState SimpleTx
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall (m :: * -> *) tx a.
Monad m =>
Environment
-> Ledger tx -> NodeState tx -> StateT (StepState tx) m a -> m a
runHeadLogic Environment
bobEnv Ledger SimpleTx
ledger ([Party] -> NodeState SimpleTx
inOpenState [Party]
threeParties) (StateT (StepState SimpleTx) IO (NodeState SimpleTx)
 -> IO (NodeState SimpleTx))
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall a b. (a -> b) -> a -> b
$ do
            Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step Input SimpleTx
forall tx. Input tx
reqSn1
            StateT (StepState SimpleTx) IO (NodeState SimpleTx)
forall tx (m :: * -> *).
MonadState (StepState tx) m =>
m (NodeState tx)
getState

        UTCTime
now <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
st.chainPointTime.currentSlot
        Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
st Input SimpleTx
forall tx. Input tx
reqSn2
          Outcome SimpleTx -> WaitReason SimpleTx -> IO ()
forall tx.
(HasCallStack, IsChainState tx) =>
Outcome tx -> WaitReason tx -> IO ()
`assertWait` SnapshotNumber -> WaitReason SimpleTx
forall tx. SnapshotNumber -> WaitReason tx
WaitOnSnapshotNumber SnapshotNumber
1

      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"acks signed snapshot from the constant leader" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        let leader :: Party
leader = Party
alice
            snapshot :: Snapshot SimpleTx
snapshot = SnapshotNumber
-> SnapshotVersion
-> [SimpleTx]
-> UTxOType SimpleTx
-> Snapshot SimpleTx
forall tx.
IsTx tx =>
SnapshotNumber
-> SnapshotVersion -> [tx] -> UTxOType tx -> Snapshot tx
testSnapshot SnapshotNumber
1 SnapshotVersion
0 [] UTxOType SimpleTx
forall a. Monoid a => a
mempty
            input :: Input SimpleTx
input = Party -> Message SimpleTx -> Input SimpleTx
forall tx. Party -> Message tx -> Input tx
receiveMessageFrom Party
leader (Message SimpleTx -> Input SimpleTx)
-> Message SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ SnapshotVersion
-> SnapshotNumber
-> [TxIdType SimpleTx]
-> Maybe SimpleTx
-> Maybe (TxIdType SimpleTx)
-> Message SimpleTx
forall tx.
SnapshotVersion
-> SnapshotNumber
-> [TxIdType tx]
-> Maybe tx
-> Maybe (TxIdType tx)
-> Message tx
ReqSn SnapshotVersion
0 (Snapshot SimpleTx -> SnapshotNumber
forall tx. Snapshot tx -> SnapshotNumber
number Snapshot SimpleTx
snapshot) [] Maybe SimpleTx
forall a. Maybe a
Nothing Maybe SimpleId
Maybe (TxIdType SimpleTx)
forall a. Maybe a
Nothing
            sig :: Signature (Snapshot SimpleTx)
sig = Secret (SigningKey HydraKey)
-> Snapshot SimpleTx -> Signature (Snapshot SimpleTx)
forall a.
SignableRepresentation a =>
Secret (SigningKey HydraKey) -> a -> Signature a
sign Secret (SigningKey HydraKey)
bobSk Snapshot SimpleTx
snapshot
            st :: NodeState SimpleTx
st = [Party] -> NodeState SimpleTx
inOpenState [Party]
threeParties
            ack :: Message SimpleTx
ack = Signature (Snapshot SimpleTx) -> SnapshotNumber -> Message SimpleTx
forall tx. Signature (Snapshot tx) -> SnapshotNumber -> Message tx
AckSn Signature (Snapshot SimpleTx)
sig (Snapshot SimpleTx -> SnapshotNumber
forall tx. Snapshot tx -> SnapshotNumber
number Snapshot SimpleTx
snapshot)
        UTCTime
now <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
st.chainPointTime.currentSlot
        Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
st Input SimpleTx
input Outcome SimpleTx -> Effect SimpleTx -> IO ()
forall tx.
(HasCallStack, IsChainState tx) =>
Outcome tx -> Effect tx -> IO ()
`hasEffect` Message SimpleTx -> Effect SimpleTx
forall tx. Message tx -> Effect tx
NetworkEffect Message SimpleTx
ack

      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"does not ack snapshots from non-leaders" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        let input :: Input tx
            input :: forall tx. Input tx
input = Party -> Message tx -> Input tx
forall tx. Party -> Message tx -> Input tx
receiveMessageFrom Party
notTheLeader (Message tx -> Input tx) -> Message tx -> Input 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
0 SnapshotNumber
1 [] Maybe tx
forall a. Maybe a
Nothing Maybe (TxIdType tx)
forall a. Maybe a
Nothing
            notTheLeader :: Party
notTheLeader = Party
bob
            st :: NodeState SimpleTx
st = [Party] -> NodeState SimpleTx
inOpenState [Party]
threeParties
        UTCTime
now <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
st.chainPointTime.currentSlot
        Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
st Input SimpleTx
forall tx. Input tx
input Outcome SimpleTx -> (Outcome SimpleTx -> Bool) -> IO ()
forall a. (HasCallStack, Show a) => a -> (a -> Bool) -> IO ()
`shouldSatisfy` \case
          Error (RequireFailed ReqSnNotLeader{$sel:requestedSn:ReqSnNumberInvalid :: forall tx. RequirementFailure tx -> SnapshotNumber
requestedSn = SnapshotNumber
1, Party
leader :: Party
$sel:leader:ReqSnNumberInvalid :: forall tx. RequirementFailure tx -> Party
leader}) -> Party
leader Party -> Party -> Bool
forall a. Eq a => a -> a -> Bool
== Party
notTheLeader
          Outcome SimpleTx
_ -> Bool
False

      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"rejects too-old snapshots" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        let input :: Input tx
            input :: forall tx. Input tx
input = Party -> Message tx -> Input tx
forall tx. Party -> Message tx -> Input tx
receiveMessageFrom Party
theLeader (Message tx -> Input tx) -> Message tx -> Input 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
0 SnapshotNumber
2 [] Maybe tx
forall a. Maybe a
Nothing Maybe (TxIdType tx)
forall a. Maybe a
Nothing
            theLeader :: Party
theLeader = Party
alice
            snapshot :: Snapshot SimpleTx
snapshot = SnapshotNumber
-> SnapshotVersion
-> [SimpleTx]
-> UTxOType SimpleTx
-> Snapshot SimpleTx
forall tx.
IsTx tx =>
SnapshotNumber
-> SnapshotVersion -> [tx] -> UTxOType tx -> Snapshot tx
testSnapshot SnapshotNumber
2 SnapshotVersion
0 [] UTxOType SimpleTx
forall a. Monoid a => a
mempty
            st :: NodeState SimpleTx
st =
              [Party] -> CoordinatedHeadState SimpleTx -> NodeState SimpleTx
inOpenState' [Party]
threeParties (CoordinatedHeadState SimpleTx -> NodeState SimpleTx)
-> CoordinatedHeadState SimpleTx -> NodeState SimpleTx
forall a b. (a -> b) -> a -> b
$
                CoordinatedHeadState SimpleTx
coordinatedHeadState{confirmedSnapshot = ConfirmedSnapshot snapshot (Crypto.aggregate [])}
        UTCTime
now <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
st.chainPointTime.currentSlot
        Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
st Input SimpleTx
forall tx. Input tx
input Outcome SimpleTx -> Outcome SimpleTx -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` LogicError SimpleTx -> Outcome SimpleTx
forall tx. LogicError tx -> Outcome tx
Error (RequirementFailure SimpleTx -> LogicError SimpleTx
forall tx. RequirementFailure tx -> LogicError tx
RequireFailed (RequirementFailure SimpleTx -> LogicError SimpleTx)
-> RequirementFailure SimpleTx -> LogicError SimpleTx
forall a b. (a -> b) -> a -> b
$ SnapshotNumber -> SnapshotNumber -> RequirementFailure SimpleTx
forall tx.
SnapshotNumber -> SnapshotNumber -> RequirementFailure tx
ReqSnNumberInvalid SnapshotNumber
2 SnapshotNumber
0)

      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"rejects too-old snapshots when collecting signatures" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        let input :: Input tx
            input :: forall tx. Input tx
input = Party -> Message tx -> Input tx
forall tx. Party -> Message tx -> Input tx
receiveMessageFrom Party
theLeader (Message tx -> Input tx) -> Message tx -> Input 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
0 SnapshotNumber
2 [] Maybe tx
forall a. Maybe a
Nothing Maybe (TxIdType tx)
forall a. Maybe a
Nothing
            theLeader :: Party
theLeader = Party
alice
            snapshot :: Snapshot SimpleTx
snapshot = SnapshotNumber
-> SnapshotVersion
-> [SimpleTx]
-> UTxOType SimpleTx
-> Snapshot SimpleTx
forall tx.
IsTx tx =>
SnapshotNumber
-> SnapshotVersion -> [tx] -> UTxOType tx -> Snapshot tx
testSnapshot SnapshotNumber
2 SnapshotVersion
0 [] UTxOType SimpleTx
forall a. Monoid a => a
mempty
            st :: NodeState SimpleTx
st =
              [Party] -> CoordinatedHeadState SimpleTx -> NodeState SimpleTx
inOpenState' [Party]
threeParties (CoordinatedHeadState SimpleTx -> NodeState SimpleTx)
-> CoordinatedHeadState SimpleTx -> NodeState SimpleTx
forall a b. (a -> b) -> a -> b
$
                CoordinatedHeadState SimpleTx
coordinatedHeadState
                  { confirmedSnapshot = ConfirmedSnapshot snapshot (Crypto.aggregate [])
                  , seenSnapshot = mkSeenSnapshot (testSnapshot 3 0 [] mempty) mempty
                  }
        UTCTime
now <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
st.chainPointTime.currentSlot
        Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
st Input SimpleTx
forall tx. Input tx
input Outcome SimpleTx -> Outcome SimpleTx -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` LogicError SimpleTx -> Outcome SimpleTx
forall tx. LogicError tx -> Outcome tx
Error (RequirementFailure SimpleTx -> LogicError SimpleTx
forall tx. RequirementFailure tx -> LogicError tx
RequireFailed (RequirementFailure SimpleTx -> LogicError SimpleTx)
-> RequirementFailure SimpleTx -> LogicError SimpleTx
forall a b. (a -> b) -> a -> b
$ SnapshotNumber -> SnapshotNumber -> RequirementFailure SimpleTx
forall tx.
SnapshotNumber -> SnapshotNumber -> RequirementFailure tx
ReqSnNumberInvalid SnapshotNumber
2 SnapshotNumber
3)

      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"rejects too-new snapshots from the leader" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        let input :: Input tx
            input :: forall tx. Input tx
input = Party -> Message tx -> Input tx
forall tx. Party -> Message tx -> Input tx
receiveMessageFrom Party
theLeader (Message tx -> Input tx) -> Message tx -> Input 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
0 SnapshotNumber
3 [] Maybe tx
forall a. Maybe a
Nothing Maybe (TxIdType tx)
forall a. Maybe a
Nothing
            theLeader :: Party
theLeader = Party
carol
            st :: NodeState SimpleTx
st = [Party] -> NodeState SimpleTx
inOpenState [Party]
threeParties
        UTCTime
now <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
st.chainPointTime.currentSlot
        Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
st Input SimpleTx
forall tx. Input tx
input Outcome SimpleTx -> Outcome SimpleTx -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` LogicError SimpleTx -> Outcome SimpleTx
forall tx. LogicError tx -> Outcome tx
Error (RequirementFailure SimpleTx -> LogicError SimpleTx
forall tx. RequirementFailure tx -> LogicError tx
RequireFailed (RequirementFailure SimpleTx -> LogicError SimpleTx)
-> RequirementFailure SimpleTx -> LogicError SimpleTx
forall a b. (a -> b) -> a -> b
$ SnapshotNumber -> SnapshotNumber -> RequirementFailure SimpleTx
forall tx.
SnapshotNumber -> SnapshotNumber -> RequirementFailure tx
ReqSnNumberInvalid SnapshotNumber
3 SnapshotNumber
0)

      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"waits on out-of-sync snapshot version" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        -- A ReqSn whose version does not match our local version is parked as
        -- a Wait so the TTL/retry machinery can recover when a follower is
        -- briefly behind the leader after an in-flight OnIncrement/OnDecrement.
        let validSnNumber :: SnapshotNumber
validSnNumber = SnapshotNumber
1
            invalidSnVersion :: SnapshotVersion
invalidSnVersion = SnapshotVersion
1
            input :: Input SimpleTx
input = Party -> Message SimpleTx -> Input SimpleTx
forall tx. Party -> Message tx -> Input tx
receiveMessageFrom Party
theLeader (Message SimpleTx -> Input SimpleTx)
-> Message SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ SnapshotVersion
-> SnapshotNumber
-> [TxIdType SimpleTx]
-> Maybe SimpleTx
-> Maybe (TxIdType SimpleTx)
-> Message SimpleTx
forall tx.
SnapshotVersion
-> SnapshotNumber
-> [TxIdType tx]
-> Maybe tx
-> Maybe (TxIdType tx)
-> Message tx
ReqSn SnapshotVersion
invalidSnVersion SnapshotNumber
validSnNumber [] Maybe SimpleTx
forall a. Maybe a
Nothing Maybe SimpleId
Maybe (TxIdType SimpleTx)
forall a. Maybe a
Nothing
            theLeader :: Party
theLeader = Party
alice
            st :: NodeState SimpleTx
st = [Party] -> NodeState SimpleTx
inOpenState [Party]
threeParties
        UTCTime
now <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
st.chainPointTime.currentSlot
        Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
st Input SimpleTx
input Outcome SimpleTx -> (Outcome SimpleTx -> Bool) -> IO ()
forall a. (HasCallStack, Show a) => a -> (a -> Bool) -> IO ()
`shouldSatisfy` \case
          Wait WaitOnSnapshotVersion{$sel:waitingForVersion:WaitOnNotApplicableTx :: forall tx. WaitReason tx -> SnapshotVersion
waitingForVersion = SnapshotVersion
1} [StateChanged SimpleTx]
_ -> Bool
True
          Outcome SimpleTx
_ -> Bool
False

      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"rejects overlapping snapshot requests from the leader" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        let theLeader :: Party
theLeader = Party
alice
            nextSN :: SnapshotNumber
nextSN = SnapshotNumber
1
            firstReqTx :: Input SimpleTx
firstReqTx = Message SimpleTx -> Input SimpleTx
forall tx. Message tx -> Input tx
receiveMessage (Message SimpleTx -> Input SimpleTx)
-> Message SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ SimpleTx -> Message SimpleTx
forall tx. tx -> Message tx
ReqTx (SimpleId -> SimpleTx
aValidTx SimpleId
42)
            firstReqSn :: Input SimpleTx
firstReqSn = Party -> Message SimpleTx -> Input SimpleTx
forall tx. Party -> Message tx -> Input tx
receiveMessageFrom Party
theLeader (Message SimpleTx -> Input SimpleTx)
-> Message SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ SnapshotVersion
-> SnapshotNumber
-> [TxIdType SimpleTx]
-> Maybe SimpleTx
-> Maybe (TxIdType SimpleTx)
-> Message SimpleTx
forall tx.
SnapshotVersion
-> SnapshotNumber
-> [TxIdType tx]
-> Maybe tx
-> Maybe (TxIdType tx)
-> Message tx
ReqSn SnapshotVersion
0 SnapshotNumber
nextSN [TxIdType SimpleTx
42] Maybe SimpleTx
forall a. Maybe a
Nothing Maybe (TxIdType SimpleTx)
forall a. Maybe a
Nothing
            secondReqTx :: Input SimpleTx
secondReqTx = Message SimpleTx -> Input SimpleTx
forall tx. Message tx -> Input tx
receiveMessage (Message SimpleTx -> Input SimpleTx)
-> Message SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ SimpleTx -> Message SimpleTx
forall tx. tx -> Message tx
ReqTx (SimpleId -> SimpleTx
aValidTx SimpleId
51)
            secondReqSn :: Input SimpleTx
secondReqSn = Party -> Message SimpleTx -> Input SimpleTx
forall tx. Party -> Message tx -> Input tx
receiveMessageFrom Party
theLeader (Message SimpleTx -> Input SimpleTx)
-> Message SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ SnapshotVersion
-> SnapshotNumber
-> [TxIdType SimpleTx]
-> Maybe SimpleTx
-> Maybe (TxIdType SimpleTx)
-> Message SimpleTx
forall tx.
SnapshotVersion
-> SnapshotNumber
-> [TxIdType tx]
-> Maybe tx
-> Maybe (TxIdType tx)
-> Message tx
ReqSn SnapshotVersion
0 SnapshotNumber
nextSN [SimpleId
TxIdType SimpleTx
51] Maybe SimpleTx
forall a. Maybe a
Nothing Maybe SimpleId
Maybe (TxIdType SimpleTx)
forall a. Maybe a
Nothing

        NodeState SimpleTx
s3 <- Environment
-> Ledger SimpleTx
-> NodeState SimpleTx
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall (m :: * -> *) tx a.
Monad m =>
Environment
-> Ledger tx -> NodeState tx -> StateT (StepState tx) m a -> m a
runHeadLogic Environment
bobEnv Ledger SimpleTx
ledger ([Party] -> NodeState SimpleTx
inOpenState [Party]
threeParties) (StateT (StepState SimpleTx) IO (NodeState SimpleTx)
 -> IO (NodeState SimpleTx))
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall a b. (a -> b) -> a -> b
$ do
          Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step Input SimpleTx
firstReqTx
          Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step Input SimpleTx
firstReqSn
          Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step Input SimpleTx
secondReqTx
          StateT (StepState SimpleTx) IO (NodeState SimpleTx)
forall tx (m :: * -> *).
MonadState (StepState tx) m =>
m (NodeState tx)
getState

        UTCTime
now <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
s3.chainPointTime.currentSlot
        Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
s3 Input SimpleTx
secondReqSn Outcome SimpleTx -> (Outcome SimpleTx -> Bool) -> IO ()
forall a. (HasCallStack, Show a) => a -> (a -> Bool) -> IO ()
`shouldSatisfy` \case
          Error RequireFailed{} -> Bool
True
          Outcome SimpleTx
_ -> Bool
False

      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"rejects same version snapshot requests with differing decommit txs" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        let decommitTx1 :: SimpleTx
decommitTx1 = SimpleId -> UTxOType SimpleTx -> UTxOType SimpleTx -> SimpleTx
SimpleTx SimpleId
1 (SimpleId -> UTxOType SimpleTx
utxoRef SimpleId
1) (SimpleId -> UTxOType SimpleTx
utxoRef SimpleId
3)
            decommitTx2 :: SimpleTx
decommitTx2 = SimpleId -> UTxOType SimpleTx -> UTxOType SimpleTx -> SimpleTx
SimpleTx SimpleId
2 (SimpleId -> UTxOType SimpleTx
utxoRef SimpleId
2) (SimpleId -> UTxOType SimpleTx
utxoRef SimpleId
4)
            activeUTxO :: UTxOType SimpleTx
activeUTxO = [SimpleId] -> UTxOType SimpleTx
utxoRefs [SimpleId
1, SimpleId
2]
            utxoToDecommit :: Maybe (UTxOType SimpleTx)
utxoToDecommit = UTxOType SimpleTx -> Maybe (UTxOType SimpleTx)
forall a. a -> Maybe a
Just (UTxOType SimpleTx -> Maybe (UTxOType SimpleTx))
-> UTxOType SimpleTx -> Maybe (UTxOType SimpleTx)
forall a b. (a -> b) -> a -> b
$ [SimpleId] -> UTxOType SimpleTx
utxoRefs [SimpleId
3]
            snapshot :: Snapshot SimpleTx
snapshot =
              Snapshot
                { $sel:headId:Snapshot :: HeadId
headId = HeadId
testHeadId
                , $sel:version:Snapshot :: SnapshotVersion
version = SnapshotVersion
0
                , $sel:number:Snapshot :: SnapshotNumber
number = SnapshotNumber
1
                , $sel:confirmed:Snapshot :: [SimpleTx]
confirmed = []
                , $sel:utxo:Snapshot :: UTxOType SimpleTx
utxo = Set SimpleTxOut
UTxOType SimpleTx
activeUTxO
                , $sel:utxoToCommit:Snapshot :: Maybe (UTxOType SimpleTx)
utxoToCommit = Maybe (Set SimpleTxOut)
Maybe (UTxOType SimpleTx)
forall a. Maybe a
Nothing
                , $sel:utxoToDecommit:Snapshot :: Maybe (UTxOType SimpleTx)
utxoToDecommit = Maybe (Set SimpleTxOut)
Maybe (UTxOType SimpleTx)
utxoToDecommit
                , $sel:depositTxId:Snapshot :: Maybe (TxIdType SimpleTx)
depositTxId = Maybe SimpleId
Maybe (TxIdType SimpleTx)
forall a. Maybe a
Nothing
                , $sel:accumulator:Snapshot :: HydraAccumulator
accumulator = UTxOType SimpleTx
-> Maybe (UTxOType SimpleTx)
-> Maybe (UTxOType SimpleTx)
-> HydraAccumulator
forall tx.
IsTx tx =>
UTxOType tx
-> Maybe (UTxOType tx) -> Maybe (UTxOType tx) -> HydraAccumulator
Accumulator.buildFromSnapshotUTxOs Set SimpleTxOut
UTxOType SimpleTx
activeUTxO Maybe (Set SimpleTxOut)
Maybe (UTxOType SimpleTx)
forall a. Maybe a
Nothing Maybe (Set SimpleTxOut)
Maybe (UTxOType SimpleTx)
utxoToDecommit
                }
            s0 :: NodeState SimpleTx
s0 =
              [Party] -> CoordinatedHeadState SimpleTx -> NodeState SimpleTx
inOpenState'
                [Party]
threeParties
                CoordinatedHeadState SimpleTx
coordinatedHeadState
                  { confirmedSnapshot = ConfirmedSnapshot snapshot (Crypto.aggregate [])
                  , seenSnapshot = LastSeenSnapshot 1
                  , localUTxO = activeUTxO
                  }
            reqSn0 :: Input SimpleTx
reqSn0 = Party -> Message SimpleTx -> Input SimpleTx
forall tx. Party -> Message tx -> Input tx
receiveMessageFrom Party
alice (Message SimpleTx -> Input SimpleTx)
-> Message SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ SnapshotVersion
-> SnapshotNumber
-> [TxIdType SimpleTx]
-> Maybe SimpleTx
-> Maybe (TxIdType SimpleTx)
-> Message SimpleTx
forall tx.
SnapshotVersion
-> SnapshotNumber
-> [TxIdType tx]
-> Maybe tx
-> Maybe (TxIdType tx)
-> Message tx
ReqSn SnapshotVersion
0 SnapshotNumber
1 [] (SimpleTx -> Maybe SimpleTx
forall a. a -> Maybe a
Just SimpleTx
decommitTx1) Maybe SimpleId
Maybe (TxIdType SimpleTx)
forall a. Maybe a
Nothing
            reqSn1 :: Input SimpleTx
reqSn1 = Party -> Message SimpleTx -> Input SimpleTx
forall tx. Party -> Message tx -> Input tx
receiveMessageFrom Party
bob (Message SimpleTx -> Input SimpleTx)
-> Message SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ SnapshotVersion
-> SnapshotNumber
-> [TxIdType SimpleTx]
-> Maybe SimpleTx
-> Maybe (TxIdType SimpleTx)
-> Message SimpleTx
forall tx.
SnapshotVersion
-> SnapshotNumber
-> [TxIdType tx]
-> Maybe tx
-> Maybe (TxIdType tx)
-> Message tx
ReqSn SnapshotVersion
0 SnapshotNumber
2 [] (SimpleTx -> Maybe SimpleTx
forall a. a -> Maybe a
Just SimpleTx
decommitTx2) Maybe SimpleId
Maybe (TxIdType SimpleTx)
forall a. Maybe a
Nothing

        Outcome SimpleTx
outcome <- Environment
-> Ledger SimpleTx
-> NodeState SimpleTx
-> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
-> IO (Outcome SimpleTx)
forall (m :: * -> *) tx a.
Monad m =>
Environment
-> Ledger tx -> NodeState tx -> StateT (StepState tx) m a -> m a
runHeadLogic Environment
bobEnv Ledger SimpleTx
ledger NodeState SimpleTx
s0 (StateT (StepState SimpleTx) IO (Outcome SimpleTx)
 -> IO (Outcome SimpleTx))
-> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
-> IO (Outcome SimpleTx)
forall a b. (a -> b) -> a -> b
$ do
          Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step Input SimpleTx
reqSn0
          Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step Input SimpleTx
reqSn1
        Outcome SimpleTx
outcome Outcome SimpleTx -> (Outcome SimpleTx -> Bool) -> IO ()
forall a. (HasCallStack, Show a) => a -> (a -> Bool) -> IO ()
`shouldSatisfy` \case
          Error RequireFailed{RequirementFailure SimpleTx
requirementFailure :: RequirementFailure SimpleTx
$sel:requirementFailure:UnhandledInput :: forall tx. LogicError tx -> RequirementFailure tx
requirementFailure} | RequirementFailure SimpleTx
requirementFailure RequirementFailure SimpleTx -> RequirementFailure SimpleTx -> Bool
forall a. Eq a => a -> a -> Bool
== RequirementFailure SimpleTx
forall tx. RequirementFailure tx
ReqSnDecommitNotSettled -> Bool
True
          Outcome SimpleTx
_ -> Bool
False

      String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Deposit after rollback" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
        let singleParty :: [Party]
singleParty = [Party
alice]
            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

        String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"ReqSn still references stale currentDepositTxId after deposit is recovered" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
          -- This test reproduced the bug where:
          -- 1. A deposit is included in a snapshot (setting currentDepositTxId in local state)
          -- 2. The IncrementTx is posted on-chain
          -- 3. A chain rollback erases the IncrementTx observation
          -- 4. The deposit is recovered on-chain (removed from pendingDeposits)
          -- 5. The stale currentDepositTxId causes future ReqSn to reference a
          --    deposit that no longer exists, leading to infinite WaitOnDepositObserved
          UTCTime
now <- IO UTCTime
forall (m :: * -> *). MonadTime m => m UTCTime
getCurrentTime
          let aliceEnv' :: Environment
aliceEnv' =
                Environment
aliceEnv
                  { depositPeriod = 60
                  , depositActivation = 60
                  , contestationPeriod = 60
                  , otherParties = []
                  , participants = deriveOnChainId <$> [alice]
                  }
          let depositTime :: NominalDiffTime -> UTCTime
depositTime = UTCTime -> NominalDiffTime -> UTCTime
plusTime UTCTime
now
              deadline :: UTCTime
deadline = NominalDiffTime -> UTCTime
depositTime NominalDiffTime
600
              depositTxId :: SimpleId
depositTxId = SimpleId
42 :: Integer
              depositedUtxo :: UTxOType SimpleTx
depositedUtxo = SimpleId -> UTxOType SimpleTx
utxoRef SimpleId
depositTxId
              deposit :: OnChainTx SimpleTx
deposit =
                OnDepositTx
                  { $sel:headId:OnInitTx :: HeadId
headId = HeadId
testHeadId
                  , SimpleId
TxIdType SimpleTx
$sel:depositTxId:OnInitTx :: TxIdType SimpleTx
depositTxId :: SimpleId
depositTxId
                  , $sel:deposited:OnInitTx :: UTxOType SimpleTx
deposited = Set SimpleTxOut
UTxOType SimpleTx
depositedUtxo
                  , $sel:created:OnInitTx :: UTCTime
created = NominalDiffTime -> UTCTime
depositTime NominalDiffTime
1
                  , UTCTime
$sel:deadline:OnInitTx :: UTCTime
deadline :: UTCTime
deadline
                  }

          -- Step 1: Start in open state, observe deposit
          NodeState SimpleTx
s1 <- Environment
-> Ledger SimpleTx
-> NodeState SimpleTx
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall (m :: * -> *) tx a.
Monad m =>
Environment
-> Ledger tx -> NodeState tx -> StateT (StepState tx) m a -> m a
runHeadLogic Environment
aliceEnv' Ledger SimpleTx
ledger ([Party] -> NodeState SimpleTx
inOpenState [Party]
singleParty) (StateT (StepState SimpleTx) IO (NodeState SimpleTx)
 -> IO (NodeState SimpleTx))
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall a b. (a -> b) -> a -> b
$ do
            Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step (ChainSlot -> OnChainTx SimpleTx -> Input SimpleTx
observeTxAtSlot ChainSlot
1 OnChainTx SimpleTx
deposit)
            StateT (StepState SimpleTx) IO (NodeState SimpleTx)
forall tx (m :: * -> *).
MonadState (StepState tx) m =>
m (NodeState tx)
getState

          -- Step 2: Tick to activate deposit and trigger ReqSn
          let chainTime :: UTCTime
chainTime = NominalDiffTime -> UTCTime
depositTime NominalDiffTime
2 UTCTime -> NominalDiffTime -> UTCTime
`plusTime` DepositPeriod -> NominalDiffTime
toNominalDiffTime Environment
aliceEnv'.depositPeriod
              tickInput :: Input SimpleTx
tickInput = ChainEvent SimpleTx -> Input SimpleTx
forall tx. ChainEvent tx -> Input tx
ChainInput (ChainEvent SimpleTx -> Input SimpleTx)
-> ChainEvent SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ Tick{UTCTime
$sel:chainTime:Observation :: UTCTime
chainTime :: UTCTime
chainTime, $sel:chainPoint:Observation :: ChainPointType SimpleTx
chainPoint = ChainPointType SimpleTx
2}
          NodeState SimpleTx
s2 <- Environment
-> Ledger SimpleTx
-> NodeState SimpleTx
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall (m :: * -> *) tx a.
Monad m =>
Environment
-> Ledger tx -> NodeState tx -> StateT (StepState tx) m a -> m a
runHeadLogic Environment
aliceEnv' Ledger SimpleTx
ledger NodeState SimpleTx
s1 (StateT (StepState SimpleTx) IO (NodeState SimpleTx)
 -> IO (NodeState SimpleTx))
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall a b. (a -> b) -> a -> b
$ do
            Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step Input SimpleTx
tickInput
            StateT (StepState SimpleTx) IO (NodeState SimpleTx)
forall tx (m :: * -> *).
MonadState (StepState tx) m =>
m (NodeState tx)
getState

          -- Verify deposit is now active. DepositActivated queues the deposit
          -- immediately into currentDepositTxId (via <|> in the aggregate).
          case NodeState SimpleTx -> HeadState SimpleTx
forall tx. NodeState tx -> HeadState tx
headState NodeState SimpleTx
s2 of
            Open OpenState{$sel:coordinatedHeadState:OpenState :: forall tx. OpenState tx -> CoordinatedHeadState tx
coordinatedHeadState = CoordinatedHeadState{Maybe (TxIdType SimpleTx)
$sel:currentDepositTxId:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> Maybe (TxIdType tx)
currentDepositTxId :: Maybe (TxIdType SimpleTx)
currentDepositTxId}} ->
              Maybe SimpleId
Maybe (TxIdType SimpleTx)
currentDepositTxId Maybe SimpleId -> Maybe SimpleId -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` SimpleId -> Maybe SimpleId
forall a. a -> Maybe a
Just SimpleId
depositTxId
            HeadState SimpleTx
other -> HasCallStack => String -> IO ()
String -> IO ()
expectationFailure (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Expected Open state, got: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> HeadState SimpleTx -> String
forall b a. (Show a, IsString b) => a -> b
show HeadState SimpleTx
other

          -- Step 3: Process ReqSn with the deposit (as if received from network)
          let reqSnWithDeposit :: Input SimpleTx
reqSnWithDeposit = Message SimpleTx -> Input SimpleTx
forall tx. Message tx -> Input tx
receiveMessage (Message SimpleTx -> Input SimpleTx)
-> Message SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ SnapshotVersion
-> SnapshotNumber
-> [TxIdType SimpleTx]
-> Maybe SimpleTx
-> Maybe (TxIdType SimpleTx)
-> Message SimpleTx
forall tx.
SnapshotVersion
-> SnapshotNumber
-> [TxIdType tx]
-> Maybe tx
-> Maybe (TxIdType tx)
-> Message tx
ReqSn SnapshotVersion
0 SnapshotNumber
1 [] Maybe SimpleTx
forall a. Maybe a
Nothing (SimpleId -> Maybe SimpleId
forall a. a -> Maybe a
Just SimpleId
depositTxId)
          NodeState SimpleTx
s3 <- Environment
-> Ledger SimpleTx
-> NodeState SimpleTx
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall (m :: * -> *) tx a.
Monad m =>
Environment
-> Ledger tx -> NodeState tx -> StateT (StepState tx) m a -> m a
runHeadLogic Environment
aliceEnv' Ledger SimpleTx
ledger NodeState SimpleTx
s2 (StateT (StepState SimpleTx) IO (NodeState SimpleTx)
 -> IO (NodeState SimpleTx))
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall a b. (a -> b) -> a -> b
$ do
            Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step Input SimpleTx
reqSnWithDeposit
            StateT (StepState SimpleTx) IO (NodeState SimpleTx)
forall tx (m :: * -> *).
MonadState (StepState tx) m =>
m (NodeState tx)
getState

          -- Verify currentDepositTxId is now set
          case NodeState SimpleTx -> HeadState SimpleTx
forall tx. NodeState tx -> HeadState tx
headState NodeState SimpleTx
s3 of
            Open OpenState{$sel:coordinatedHeadState:OpenState :: forall tx. OpenState tx -> CoordinatedHeadState tx
coordinatedHeadState = CoordinatedHeadState{Maybe (TxIdType SimpleTx)
$sel:currentDepositTxId:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> Maybe (TxIdType tx)
currentDepositTxId :: Maybe (TxIdType SimpleTx)
currentDepositTxId}} ->
              Maybe SimpleId
Maybe (TxIdType SimpleTx)
currentDepositTxId Maybe SimpleId -> Maybe SimpleId -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` SimpleId -> Maybe SimpleId
forall a. a -> Maybe a
Just SimpleId
depositTxId
            HeadState SimpleTx
other -> HasCallStack => String -> IO ()
String -> IO ()
expectationFailure (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Expected Open state, got: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> HeadState SimpleTx -> String
forall b a. (Show a, IsString b) => a -> b
show HeadState SimpleTx
other

          -- Step 4: AckSn from alice (single party) → SnapshotConfirmed + CommitApproved + IncrementTx posted
          let snapshot1 :: Snapshot SimpleTx
snapshot1 =
                Snapshot
                  { $sel:headId:Snapshot :: HeadId
headId = HeadId
testHeadId
                  , $sel:version:Snapshot :: SnapshotVersion
version = SnapshotVersion
0
                  , $sel:number:Snapshot :: SnapshotNumber
number = SnapshotNumber
1
                  , $sel:confirmed:Snapshot :: [SimpleTx]
confirmed = []
                  , $sel:utxo:Snapshot :: UTxOType SimpleTx
utxo = UTxOType SimpleTx
forall a. Monoid a => a
mempty
                  , $sel:utxoToCommit:Snapshot :: Maybe (UTxOType SimpleTx)
utxoToCommit = Set SimpleTxOut -> Maybe (Set SimpleTxOut)
forall a. a -> Maybe a
Just Set SimpleTxOut
depositedUtxo
                  , $sel:utxoToDecommit:Snapshot :: Maybe (UTxOType SimpleTx)
utxoToDecommit = Maybe (Set SimpleTxOut)
Maybe (UTxOType SimpleTx)
forall a. Maybe a
Nothing
                  , $sel:depositTxId:Snapshot :: Maybe (TxIdType SimpleTx)
depositTxId = SimpleId -> Maybe SimpleId
forall a. a -> Maybe a
Just SimpleId
depositTxId
                  , $sel:accumulator:Snapshot :: HydraAccumulator
accumulator = UTxOType SimpleTx
-> Maybe (UTxOType SimpleTx)
-> Maybe (UTxOType SimpleTx)
-> HydraAccumulator
forall tx.
IsTx tx =>
UTxOType tx
-> Maybe (UTxOType tx) -> Maybe (UTxOType tx) -> HydraAccumulator
Accumulator.buildFromSnapshotUTxOs UTxOType SimpleTx
forall a. Monoid a => a
mempty (Set SimpleTxOut -> Maybe (Set SimpleTxOut)
forall a. a -> Maybe a
Just Set SimpleTxOut
depositedUtxo) Maybe (Set SimpleTxOut)
Maybe (UTxOType SimpleTx)
forall a. Maybe a
Nothing
                  }
              ackSn :: Input SimpleTx
ackSn = Message SimpleTx -> Input SimpleTx
forall tx. Message tx -> Input tx
receiveMessage (Message SimpleTx -> Input SimpleTx)
-> Message SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ Signature (Snapshot SimpleTx) -> SnapshotNumber -> Message SimpleTx
forall tx. Signature (Snapshot tx) -> SnapshotNumber -> Message tx
AckSn (Secret (SigningKey HydraKey)
-> Snapshot SimpleTx -> Signature (Snapshot SimpleTx)
forall a.
SignableRepresentation a =>
Secret (SigningKey HydraKey) -> a -> Signature a
sign Secret (SigningKey HydraKey)
aliceSk Snapshot SimpleTx
snapshot1) SnapshotNumber
1
          NodeState SimpleTx
s4 <- Environment
-> Ledger SimpleTx
-> NodeState SimpleTx
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall (m :: * -> *) tx a.
Monad m =>
Environment
-> Ledger tx -> NodeState tx -> StateT (StepState tx) m a -> m a
runHeadLogic Environment
aliceEnv' Ledger SimpleTx
ledger NodeState SimpleTx
s3 (StateT (StepState SimpleTx) IO (NodeState SimpleTx)
 -> IO (NodeState SimpleTx))
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall a b. (a -> b) -> a -> b
$ do
            Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step Input SimpleTx
ackSn
            StateT (StepState SimpleTx) IO (NodeState SimpleTx)
forall tx (m :: * -> *).
MonadState (StepState tx) m =>
m (NodeState tx)
getState

          -- Verify SnapshotConfirmed happened and currentDepositTxId is still set
          case NodeState SimpleTx -> HeadState SimpleTx
forall tx. NodeState tx -> HeadState tx
headState NodeState SimpleTx
s4 of
            Open OpenState{$sel:coordinatedHeadState:OpenState :: forall tx. OpenState tx -> CoordinatedHeadState tx
coordinatedHeadState = CoordinatedHeadState{Maybe (TxIdType SimpleTx)
$sel:currentDepositTxId:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> Maybe (TxIdType tx)
currentDepositTxId :: Maybe (TxIdType SimpleTx)
currentDepositTxId, ConfirmedSnapshot SimpleTx
$sel:confirmedSnapshot:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> ConfirmedSnapshot tx
confirmedSnapshot :: ConfirmedSnapshot SimpleTx
confirmedSnapshot}} -> do
              Maybe SimpleId
Maybe (TxIdType SimpleTx)
currentDepositTxId Maybe SimpleId -> Maybe SimpleId -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` SimpleId -> Maybe SimpleId
forall a. a -> Maybe a
Just SimpleId
depositTxId
              case ConfirmedSnapshot SimpleTx
confirmedSnapshot of
                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 SnapshotNumber -> SnapshotNumber -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` SnapshotNumber
1
                ConfirmedSnapshot SimpleTx
_ -> HasCallStack => String -> IO ()
String -> IO ()
expectationFailure String
"Expected ConfirmedSnapshot"
            HeadState SimpleTx
other -> HasCallStack => String -> IO ()
String -> IO ()
expectationFailure (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Expected Open state, got: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> HeadState SimpleTx -> String
forall b a. (Show a, IsString b) => a -> b
show HeadState SimpleTx
other

          -- Step 5: Chain rollback (erases the IncrementTx observation)
          let rollbackInput :: Input SimpleTx
rollbackInput = ChainEvent SimpleTx -> Input SimpleTx
forall tx. ChainEvent tx -> Input tx
ChainInput Rollback{$sel:rolledBackChainState:Observation :: ChainStateType SimpleTx
rolledBackChainState = ChainSlot -> SimpleChainState
SimpleChainState ChainSlot
0, $sel:chainTime:Observation :: UTCTime
chainTime = UTCTime
now}
          NodeState SimpleTx
s5 <- Environment
-> Ledger SimpleTx
-> NodeState SimpleTx
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall (m :: * -> *) tx a.
Monad m =>
Environment
-> Ledger tx -> NodeState tx -> StateT (StepState tx) m a -> m a
runHeadLogic Environment
aliceEnv' Ledger SimpleTx
ledger NodeState SimpleTx
s4 (StateT (StepState SimpleTx) IO (NodeState SimpleTx)
 -> IO (NodeState SimpleTx))
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall a b. (a -> b) -> a -> b
$ do
            Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step Input SimpleTx
rollbackInput
            StateT (StepState SimpleTx) IO (NodeState SimpleTx)
forall tx (m :: * -> *).
MonadState (StepState tx) m =>
m (NodeState tx)
getState

          -- currentDepositTxId should still be set (this is part of the bug)
          case NodeState SimpleTx -> HeadState SimpleTx
forall tx. NodeState tx -> HeadState tx
headState NodeState SimpleTx
s5 of
            Open OpenState{$sel:coordinatedHeadState:OpenState :: forall tx. OpenState tx -> CoordinatedHeadState tx
coordinatedHeadState = CoordinatedHeadState{Maybe (TxIdType SimpleTx)
$sel:currentDepositTxId:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> Maybe (TxIdType tx)
currentDepositTxId :: Maybe (TxIdType SimpleTx)
currentDepositTxId}} ->
              Maybe SimpleId
Maybe (TxIdType SimpleTx)
currentDepositTxId Maybe SimpleId -> Maybe SimpleId -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` SimpleId -> Maybe SimpleId
forall a. a -> Maybe a
Just SimpleId
depositTxId
            HeadState SimpleTx
other -> HasCallStack => String -> IO ()
String -> IO ()
expectationFailure (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Expected Open state, got: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> HeadState SimpleTx -> String
forall b a. (Show a, IsString b) => a -> b
show HeadState SimpleTx
other

          -- Step 6: Deposit is recovered on-chain (removed from pendingDeposits)
          let recoverInput :: Input SimpleTx
recoverInput =
                ChainSlot -> OnChainTx SimpleTx -> Input SimpleTx
observeTxAtSlot
                  ChainSlot
2
                  OnRecoverTx
                    { $sel:headId:OnInitTx :: HeadId
headId = HeadId
testHeadId
                    , $sel:recoveredTxId:OnInitTx :: TxIdType SimpleTx
recoveredTxId = SimpleId
TxIdType SimpleTx
depositTxId
                    , $sel:recoveredUTxO:OnInitTx :: UTxOType SimpleTx
recoveredUTxO = Set SimpleTxOut
UTxOType SimpleTx
depositedUtxo
                    }
          NodeState SimpleTx
s6 <- Environment
-> Ledger SimpleTx
-> NodeState SimpleTx
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall (m :: * -> *) tx a.
Monad m =>
Environment
-> Ledger tx -> NodeState tx -> StateT (StepState tx) m a -> m a
runHeadLogic Environment
aliceEnv' Ledger SimpleTx
ledger NodeState SimpleTx
s5 (StateT (StepState SimpleTx) IO (NodeState SimpleTx)
 -> IO (NodeState SimpleTx))
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall a b. (a -> b) -> a -> b
$ do
            Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step Input SimpleTx
recoverInput
            StateT (StepState SimpleTx) IO (NodeState SimpleTx)
forall tx (m :: * -> *).
MonadState (StepState tx) m =>
m (NodeState tx)
getState

          -- Verify that deposit was removed from pendingDeposits after recover (fix for the bug)
          case NodeState SimpleTx -> HeadState SimpleTx
forall tx. NodeState tx -> HeadState tx
headState NodeState SimpleTx
s6 of
            Open OpenState{$sel:coordinatedHeadState:OpenState :: forall tx. OpenState tx -> CoordinatedHeadState tx
coordinatedHeadState = CoordinatedHeadState{Maybe (TxIdType SimpleTx)
$sel:currentDepositTxId:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> Maybe (TxIdType tx)
currentDepositTxId :: Maybe (TxIdType SimpleTx)
currentDepositTxId}} ->
              Maybe SimpleId
Maybe (TxIdType SimpleTx)
currentDepositTxId Maybe SimpleId -> Maybe SimpleId -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Maybe SimpleId
forall a. Maybe a
Nothing
            HeadState SimpleTx
other -> HasCallStack => String -> IO ()
String -> IO ()
expectationFailure (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Expected Open state, got: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> HeadState SimpleTx -> String
forall b a. (Show a, IsString b) => a -> b
show HeadState SimpleTx
other

          SimpleId
-> Map SimpleId (Deposit SimpleTx) -> Maybe (Deposit SimpleTx)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup SimpleId
depositTxId NodeState SimpleTx
s6.pendingDeposits Maybe (Deposit SimpleTx) -> Maybe (Deposit SimpleTx) -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Maybe (Deposit SimpleTx)
forall a. Maybe a
Nothing

          -- Step 7: New transaction arrives, leader creates new ReqSn
          let newTx :: SimpleTx
newTx = SimpleId -> SimpleTx
aValidTx SimpleId
1
          let reqTxInput :: Input SimpleTx
reqTxInput = Message SimpleTx -> Input SimpleTx
forall tx. Message tx -> Input tx
receiveMessage (Message SimpleTx -> Input SimpleTx)
-> Message SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ SimpleTx -> Message SimpleTx
forall tx. tx -> Message tx
ReqTx SimpleTx
newTx

          let outcome :: Outcome SimpleTx
outcome = Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
aliceEnv' Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
s6 Input SimpleTx
reqTxInput

          -- The ReqSn emitted by the leader does not reference the recovered deposit
          Outcome SimpleTx
outcome Outcome SimpleTx -> (Effect SimpleTx -> Bool) -> IO ()
forall tx.
(HasCallStack, IsChainState tx) =>
Outcome tx -> (Effect tx -> Bool) -> IO ()
`hasEffectSatisfying` \case
            NetworkEffect ReqSn{$sel:depositTxId:ReqTx :: forall tx. Message tx -> Maybe (TxIdType tx)
depositTxId = Maybe (TxIdType SimpleTx)
reqDepositTxId} ->
              Maybe SimpleId -> Bool
forall a. Maybe a -> Bool
isNothing Maybe SimpleId
Maybe (TxIdType SimpleTx)
reqDepositTxId
            Effect SimpleTx
_ -> Bool
False

          -- Step 8: When node processes this ReqSn, it will wait forever
          NodeState SimpleTx
s7 <- Environment
-> Ledger SimpleTx
-> NodeState SimpleTx
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall (m :: * -> *) tx a.
Monad m =>
Environment
-> Ledger tx -> NodeState tx -> StateT (StepState tx) m a -> m a
runHeadLogic Environment
aliceEnv' Ledger SimpleTx
ledger NodeState SimpleTx
s6 (StateT (StepState SimpleTx) IO (NodeState SimpleTx)
 -> IO (NodeState SimpleTx))
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall a b. (a -> b) -> a -> b
$ do
            Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step Input SimpleTx
reqTxInput
            StateT (StepState SimpleTx) IO (NodeState SimpleTx)
forall tx (m :: * -> *).
MonadState (StepState tx) m =>
m (NodeState tx)
getState

          let staleReqSn :: Input SimpleTx
staleReqSn = Message SimpleTx -> Input SimpleTx
forall tx. Message tx -> Input tx
receiveMessage (Message SimpleTx -> Input SimpleTx)
-> Message SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ SnapshotVersion
-> SnapshotNumber
-> [TxIdType SimpleTx]
-> Maybe SimpleTx
-> Maybe (TxIdType SimpleTx)
-> Message SimpleTx
forall tx.
SnapshotVersion
-> SnapshotNumber
-> [TxIdType tx]
-> Maybe tx
-> Maybe (TxIdType tx)
-> Message tx
ReqSn SnapshotVersion
0 SnapshotNumber
2 [SimpleTx -> TxIdType SimpleTx
forall tx. IsTx tx => tx -> TxIdType tx
txId SimpleTx
newTx] Maybe SimpleTx
forall a. Maybe a
Nothing (SimpleId -> Maybe SimpleId
forall a. a -> Maybe a
Just SimpleId
depositTxId)
          let reqSnOutcome :: Outcome SimpleTx
reqSnOutcome = Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
aliceEnv' Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
s7 Input SimpleTx
staleReqSn
          -- Fix bug: Error out instead of waiting for deposit to be observed forever
          Outcome SimpleTx
reqSnOutcome Outcome SimpleTx -> Outcome SimpleTx -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` LogicError SimpleTx -> Outcome SimpleTx
forall tx. LogicError tx -> Outcome tx
Error (RequirementFailure SimpleTx -> LogicError SimpleTx
forall tx. RequirementFailure tx -> LogicError tx
RequireFailed (RequirementFailure SimpleTx -> LogicError SimpleTx)
-> RequirementFailure SimpleTx -> LogicError SimpleTx
forall a b. (a -> b) -> a -> b
$ TxIdType SimpleTx -> RequirementFailure SimpleTx
forall tx. TxIdType tx -> RequirementFailure tx
RequestedDepositNotFoundLocally SimpleId
TxIdType SimpleTx
depositTxId)

        String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"re-posts IncrementTx on chain rollback when deposit is pending" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
          -- After a snapshot is confirmed with a deposit (CommitApproved + IncrementTx posted),
          -- if a chain rollback occurs, the node should re-post the IncrementTx because
          -- the rollback may have erased the original on-chain observation.
          UTCTime
now <- IO UTCTime
forall (m :: * -> *). MonadTime m => m UTCTime
getCurrentTime
          let aliceEnv' :: Environment
aliceEnv' =
                Environment
aliceEnv
                  { depositPeriod = 60
                  , depositActivation = 60
                  , contestationPeriod = 60
                  , otherParties = []
                  , participants = deriveOnChainId <$> [alice]
                  }
          let depositTime :: NominalDiffTime -> UTCTime
depositTime = UTCTime -> NominalDiffTime -> UTCTime
plusTime UTCTime
now
              deadline :: UTCTime
deadline = NominalDiffTime -> UTCTime
depositTime NominalDiffTime
600
              depositTxId :: SimpleId
depositTxId = SimpleId
42 :: Integer
              depositedUtxo :: UTxOType SimpleTx
depositedUtxo = SimpleId -> UTxOType SimpleTx
utxoRef SimpleId
depositTxId
              deposit :: OnChainTx SimpleTx
deposit =
                OnDepositTx
                  { $sel:headId:OnInitTx :: HeadId
headId = HeadId
testHeadId
                  , SimpleId
TxIdType SimpleTx
$sel:depositTxId:OnInitTx :: TxIdType SimpleTx
depositTxId :: SimpleId
depositTxId
                  , $sel:deposited:OnInitTx :: UTxOType SimpleTx
deposited = Set SimpleTxOut
UTxOType SimpleTx
depositedUtxo
                  , $sel:created:OnInitTx :: UTCTime
created = NominalDiffTime -> UTCTime
depositTime NominalDiffTime
1
                  , UTCTime
$sel:deadline:OnInitTx :: UTCTime
deadline :: UTCTime
deadline
                  }

          -- Observe deposit, activate it via tick, process ReqSn and AckSn
          -- to reach a state where CommitApproved happened and IncrementTx was posted
          NodeState SimpleTx
s1 <- Environment
-> Ledger SimpleTx
-> NodeState SimpleTx
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall (m :: * -> *) tx a.
Monad m =>
Environment
-> Ledger tx -> NodeState tx -> StateT (StepState tx) m a -> m a
runHeadLogic Environment
aliceEnv' Ledger SimpleTx
ledger ([Party] -> NodeState SimpleTx
inOpenState [Party]
singleParty) (StateT (StepState SimpleTx) IO (NodeState SimpleTx)
 -> IO (NodeState SimpleTx))
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall a b. (a -> b) -> a -> b
$ do
            Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step (ChainSlot -> OnChainTx SimpleTx -> Input SimpleTx
observeTxAtSlot ChainSlot
1 OnChainTx SimpleTx
deposit)
            StateT (StepState SimpleTx) IO (NodeState SimpleTx)
forall tx (m :: * -> *).
MonadState (StepState tx) m =>
m (NodeState tx)
getState

          let chainTime :: UTCTime
chainTime = NominalDiffTime -> UTCTime
depositTime NominalDiffTime
2 UTCTime -> NominalDiffTime -> UTCTime
`plusTime` DepositPeriod -> NominalDiffTime
toNominalDiffTime Environment
aliceEnv'.depositPeriod
              tickInput :: Input SimpleTx
tickInput = ChainEvent SimpleTx -> Input SimpleTx
forall tx. ChainEvent tx -> Input tx
ChainInput (ChainEvent SimpleTx -> Input SimpleTx)
-> ChainEvent SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ Tick{UTCTime
$sel:chainTime:Observation :: UTCTime
chainTime :: UTCTime
chainTime, $sel:chainPoint:Observation :: ChainPointType SimpleTx
chainPoint = ChainPointType SimpleTx
2}
          NodeState SimpleTx
s2 <- Environment
-> Ledger SimpleTx
-> NodeState SimpleTx
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall (m :: * -> *) tx a.
Monad m =>
Environment
-> Ledger tx -> NodeState tx -> StateT (StepState tx) m a -> m a
runHeadLogic Environment
aliceEnv' Ledger SimpleTx
ledger NodeState SimpleTx
s1 (StateT (StepState SimpleTx) IO (NodeState SimpleTx)
 -> IO (NodeState SimpleTx))
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall a b. (a -> b) -> a -> b
$ do
            Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step Input SimpleTx
tickInput
            StateT (StepState SimpleTx) IO (NodeState SimpleTx)
forall tx (m :: * -> *).
MonadState (StepState tx) m =>
m (NodeState tx)
getState

          let reqSnWithDeposit :: Input SimpleTx
reqSnWithDeposit = Message SimpleTx -> Input SimpleTx
forall tx. Message tx -> Input tx
receiveMessage (Message SimpleTx -> Input SimpleTx)
-> Message SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ SnapshotVersion
-> SnapshotNumber
-> [TxIdType SimpleTx]
-> Maybe SimpleTx
-> Maybe (TxIdType SimpleTx)
-> Message SimpleTx
forall tx.
SnapshotVersion
-> SnapshotNumber
-> [TxIdType tx]
-> Maybe tx
-> Maybe (TxIdType tx)
-> Message tx
ReqSn SnapshotVersion
0 SnapshotNumber
1 [] Maybe SimpleTx
forall a. Maybe a
Nothing (SimpleId -> Maybe SimpleId
forall a. a -> Maybe a
Just SimpleId
depositTxId)
          NodeState SimpleTx
s3 <- Environment
-> Ledger SimpleTx
-> NodeState SimpleTx
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall (m :: * -> *) tx a.
Monad m =>
Environment
-> Ledger tx -> NodeState tx -> StateT (StepState tx) m a -> m a
runHeadLogic Environment
aliceEnv' Ledger SimpleTx
ledger NodeState SimpleTx
s2 (StateT (StepState SimpleTx) IO (NodeState SimpleTx)
 -> IO (NodeState SimpleTx))
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall a b. (a -> b) -> a -> b
$ do
            Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step Input SimpleTx
reqSnWithDeposit
            StateT (StepState SimpleTx) IO (NodeState SimpleTx)
forall tx (m :: * -> *).
MonadState (StepState tx) m =>
m (NodeState tx)
getState

          let snapshot1 :: Snapshot SimpleTx
snapshot1 =
                Snapshot
                  { $sel:headId:Snapshot :: HeadId
headId = HeadId
testHeadId
                  , $sel:version:Snapshot :: SnapshotVersion
version = SnapshotVersion
0
                  , $sel:number:Snapshot :: SnapshotNumber
number = SnapshotNumber
1
                  , $sel:confirmed:Snapshot :: [SimpleTx]
confirmed = []
                  , $sel:utxo:Snapshot :: UTxOType SimpleTx
utxo = UTxOType SimpleTx
forall a. Monoid a => a
mempty
                  , $sel:utxoToCommit:Snapshot :: Maybe (UTxOType SimpleTx)
utxoToCommit = Set SimpleTxOut -> Maybe (Set SimpleTxOut)
forall a. a -> Maybe a
Just Set SimpleTxOut
depositedUtxo
                  , $sel:utxoToDecommit:Snapshot :: Maybe (UTxOType SimpleTx)
utxoToDecommit = Maybe (Set SimpleTxOut)
Maybe (UTxOType SimpleTx)
forall a. Maybe a
Nothing
                  , $sel:depositTxId:Snapshot :: Maybe (TxIdType SimpleTx)
depositTxId = SimpleId -> Maybe SimpleId
forall a. a -> Maybe a
Just SimpleId
depositTxId
                  , $sel:accumulator:Snapshot :: HydraAccumulator
accumulator = UTxOType SimpleTx
-> Maybe (UTxOType SimpleTx)
-> Maybe (UTxOType SimpleTx)
-> HydraAccumulator
forall tx.
IsTx tx =>
UTxOType tx
-> Maybe (UTxOType tx) -> Maybe (UTxOType tx) -> HydraAccumulator
Accumulator.buildFromSnapshotUTxOs UTxOType SimpleTx
forall a. Monoid a => a
mempty (Set SimpleTxOut -> Maybe (Set SimpleTxOut)
forall a. a -> Maybe a
Just Set SimpleTxOut
depositedUtxo) Maybe (Set SimpleTxOut)
Maybe (UTxOType SimpleTx)
forall a. Maybe a
Nothing
                  }
              ackSn :: Input SimpleTx
ackSn = Message SimpleTx -> Input SimpleTx
forall tx. Message tx -> Input tx
receiveMessage (Message SimpleTx -> Input SimpleTx)
-> Message SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ Signature (Snapshot SimpleTx) -> SnapshotNumber -> Message SimpleTx
forall tx. Signature (Snapshot tx) -> SnapshotNumber -> Message tx
AckSn (Secret (SigningKey HydraKey)
-> Snapshot SimpleTx -> Signature (Snapshot SimpleTx)
forall a.
SignableRepresentation a =>
Secret (SigningKey HydraKey) -> a -> Signature a
sign Secret (SigningKey HydraKey)
aliceSk Snapshot SimpleTx
snapshot1) SnapshotNumber
1
          NodeState SimpleTx
s4 <- Environment
-> Ledger SimpleTx
-> NodeState SimpleTx
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall (m :: * -> *) tx a.
Monad m =>
Environment
-> Ledger tx -> NodeState tx -> StateT (StepState tx) m a -> m a
runHeadLogic Environment
aliceEnv' Ledger SimpleTx
ledger NodeState SimpleTx
s3 (StateT (StepState SimpleTx) IO (NodeState SimpleTx)
 -> IO (NodeState SimpleTx))
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall a b. (a -> b) -> a -> b
$ do
            Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step Input SimpleTx
ackSn
            StateT (StepState SimpleTx) IO (NodeState SimpleTx)
forall tx (m :: * -> *).
MonadState (StepState tx) m =>
m (NodeState tx)
getState

          -- Verify we are in the expected state: currentDepositTxId set, snapshot confirmed
          case NodeState SimpleTx -> HeadState SimpleTx
forall tx. NodeState tx -> HeadState tx
headState NodeState SimpleTx
s4 of
            Open OpenState{$sel:coordinatedHeadState:OpenState :: forall tx. OpenState tx -> CoordinatedHeadState tx
coordinatedHeadState = CoordinatedHeadState{Maybe (TxIdType SimpleTx)
$sel:currentDepositTxId:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> Maybe (TxIdType tx)
currentDepositTxId :: Maybe (TxIdType SimpleTx)
currentDepositTxId, ConfirmedSnapshot SimpleTx
$sel:confirmedSnapshot:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> ConfirmedSnapshot tx
confirmedSnapshot :: ConfirmedSnapshot SimpleTx
confirmedSnapshot}} -> do
              Maybe SimpleId
Maybe (TxIdType SimpleTx)
currentDepositTxId Maybe SimpleId -> Maybe SimpleId -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` SimpleId -> Maybe SimpleId
forall a. a -> Maybe a
Just SimpleId
depositTxId
              case ConfirmedSnapshot SimpleTx
confirmedSnapshot of
                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 SnapshotNumber -> SnapshotNumber -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` SnapshotNumber
1
                ConfirmedSnapshot SimpleTx
_ -> HasCallStack => String -> IO ()
String -> IO ()
expectationFailure String
"Expected ConfirmedSnapshot"
            HeadState SimpleTx
other -> HasCallStack => String -> IO ()
String -> IO ()
expectationFailure (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Expected Open state, got: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> HeadState SimpleTx -> String
forall b a. (Show a, IsString b) => a -> b
show HeadState SimpleTx
other

          -- Chain rollback should re-post the IncrementTx
          let rollbackInput :: Input SimpleTx
rollbackInput = ChainEvent SimpleTx -> Input SimpleTx
forall tx. ChainEvent tx -> Input tx
ChainInput Rollback{$sel:rolledBackChainState:Observation :: ChainStateType SimpleTx
rolledBackChainState = ChainSlot -> SimpleChainState
SimpleChainState ChainSlot
0, $sel:chainTime:Observation :: UTCTime
chainTime = UTCTime
now}
          let rollbackOutcome :: Outcome SimpleTx
rollbackOutcome = Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
aliceEnv' Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
s4 Input SimpleTx
rollbackInput

          Outcome SimpleTx
rollbackOutcome Outcome SimpleTx -> (Effect SimpleTx -> Bool) -> IO ()
forall tx.
(HasCallStack, IsChainState tx) =>
Outcome tx -> (Effect tx -> Bool) -> IO ()
`hasEffectSatisfying` \case
            OnChainEffect{PostChainTx SimpleTx
$sel:postChainTx:ClientEffect :: forall tx. Effect tx -> PostChainTx tx
postChainTx :: PostChainTx SimpleTx
postChainTx} ->
              case PostChainTx SimpleTx
postChainTx of
                IncrementTx{} -> Bool
True
                PostChainTx SimpleTx
_ -> Bool
False
            Effect SimpleTx
_ -> Bool
False

        String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"re-posts DecrementTx on chain rollback when decommit is pending" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
          -- After a snapshot is confirmed with a decommit (DecommitApproved + DecrementTx posted),
          -- if a chain rollback occurs, the node should re-post the DecrementTx because
          -- the rollback may have erased the original on-chain observation.
          UTCTime
now <- IO UTCTime
forall (m :: * -> *). MonadTime m => m UTCTime
getCurrentTime
          let aliceEnv' :: Environment
aliceEnv' =
                Environment
aliceEnv
                  { depositPeriod = 60
                  , depositActivation = 60
                  , contestationPeriod = 60
                  , otherParties = []
                  , participants = deriveOnChainId <$> [alice]
                  }

          -- NOTE: The simple ledger does not check inputs if none present.
          let decommitTx' :: SimpleTx
decommitTx' = SimpleId -> SimpleTx
aValidTx SimpleId
3
              s0 :: NodeState SimpleTx
s0 = [Party] -> NodeState SimpleTx
inOpenState [Party]
singleParty

          -- Step 1: Submit decommit request
          NodeState SimpleTx
s1 <- Environment
-> Ledger SimpleTx
-> NodeState SimpleTx
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall (m :: * -> *) tx a.
Monad m =>
Environment
-> Ledger tx -> NodeState tx -> StateT (StepState tx) m a -> m a
runHeadLogic Environment
aliceEnv' Ledger SimpleTx
ledger NodeState SimpleTx
s0 (StateT (StepState SimpleTx) IO (NodeState SimpleTx)
 -> IO (NodeState SimpleTx))
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall a b. (a -> b) -> a -> b
$ do
            Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step (Input SimpleTx
 -> StateT (StepState SimpleTx) IO (Outcome SimpleTx))
-> Input SimpleTx
-> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall a b. (a -> b) -> a -> b
$ Message SimpleTx -> Input SimpleTx
forall tx. Message tx -> Input tx
receiveMessage ReqDec{$sel:transaction:ReqTx :: SimpleTx
transaction = SimpleTx
decommitTx'}
            StateT (StepState SimpleTx) IO (NodeState SimpleTx)
forall tx (m :: * -> *).
MonadState (StepState tx) m =>
m (NodeState tx)
getState

          -- Verify decommitTx is recorded
          case NodeState SimpleTx -> HeadState SimpleTx
forall tx. NodeState tx -> HeadState tx
headState NodeState SimpleTx
s1 of
            Open OpenState{$sel:coordinatedHeadState:OpenState :: forall tx. OpenState tx -> CoordinatedHeadState tx
coordinatedHeadState = CoordinatedHeadState{Maybe SimpleTx
$sel:decommitTx:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> Maybe tx
decommitTx :: Maybe SimpleTx
decommitTx}} ->
              Maybe SimpleTx
decommitTx Maybe SimpleTx -> Maybe SimpleTx -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` SimpleTx -> Maybe SimpleTx
forall a. a -> Maybe a
Just SimpleTx
decommitTx'
            HeadState SimpleTx
other -> HasCallStack => String -> IO ()
String -> IO ()
expectationFailure (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Expected Open state, got: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> HeadState SimpleTx -> String
forall b a. (Show a, IsString b) => a -> b
show HeadState SimpleTx
other

          -- Step 2: Process ReqSn with the decommit tx
          let reqSnWithDecommit :: Input SimpleTx
reqSnWithDecommit = Message SimpleTx -> Input SimpleTx
forall tx. Message tx -> Input tx
receiveMessage (Message SimpleTx -> Input SimpleTx)
-> Message SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ SnapshotVersion
-> SnapshotNumber
-> [TxIdType SimpleTx]
-> Maybe SimpleTx
-> Maybe (TxIdType SimpleTx)
-> Message SimpleTx
forall tx.
SnapshotVersion
-> SnapshotNumber
-> [TxIdType tx]
-> Maybe tx
-> Maybe (TxIdType tx)
-> Message tx
ReqSn SnapshotVersion
0 SnapshotNumber
1 [] (SimpleTx -> Maybe SimpleTx
forall a. a -> Maybe a
Just SimpleTx
decommitTx') Maybe SimpleId
Maybe (TxIdType SimpleTx)
forall a. Maybe a
Nothing
          NodeState SimpleTx
s2 <- Environment
-> Ledger SimpleTx
-> NodeState SimpleTx
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall (m :: * -> *) tx a.
Monad m =>
Environment
-> Ledger tx -> NodeState tx -> StateT (StepState tx) m a -> m a
runHeadLogic Environment
aliceEnv' Ledger SimpleTx
ledger NodeState SimpleTx
s1 (StateT (StepState SimpleTx) IO (NodeState SimpleTx)
 -> IO (NodeState SimpleTx))
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall a b. (a -> b) -> a -> b
$ do
            Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step Input SimpleTx
reqSnWithDecommit
            StateT (StepState SimpleTx) IO (NodeState SimpleTx)
forall tx (m :: * -> *).
MonadState (StepState tx) m =>
m (NodeState tx)
getState

          -- Step 3: AckSn from alice → SnapshotConfirmed + DecommitApproved + DecrementTx posted
          -- The snapshot after applying decommit:
          --   confirmedUTxO = initialUtxo = {1}
          --   applyTransactions {1} [SimpleTx 10 {1} {3}] = {3}
          --   utxoToDecommit = utxoFromTx decommitTx' = txOutputs = {3}
          --   activeUTxO = {3} \ {3} = {}
          let snapshot1 :: Snapshot SimpleTx
snapshot1 =
                Snapshot
                  { $sel:headId:Snapshot :: HeadId
headId = HeadId
testHeadId
                  , $sel:version:Snapshot :: SnapshotVersion
version = SnapshotVersion
0
                  , $sel:number:Snapshot :: SnapshotNumber
number = SnapshotNumber
1
                  , $sel:confirmed:Snapshot :: [SimpleTx]
confirmed = []
                  , $sel:utxo:Snapshot :: UTxOType SimpleTx
utxo = UTxOType SimpleTx
forall a. Monoid a => a
mempty -- activeUTxO after decommit
                  , $sel:utxoToCommit:Snapshot :: Maybe (UTxOType SimpleTx)
utxoToCommit = Maybe (UTxOType SimpleTx)
forall a. Maybe a
Nothing
                  , $sel:utxoToDecommit:Snapshot :: Maybe (UTxOType SimpleTx)
utxoToDecommit = UTxOType SimpleTx -> Maybe (UTxOType SimpleTx)
forall a. a -> Maybe a
Just (SimpleId -> UTxOType SimpleTx
utxoRef SimpleId
3) -- outputs of decommit tx
                  , $sel:depositTxId:Snapshot :: Maybe (TxIdType SimpleTx)
depositTxId = Maybe SimpleId
Maybe (TxIdType SimpleTx)
forall a. Maybe a
Nothing
                  , $sel:accumulator:Snapshot :: HydraAccumulator
accumulator = UTxOType SimpleTx
-> Maybe (UTxOType SimpleTx)
-> Maybe (UTxOType SimpleTx)
-> HydraAccumulator
forall tx.
IsTx tx =>
UTxOType tx
-> Maybe (UTxOType tx) -> Maybe (UTxOType tx) -> HydraAccumulator
Accumulator.buildFromSnapshotUTxOs UTxOType SimpleTx
forall a. Monoid a => a
mempty Maybe (UTxOType SimpleTx)
forall a. Maybe a
Nothing (UTxOType SimpleTx -> Maybe (UTxOType SimpleTx)
forall a. a -> Maybe a
Just (SimpleId -> UTxOType SimpleTx
utxoRef SimpleId
3))
                  }
              ackSn :: Input SimpleTx
ackSn = Message SimpleTx -> Input SimpleTx
forall tx. Message tx -> Input tx
receiveMessage (Message SimpleTx -> Input SimpleTx)
-> Message SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ Signature (Snapshot SimpleTx) -> SnapshotNumber -> Message SimpleTx
forall tx. Signature (Snapshot tx) -> SnapshotNumber -> Message tx
AckSn (Secret (SigningKey HydraKey)
-> Snapshot SimpleTx -> Signature (Snapshot SimpleTx)
forall a.
SignableRepresentation a =>
Secret (SigningKey HydraKey) -> a -> Signature a
sign Secret (SigningKey HydraKey)
aliceSk Snapshot SimpleTx
snapshot1) SnapshotNumber
1
          NodeState SimpleTx
s3 <- Environment
-> Ledger SimpleTx
-> NodeState SimpleTx
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall (m :: * -> *) tx a.
Monad m =>
Environment
-> Ledger tx -> NodeState tx -> StateT (StepState tx) m a -> m a
runHeadLogic Environment
aliceEnv' Ledger SimpleTx
ledger NodeState SimpleTx
s2 (StateT (StepState SimpleTx) IO (NodeState SimpleTx)
 -> IO (NodeState SimpleTx))
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall a b. (a -> b) -> a -> b
$ do
            Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step Input SimpleTx
ackSn
            StateT (StepState SimpleTx) IO (NodeState SimpleTx)
forall tx (m :: * -> *).
MonadState (StepState tx) m =>
m (NodeState tx)
getState

          -- Verify SnapshotConfirmed happened and decommitTx is still set
          case NodeState SimpleTx -> HeadState SimpleTx
forall tx. NodeState tx -> HeadState tx
headState NodeState SimpleTx
s3 of
            Open OpenState{$sel:coordinatedHeadState:OpenState :: forall tx. OpenState tx -> CoordinatedHeadState tx
coordinatedHeadState = CoordinatedHeadState{Maybe SimpleTx
$sel:decommitTx:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> Maybe tx
decommitTx :: Maybe SimpleTx
decommitTx, ConfirmedSnapshot SimpleTx
$sel:confirmedSnapshot:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> ConfirmedSnapshot tx
confirmedSnapshot :: ConfirmedSnapshot SimpleTx
confirmedSnapshot}} -> do
              Maybe SimpleTx
decommitTx Maybe SimpleTx -> Maybe SimpleTx -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` SimpleTx -> Maybe SimpleTx
forall a. a -> Maybe a
Just SimpleTx
decommitTx'
              case ConfirmedSnapshot SimpleTx
confirmedSnapshot of
                ConfirmedSnapshot{$sel:snapshot:InitialSnapshot :: forall tx. ConfirmedSnapshot tx -> Snapshot tx
snapshot = Snapshot{SnapshotNumber
$sel:number:Snapshot :: forall tx. Snapshot tx -> SnapshotNumber
number :: SnapshotNumber
number, Maybe (UTxOType SimpleTx)
$sel:utxoToDecommit:Snapshot :: forall tx. Snapshot tx -> Maybe (UTxOType tx)
utxoToDecommit :: Maybe (UTxOType SimpleTx)
utxoToDecommit}} -> do
                  SnapshotNumber
number SnapshotNumber -> SnapshotNumber -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` SnapshotNumber
1
                  Maybe (Set SimpleTxOut)
Maybe (UTxOType SimpleTx)
utxoToDecommit Maybe (Set SimpleTxOut) -> Maybe (Set SimpleTxOut) -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Set SimpleTxOut -> Maybe (Set SimpleTxOut)
forall a. a -> Maybe a
Just (SimpleId -> UTxOType SimpleTx
utxoRef SimpleId
3)
                ConfirmedSnapshot SimpleTx
_ -> HasCallStack => String -> IO ()
String -> IO ()
expectationFailure String
"Expected ConfirmedSnapshot"
            HeadState SimpleTx
other -> HasCallStack => String -> IO ()
String -> IO ()
expectationFailure (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Expected Open state, got: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> HeadState SimpleTx -> String
forall b a. (Show a, IsString b) => a -> b
show HeadState SimpleTx
other

          -- Step 4: Chain rollback should re-post the DecrementTx
          let rollbackInput :: Input SimpleTx
rollbackInput = ChainEvent SimpleTx -> Input SimpleTx
forall tx. ChainEvent tx -> Input tx
ChainInput Rollback{$sel:rolledBackChainState:Observation :: ChainStateType SimpleTx
rolledBackChainState = ChainSlot -> SimpleChainState
SimpleChainState ChainSlot
0, $sel:chainTime:Observation :: UTCTime
chainTime = UTCTime
now}
          let rollbackOutcome :: Outcome SimpleTx
rollbackOutcome = Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
aliceEnv' Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
s3 Input SimpleTx
rollbackInput

          Outcome SimpleTx
rollbackOutcome Outcome SimpleTx -> (Effect SimpleTx -> Bool) -> IO ()
forall tx.
(HasCallStack, IsChainState tx) =>
Outcome tx -> (Effect tx -> Bool) -> IO ()
`hasEffectSatisfying` \case
            OnChainEffect{PostChainTx SimpleTx
$sel:postChainTx:ClientEffect :: forall tx. Effect tx -> PostChainTx tx
postChainTx :: PostChainTx SimpleTx
postChainTx} ->
              case PostChainTx SimpleTx
postChainTx of
                DecrementTx{} -> Bool
True
                PostChainTx SimpleTx
_ -> Bool
False
            Effect SimpleTx
_ -> Bool
False

      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"ignores in-flight ReqTx when closed" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        let s0 :: NodeState SimpleTx
s0 = [Party] -> NodeState SimpleTx
inClosedState [Party]
threeParties
            input :: Input SimpleTx
input = Message SimpleTx -> Input SimpleTx
forall tx. Message tx -> Input tx
receiveMessage (Message SimpleTx -> Input SimpleTx)
-> Message SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ SimpleTx -> Message SimpleTx
forall tx. tx -> Message tx
ReqTx (SimpleId -> SimpleTx
aValidTx SimpleId
42)
        UTCTime
now <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
s0.chainPointTime.currentSlot
        Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
s0 Input SimpleTx
input Outcome SimpleTx -> Outcome SimpleTx -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` LogicError SimpleTx -> Outcome SimpleTx
forall tx. LogicError tx -> Outcome tx
Error (Input SimpleTx -> HeadState SimpleTx -> LogicError SimpleTx
forall tx. Input tx -> HeadState tx -> LogicError tx
UnhandledInput Input SimpleTx
input (NodeState SimpleTx -> HeadState SimpleTx
forall tx. NodeState tx -> HeadState tx
headState NodeState SimpleTx
s0))

      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"ignores in-flight ReqDec when closed" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        let s0 :: NodeState SimpleTx
s0 = [Party] -> NodeState SimpleTx
inClosedState [Party]
threeParties
            input :: Input SimpleTx
input = Message SimpleTx -> Input SimpleTx
forall tx. Message tx -> Input tx
receiveMessage (Message SimpleTx -> Input SimpleTx)
-> Message SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ ReqDec{$sel:transaction:ReqTx :: SimpleTx
transaction = SimpleId -> SimpleTx
aValidTx SimpleId
42}
        UTCTime
now <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
s0.chainPointTime.currentSlot
        Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
s0 Input SimpleTx
input Outcome SimpleTx -> Outcome SimpleTx -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` LogicError SimpleTx -> Outcome SimpleTx
forall tx. LogicError tx -> Outcome tx
Error (Input SimpleTx -> HeadState SimpleTx -> LogicError SimpleTx
forall tx. Input tx -> HeadState tx -> LogicError tx
UnhandledInput Input SimpleTx
input (NodeState SimpleTx -> HeadState SimpleTx
forall tx. NodeState tx -> HeadState tx
headState NodeState SimpleTx
s0))

      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"notifies user on head closing and when passing the contestation deadline" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        let s0 :: NodeState SimpleTx
s0 = [Party] -> NodeState SimpleTx
inOpenState [Party]
threeParties
            snapshotNumber :: SnapshotNumber
snapshotNumber = SnapshotNumber
0
            contestationDeadline :: UTCTime
contestationDeadline = Gen UTCTime
forall a. Arbitrary a => Gen a
arbitrary Gen UTCTime -> Int -> UTCTime
forall a. Gen a -> Int -> a
`generateWith` Int
42
            observeCloseTx :: Input SimpleTx
observeCloseTx =
              OnChainTx SimpleTx -> Input SimpleTx
observeTx
                OnCloseTx
                  { $sel:headId:OnInitTx :: HeadId
headId = HeadId
testHeadId
                  , SnapshotNumber
snapshotNumber :: SnapshotNumber
$sel:snapshotNumber:OnInitTx :: SnapshotNumber
snapshotNumber
                  , UTCTime
contestationDeadline :: UTCTime
$sel:contestationDeadline:OnInitTx :: UTCTime
contestationDeadline
                  }
        Environment
-> Ledger SimpleTx
-> NodeState SimpleTx
-> StateT (StepState SimpleTx) IO ()
-> IO ()
forall (m :: * -> *) tx a.
Monad m =>
Environment
-> Ledger tx -> NodeState tx -> StateT (StepState tx) m a -> m a
runHeadLogic Environment
bobEnv Ledger SimpleTx
ledger NodeState SimpleTx
s0 (StateT (StepState SimpleTx) IO () -> IO ())
-> StateT (StepState SimpleTx) IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          Outcome SimpleTx
outcome1 <- Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step Input SimpleTx
observeCloseTx
          IO () -> StateT (StepState SimpleTx) IO ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (StepState SimpleTx) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> StateT (StepState SimpleTx) IO ())
-> IO () -> StateT (StepState SimpleTx) IO ()
forall a b. (a -> b) -> a -> b
$ do
            Outcome SimpleTx
outcome1 Outcome SimpleTx -> (StateChanged SimpleTx -> Bool) -> IO ()
forall tx.
(HasCallStack, IsChainState tx) =>
Outcome tx -> (StateChanged tx -> Bool) -> IO ()
`hasStateChangedSatisfying` \case
              HeadClosed{} -> Bool
True
              StateChanged SimpleTx
_ -> Bool
False
            Outcome SimpleTx
outcome1
              Outcome SimpleTx -> (StateChanged SimpleTx -> Bool) -> IO ()
forall tx.
(HasCallStack, IsChainState tx) =>
Outcome tx -> (StateChanged tx -> Bool) -> IO ()
`hasNoStateChangedSatisfying` \case
                HeadIsReadyToFanout{} -> Bool
True
                StateChanged SimpleTx
_ -> Bool
False

          let oneSecondsPastDeadline :: UTCTime
oneSecondsPastDeadline = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
1 UTCTime
contestationDeadline
              someChainPoint :: ChainPointType SimpleTx
someChainPoint = Gen (ChainPointType SimpleTx)
forall a. Arbitrary a => Gen a
arbitrary Gen (ChainPointType SimpleTx) -> Int -> ChainPointType SimpleTx
forall a. Gen a -> Int -> a
`generateWith` Int
42
          let stepTimePastDeadline :: Input SimpleTx
stepTimePastDeadline = ChainEvent SimpleTx -> Input SimpleTx
forall tx. ChainEvent tx -> Input tx
ChainInput (ChainEvent SimpleTx -> Input SimpleTx)
-> ChainEvent SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ UTCTime -> ChainPointType SimpleTx -> ChainEvent SimpleTx
forall tx. UTCTime -> ChainPointType tx -> ChainEvent tx
Tick UTCTime
oneSecondsPastDeadline ChainPointType SimpleTx
someChainPoint

          Outcome SimpleTx
outcome2 <- Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step Input SimpleTx
stepTimePastDeadline
          IO () -> StateT (StepState SimpleTx) IO ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (StepState SimpleTx) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> StateT (StepState SimpleTx) IO ())
-> IO () -> StateT (StepState SimpleTx) IO ()
forall a b. (a -> b) -> a -> b
$
            Outcome SimpleTx
outcome2 Outcome SimpleTx -> (StateChanged SimpleTx -> Bool) -> IO ()
forall tx.
(HasCallStack, IsChainState tx) =>
Outcome tx -> (StateChanged tx -> Bool) -> IO ()
`hasStateChangedSatisfying` \case
              HeadIsReadyToFanout{HeadId
$sel:headId:NetworkConnected :: forall tx. StateChanged tx -> HeadId
headId :: HeadId
headId} -> HeadId
testHeadId HeadId -> HeadId -> Bool
forall a. Eq a => a -> a -> Bool
== HeadId
headId
              StateChanged SimpleTx
_ -> Bool
False

      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"contests when detecting close with old snapshot" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        let snapshotVersion :: SnapshotVersion
snapshotVersion = SnapshotVersion
0
            snapshot :: Snapshot SimpleTx
snapshot = SnapshotNumber
-> SnapshotVersion
-> [SimpleTx]
-> UTxOType SimpleTx
-> Snapshot SimpleTx
forall tx.
IsTx tx =>
SnapshotNumber
-> SnapshotVersion -> [tx] -> UTxOType tx -> Snapshot tx
testSnapshot SnapshotNumber
2 SnapshotVersion
snapshotVersion [] Set SimpleTxOut
UTxOType SimpleTx
forall a. Monoid a => a
mempty
            latestConfirmedSnapshot :: ConfirmedSnapshot SimpleTx
latestConfirmedSnapshot = Snapshot SimpleTx
-> MultiSignature (Snapshot SimpleTx) -> ConfirmedSnapshot SimpleTx
forall tx.
Snapshot tx -> MultiSignature (Snapshot tx) -> ConfirmedSnapshot tx
ConfirmedSnapshot Snapshot SimpleTx
snapshot ([Signature (Snapshot SimpleTx)]
-> MultiSignature (Snapshot SimpleTx)
forall a. [Signature a] -> MultiSignature a
Crypto.aggregate [])
            s0 :: NodeState SimpleTx
s0 =
              [Party] -> CoordinatedHeadState SimpleTx -> NodeState SimpleTx
inOpenState' [Party]
threeParties (CoordinatedHeadState SimpleTx -> NodeState SimpleTx)
-> CoordinatedHeadState SimpleTx -> NodeState SimpleTx
forall a b. (a -> b) -> a -> b
$
                CoordinatedHeadState SimpleTx
coordinatedHeadState{confirmedSnapshot = latestConfirmedSnapshot}
            deadline :: UTCTime
deadline = Gen UTCTime
forall a. Arbitrary a => Gen a
arbitrary Gen UTCTime -> Int -> UTCTime
forall a. Gen a -> Int -> a
`generateWith` Int
42
            params :: HeadParameters
params = HeadParameters -> Maybe HeadParameters -> HeadParameters
forall a. a -> Maybe a -> a
fromMaybe (ContestationPeriod -> DepositPeriod -> [Party] -> HeadParameters
HeadParameters ContestationPeriod
defaultContestationPeriod DepositPeriod
defaultDepositPeriod [Party]
threeParties) (HeadState SimpleTx -> Maybe HeadParameters
forall tx. HeadState tx -> Maybe HeadParameters
getHeadParameters (HeadState SimpleTx -> Maybe HeadParameters)
-> HeadState SimpleTx -> Maybe HeadParameters
forall a b. (a -> b) -> a -> b
$ NodeState SimpleTx -> HeadState SimpleTx
forall tx. NodeState tx -> HeadState tx
headState NodeState SimpleTx
s0)
        Environment
-> Ledger SimpleTx
-> NodeState SimpleTx
-> StateT (StepState SimpleTx) IO ()
-> IO ()
forall (m :: * -> *) tx a.
Monad m =>
Environment
-> Ledger tx -> NodeState tx -> StateT (StepState tx) m a -> m a
runHeadLogic Environment
bobEnv Ledger SimpleTx
ledger NodeState SimpleTx
s0 (StateT (StepState SimpleTx) IO () -> IO ())
-> StateT (StepState SimpleTx) IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          Outcome SimpleTx
o1 <- Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step (Input SimpleTx
 -> StateT (StepState SimpleTx) IO (Outcome SimpleTx))
-> Input SimpleTx
-> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall a b. (a -> b) -> a -> b
$ OnChainTx SimpleTx -> Input SimpleTx
observeTx (HeadId -> SnapshotNumber -> UTCTime -> OnChainTx SimpleTx
forall tx. HeadId -> SnapshotNumber -> UTCTime -> OnChainTx tx
OnCloseTx HeadId
testHeadId SnapshotNumber
0 UTCTime
deadline)
          IO () -> StateT (StepState SimpleTx) IO ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (StepState SimpleTx) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> StateT (StepState SimpleTx) IO ())
-> IO () -> StateT (StepState SimpleTx) IO ()
forall a b. (a -> b) -> a -> b
$ Outcome SimpleTx
o1 Outcome SimpleTx -> Effect SimpleTx -> IO ()
forall tx.
(HasCallStack, IsChainState tx) =>
Outcome tx -> Effect tx -> IO ()
`hasEffect` PostChainTx SimpleTx -> Effect SimpleTx
chainEffect (HeadId
-> HeadParameters
-> SnapshotVersion
-> ConfirmedSnapshot SimpleTx
-> PostChainTx SimpleTx
forall tx.
HeadId
-> HeadParameters
-> SnapshotVersion
-> ConfirmedSnapshot tx
-> PostChainTx tx
ContestTx HeadId
testHeadId HeadParameters
params SnapshotVersion
snapshotVersion ConfirmedSnapshot SimpleTx
latestConfirmedSnapshot)
          NodeState SimpleTx
s1 <- StateT (StepState SimpleTx) IO (NodeState SimpleTx)
forall tx (m :: * -> *).
MonadState (StepState tx) m =>
m (NodeState tx)
getState
          IO () -> StateT (StepState SimpleTx) IO ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (StepState SimpleTx) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> StateT (StepState SimpleTx) IO ())
-> IO () -> StateT (StepState SimpleTx) IO ()
forall a b. (a -> b) -> a -> b
$
            NodeState SimpleTx -> HeadState SimpleTx
forall tx. NodeState tx -> HeadState tx
headState NodeState SimpleTx
s1 HeadState SimpleTx -> (HeadState SimpleTx -> Bool) -> IO ()
forall a. (HasCallStack, Show a) => a -> (a -> Bool) -> IO ()
`shouldSatisfy` \case
              Closed ClosedState{} -> Bool
True
              HeadState SimpleTx
_ -> Bool
False

      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"re-contests when detecting contest with old snapshot" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        let snapshotVersion :: SnapshotVersion
snapshotVersion = SnapshotVersion
0
            snapshot2 :: Snapshot SimpleTx
snapshot2 = SnapshotNumber
-> SnapshotVersion
-> [SimpleTx]
-> UTxOType SimpleTx
-> Snapshot SimpleTx
forall tx.
IsTx tx =>
SnapshotNumber
-> SnapshotVersion -> [tx] -> UTxOType tx -> Snapshot tx
testSnapshot SnapshotNumber
2 SnapshotVersion
snapshotVersion [] Set SimpleTxOut
UTxOType SimpleTx
forall a. Monoid a => a
mempty
            latestConfirmedSnapshot :: ConfirmedSnapshot SimpleTx
latestConfirmedSnapshot = Snapshot SimpleTx
-> MultiSignature (Snapshot SimpleTx) -> ConfirmedSnapshot SimpleTx
forall tx.
Snapshot tx -> MultiSignature (Snapshot tx) -> ConfirmedSnapshot tx
ConfirmedSnapshot Snapshot SimpleTx
snapshot2 ([Signature (Snapshot SimpleTx)]
-> MultiSignature (Snapshot SimpleTx)
forall a. [Signature a] -> MultiSignature a
Crypto.aggregate [])
            s0 :: NodeState SimpleTx
s0 = [Party] -> ConfirmedSnapshot SimpleTx -> NodeState SimpleTx
inClosedState' [Party]
threeParties ConfirmedSnapshot SimpleTx
latestConfirmedSnapshot
            deadline :: UTCTime
deadline = Gen UTCTime
forall a. Arbitrary a => Gen a
arbitrary Gen UTCTime -> Int -> UTCTime
forall a. Gen a -> Int -> a
`generateWith` Int
42
            params :: HeadParameters
params = HeadParameters -> Maybe HeadParameters -> HeadParameters
forall a. a -> Maybe a -> a
fromMaybe (ContestationPeriod -> DepositPeriod -> [Party] -> HeadParameters
HeadParameters ContestationPeriod
defaultContestationPeriod DepositPeriod
defaultDepositPeriod [Party]
threeParties) (HeadState SimpleTx -> Maybe HeadParameters
forall tx. HeadState tx -> Maybe HeadParameters
getHeadParameters (NodeState SimpleTx -> HeadState SimpleTx
forall tx. NodeState tx -> HeadState tx
headState NodeState SimpleTx
s0))
        UTCTime
now <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
s0.chainPointTime.currentSlot
        Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
s0 (OnChainTx SimpleTx -> Input SimpleTx
observeTx (OnChainTx SimpleTx -> Input SimpleTx)
-> OnChainTx SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ HeadId -> SnapshotNumber -> UTCTime -> OnChainTx SimpleTx
forall tx. HeadId -> SnapshotNumber -> UTCTime -> OnChainTx tx
OnContestTx HeadId
testHeadId SnapshotNumber
1 UTCTime
deadline)
          Outcome SimpleTx -> Effect SimpleTx -> IO ()
forall tx.
(HasCallStack, IsChainState tx) =>
Outcome tx -> Effect tx -> IO ()
`hasEffect` PostChainTx SimpleTx -> Effect SimpleTx
chainEffect (HeadId
-> HeadParameters
-> SnapshotVersion
-> ConfirmedSnapshot SimpleTx
-> PostChainTx SimpleTx
forall tx.
HeadId
-> HeadParameters
-> SnapshotVersion
-> ConfirmedSnapshot tx
-> PostChainTx tx
ContestTx HeadId
testHeadId HeadParameters
params SnapshotVersion
snapshotVersion ConfirmedSnapshot SimpleTx
latestConfirmedSnapshot)

      String -> Property -> SpecWith (Arg Property)
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"ignores unrelated initTx" Property
prop_ignoresUnrelatedOnInitTx

      String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"node synced status transitions according to chain time and unsynced policy" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
        Gen (HeadState SimpleTx)
-> (HeadState SimpleTx -> [HeadState SimpleTx])
-> (HeadState SimpleTx -> Property)
-> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> [a]) -> (a -> prop) -> Property
forAllShrink Gen (HeadState SimpleTx)
forall a. Arbitrary a => Gen a
arbitrary HeadState SimpleTx -> [HeadState SimpleTx]
forall a. Arbitrary a => a -> [a]
shrink ((HeadState SimpleTx -> Property) -> Property)
-> (HeadState SimpleTx -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \HeadState SimpleTx
headState ->
          Gen [Input SimpleTx]
-> ([Input SimpleTx] -> [[Input SimpleTx]])
-> ([Input SimpleTx] -> Property)
-> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> [a]) -> (a -> prop) -> Property
forAllShrink
            ( forall a. Arbitrary a => Gen a
arbitrary @[Input SimpleTx]
                Gen [Input SimpleTx]
-> ([Input SimpleTx] -> Bool) -> Gen [Input SimpleTx]
forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` ( Bool -> Bool
not
                              (Bool -> Bool)
-> ([Input SimpleTx] -> Bool) -> [Input SimpleTx] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Input SimpleTx -> Bool) -> [Input SimpleTx] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any
                                ( \case
                                    ChainInput Tick{} -> Bool
True
                                    Input SimpleTx
_ -> Bool
False
                                )
                           )
            )
            [Input SimpleTx] -> [[Input SimpleTx]]
forall a. Arbitrary a => a -> [a]
shrink
            (([Input SimpleTx] -> Property) -> Property)
-> ([Input SimpleTx] -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \[Input SimpleTx]
noTickInputs -> PropertyM IO () -> Property
forall a. Testable a => PropertyM IO a -> Property
monadicIO (PropertyM IO () -> Property) -> PropertyM IO () -> Property
forall a b. (a -> b) -> a -> b
$ do
              NodeState SimpleTx
stillCatchingUp <-
                IO (NodeState SimpleTx) -> PropertyM IO (NodeState SimpleTx)
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (IO (NodeState SimpleTx) -> PropertyM IO (NodeState SimpleTx))
-> IO (NodeState SimpleTx) -> PropertyM IO (NodeState SimpleTx)
forall a b. (a -> b) -> a -> b
$
                  (NodeState SimpleTx -> Input SimpleTx -> IO (NodeState SimpleTx))
-> NodeState SimpleTx
-> [Input SimpleTx]
-> IO (NodeState SimpleTx)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM
                    ( \NodeState SimpleTx
nodeState Input SimpleTx
input ->
                        Environment
-> Ledger SimpleTx
-> NodeState SimpleTx
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall (m :: * -> *) tx a.
Monad m =>
Environment
-> Ledger tx -> NodeState tx -> StateT (StepState tx) m a -> m a
runHeadLogic Environment
bobEnv Ledger SimpleTx
ledger NodeState SimpleTx
nodeState (StateT (StepState SimpleTx) IO (NodeState SimpleTx)
 -> IO (NodeState SimpleTx))
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall a b. (a -> b) -> a -> b
$ do
                          Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step Input SimpleTx
input
                          StateT (StepState SimpleTx) IO (NodeState SimpleTx)
forall tx (m :: * -> *).
MonadState (StepState tx) m =>
m (NodeState tx)
getState
                    )
                    (HeadState SimpleTx -> NodeState SimpleTx
forall tx. IsTx tx => HeadState tx -> NodeState tx
catchingUp HeadState SimpleTx
headState)
                    [Input SimpleTx]
noTickInputs

              Bool -> PropertyM IO ()
forall (m :: * -> *). Monad m => Bool -> PropertyM m ()
assert (Bool -> PropertyM IO ()) -> Bool -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ case NodeState SimpleTx
stillCatchingUp of
                NodeCatchingUp{} -> Bool
True
                NodeState SimpleTx
_ -> Bool
False

              UTCTime
now <- IO UTCTime -> PropertyM IO UTCTime
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run IO UTCTime
forall (m :: * -> *). MonadTime m => m UTCTime
getCurrentTime
              NodeState SimpleTx
nodeInSync <- IO (NodeState SimpleTx) -> PropertyM IO (NodeState SimpleTx)
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (IO (NodeState SimpleTx) -> PropertyM IO (NodeState SimpleTx))
-> IO (NodeState SimpleTx) -> PropertyM IO (NodeState SimpleTx)
forall a b. (a -> b) -> a -> b
$ do
                Environment
-> Ledger SimpleTx
-> NodeState SimpleTx
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall (m :: * -> *) tx a.
Monad m =>
Environment
-> Ledger tx -> NodeState tx -> StateT (StepState tx) m a -> m a
runHeadLogic Environment
bobEnv Ledger SimpleTx
ledger NodeState SimpleTx
stillCatchingUp (StateT (StepState SimpleTx) IO (NodeState SimpleTx)
 -> IO (NodeState SimpleTx))
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall a b. (a -> b) -> a -> b
$ do
                  Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step (Input SimpleTx
 -> StateT (StepState SimpleTx) IO (Outcome SimpleTx))
-> Input SimpleTx
-> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall a b. (a -> b) -> a -> b
$ ChainEvent SimpleTx -> Input SimpleTx
forall tx. ChainEvent tx -> Input tx
ChainInput Tick{$sel:chainTime:Observation :: UTCTime
chainTime = UTCTime
now, $sel:chainPoint:Observation :: ChainPointType SimpleTx
chainPoint = ChainPointType SimpleTx
10}
                  StateT (StepState SimpleTx) IO (NodeState SimpleTx)
forall tx (m :: * -> *).
MonadState (StepState tx) m =>
m (NodeState tx)
getState

              Bool -> PropertyM IO ()
forall (m :: * -> *). Monad m => Bool -> PropertyM m ()
assert (Bool -> PropertyM IO ()) -> Bool -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ case NodeState SimpleTx
nodeInSync of
                NodeInSync{} -> Bool
True
                NodeState SimpleTx
_ -> Bool
False

              NodeState SimpleTx
nodeOutOfSync <- IO (NodeState SimpleTx) -> PropertyM IO (NodeState SimpleTx)
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (IO (NodeState SimpleTx) -> PropertyM IO (NodeState SimpleTx))
-> IO (NodeState SimpleTx) -> PropertyM IO (NodeState SimpleTx)
forall a b. (a -> b) -> a -> b
$ do
                let delta :: NominalDiffTime
delta = UnsyncedPeriod -> NominalDiffTime
unsyncedPeriodToNominalDiffTime Environment
bobEnv.unsyncedPeriod
                    -- make chain time too old: beyond unsynced threshold
                    oldChainTime :: UTCTime
oldChainTime = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime (NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a
negate (NominalDiffTime
delta NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
+ NominalDiffTime
1)) UTCTime
now
                Environment
-> Ledger SimpleTx
-> NodeState SimpleTx
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall (m :: * -> *) tx a.
Monad m =>
Environment
-> Ledger tx -> NodeState tx -> StateT (StepState tx) m a -> m a
runHeadLogic Environment
bobEnv Ledger SimpleTx
ledger NodeState SimpleTx
nodeInSync (StateT (StepState SimpleTx) IO (NodeState SimpleTx)
 -> IO (NodeState SimpleTx))
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall a b. (a -> b) -> a -> b
$ do
                  Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step (Input SimpleTx
 -> StateT (StepState SimpleTx) IO (Outcome SimpleTx))
-> Input SimpleTx
-> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall a b. (a -> b) -> a -> b
$ ChainEvent SimpleTx -> Input SimpleTx
forall tx. ChainEvent tx -> Input tx
ChainInput Tick{$sel:chainTime:Observation :: UTCTime
chainTime = UTCTime
oldChainTime, $sel:chainPoint:Observation :: ChainPointType SimpleTx
chainPoint = ChainPointType SimpleTx
100}
                  StateT (StepState SimpleTx) IO (NodeState SimpleTx)
forall tx (m :: * -> *).
MonadState (StepState tx) m =>
m (NodeState tx)
getState

              Bool -> PropertyM IO ()
forall (m :: * -> *). Monad m => Bool -> PropertyM m ()
assert (Bool -> PropertyM IO ()) -> Bool -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ case NodeState SimpleTx
nodeOutOfSync of
                NodeCatchingUp{} -> Bool
True
                NodeState SimpleTx
_ -> Bool
False

      -- safety: cannot stay in-sync beyond the contestation window
      String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"node must be out of sync after full contestation period" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
        Gen (HeadState SimpleTx)
-> (HeadState SimpleTx -> [HeadState SimpleTx])
-> (HeadState SimpleTx -> Property)
-> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> [a]) -> (a -> prop) -> Property
forAllShrink Gen (HeadState SimpleTx)
forall a. Arbitrary a => Gen a
arbitrary HeadState SimpleTx -> [HeadState SimpleTx]
forall a. Arbitrary a => a -> [a]
shrink ((HeadState SimpleTx -> Property) -> Property)
-> (HeadState SimpleTx -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \HeadState SimpleTx
headState ->
          PropertyM IO () -> Property
forall a. Testable a => PropertyM IO a -> Property
monadicIO (PropertyM IO () -> Property) -> PropertyM IO () -> Property
forall a b. (a -> b) -> a -> b
$ do
            UTCTime
now <- IO UTCTime -> PropertyM IO UTCTime
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run IO UTCTime
forall (m :: * -> *). MonadTime m => m UTCTime
getCurrentTime
            let delta :: ContestationPeriod
delta = Environment
bobEnv.contestationPeriod
            -- make chain time too old: elapsed time >= full contestation period
            let oldChainTime :: UTCTime
oldChainTime = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime (NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a
negate (NominalDiffTime -> NominalDiffTime)
-> NominalDiffTime -> NominalDiffTime
forall a b. (a -> b) -> a -> b
$ ContestationPeriod -> NominalDiffTime
CP.toNominalDiffTime ContestationPeriod
delta) UTCTime
now

            NodeState SimpleTx
nodeAfter <- IO (NodeState SimpleTx) -> PropertyM IO (NodeState SimpleTx)
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (IO (NodeState SimpleTx) -> PropertyM IO (NodeState SimpleTx))
-> IO (NodeState SimpleTx) -> PropertyM IO (NodeState SimpleTx)
forall a b. (a -> b) -> a -> b
$ Environment
-> Ledger SimpleTx
-> NodeState SimpleTx
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall (m :: * -> *) tx a.
Monad m =>
Environment
-> Ledger tx -> NodeState tx -> StateT (StepState tx) m a -> m a
runHeadLogic Environment
bobEnv Ledger SimpleTx
ledger (HeadState SimpleTx -> NodeState SimpleTx
forall tx. IsTx tx => HeadState tx -> NodeState tx
inSync HeadState SimpleTx
headState) (StateT (StepState SimpleTx) IO (NodeState SimpleTx)
 -> IO (NodeState SimpleTx))
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall a b. (a -> b) -> a -> b
$ do
              Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step (Input SimpleTx
 -> StateT (StepState SimpleTx) IO (Outcome SimpleTx))
-> Input SimpleTx
-> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall a b. (a -> b) -> a -> b
$ ChainEvent SimpleTx -> Input SimpleTx
forall tx. ChainEvent tx -> Input tx
ChainInput Tick{$sel:chainTime:Observation :: UTCTime
chainTime = UTCTime
oldChainTime, $sel:chainPoint:Observation :: ChainPointType SimpleTx
chainPoint = ChainPointType SimpleTx
1}
              StateT (StepState SimpleTx) IO (NodeState SimpleTx)
forall tx (m :: * -> *).
MonadState (StepState tx) m =>
m (NodeState tx)
getState

            Bool -> PropertyM IO ()
forall (m :: * -> *). Monad m => Bool -> PropertyM m ()
assert (Bool -> PropertyM IO ()) -> Bool -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ case NodeState SimpleTx
nodeAfter of
              NodeCatchingUp{} -> Bool
True
              NodeState SimpleTx
_ -> Bool
False

      -- liveness: cannot drop out of sync under normal block timing
      String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"node remains in sync under normal block cadence" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
        Gen (HeadState SimpleTx)
-> (HeadState SimpleTx -> [HeadState SimpleTx])
-> (HeadState SimpleTx -> Property)
-> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> [a]) -> (a -> prop) -> Property
forAllShrink Gen (HeadState SimpleTx)
forall a. Arbitrary a => Gen a
arbitrary HeadState SimpleTx -> [HeadState SimpleTx]
forall a. Arbitrary a => a -> [a]
shrink ((HeadState SimpleTx -> Property) -> Property)
-> (HeadState SimpleTx -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \HeadState SimpleTx
headState ->
          PropertyM IO () -> Property
forall a. Testable a => PropertyM IO a -> Property
monadicIO (PropertyM IO () -> Property) -> PropertyM IO () -> Property
forall a b. (a -> b) -> a -> b
$ do
            UTCTime
now <- IO UTCTime -> PropertyM IO UTCTime
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run IO UTCTime
forall (m :: * -> *). MonadTime m => m UTCTime
getCurrentTime
            let normalBlockInterval :: NominalDiffTime
normalBlockInterval = NominalDiffTime
20
            let nextTime :: UTCTime
nextTime = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
normalBlockInterval UTCTime
now

            NodeState SimpleTx
nodeAfter <- IO (NodeState SimpleTx) -> PropertyM IO (NodeState SimpleTx)
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (IO (NodeState SimpleTx) -> PropertyM IO (NodeState SimpleTx))
-> IO (NodeState SimpleTx) -> PropertyM IO (NodeState SimpleTx)
forall a b. (a -> b) -> a -> b
$ Environment
-> Ledger SimpleTx
-> NodeState SimpleTx
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall (m :: * -> *) tx a.
Monad m =>
Environment
-> Ledger tx -> NodeState tx -> StateT (StepState tx) m a -> m a
runHeadLogic Environment
bobEnv Ledger SimpleTx
ledger (HeadState SimpleTx -> NodeState SimpleTx
forall tx. IsTx tx => HeadState tx -> NodeState tx
inSync HeadState SimpleTx
headState) (StateT (StepState SimpleTx) IO (NodeState SimpleTx)
 -> IO (NodeState SimpleTx))
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall a b. (a -> b) -> a -> b
$ do
              Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step (Input SimpleTx
 -> StateT (StepState SimpleTx) IO (Outcome SimpleTx))
-> Input SimpleTx
-> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall a b. (a -> b) -> a -> b
$ ChainEvent SimpleTx -> Input SimpleTx
forall tx. ChainEvent tx -> Input tx
ChainInput Tick{$sel:chainTime:Observation :: UTCTime
chainTime = UTCTime
nextTime, $sel:chainPoint:Observation :: ChainPointType SimpleTx
chainPoint = ChainPointType SimpleTx
1}
              StateT (StepState SimpleTx) IO (NodeState SimpleTx)
forall tx (m :: * -> *).
MonadState (StepState tx) m =>
m (NodeState tx)
getState

            Bool -> PropertyM IO ()
forall (m :: * -> *). Monad m => Bool -> PropertyM m ()
assert (Bool -> PropertyM IO ()) -> Bool -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ case NodeState SimpleTx
nodeAfter of
              NodeInSync{} -> Bool
True
              NodeState SimpleTx
_ -> Bool
False

      -- #2749: the node signals its sync status only on an actual transition
      -- (NodeUnsynced / NodeSynced), not on every tick, so clients are not
      -- flooded. The continuous drift is exposed as a metric instead.
      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"signals sync status only on a transition (#2749)" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        UTCTime
now <- IO UTCTime
forall (m :: * -> *). MonadTime m => m UTCTime
getCurrentTime
        let demoEnv :: Environment
demoEnv = Environment
bobEnv{unsyncedPeriod = UnsyncedPeriod 1.5} -- threshold 1.5s
            hs :: HeadState SimpleTx
hs = Gen (HeadState SimpleTx) -> Int -> HeadState SimpleTx
forall a. Gen a -> Int -> a
generateWith Gen (HeadState SimpleTx)
forall a. Arbitrary a => Gen a
arbitrary Int
42 :: HeadState SimpleTx
            -- A tick whose observed chain time is 'driftSecs' behind 'now'.
            tickWith :: NominalDiffTime -> Int -> Input SimpleTx
            tickWith :: NominalDiffTime -> Int -> Input SimpleTx
tickWith NominalDiffTime
driftSecs Int
slot =
              ChainEvent SimpleTx -> Input SimpleTx
forall tx. ChainEvent tx -> Input tx
ChainInput Tick{$sel:chainTime:Observation :: UTCTime
chainTime = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime (NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a
negate NominalDiffTime
driftSecs) UTCTime
now, $sel:chainPoint:Observation :: ChainPointType SimpleTx
chainPoint = Int -> ChainSlot
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
slot}
            syncTransition :: StateChanged SimpleTx -> Maybe SyncedStatus
            syncTransition :: StateChanged SimpleTx -> Maybe SyncedStatus
syncTransition = \case
              NodeUnsynced{} -> SyncedStatus -> Maybe SyncedStatus
forall a. a -> Maybe a
Just SyncedStatus
CatchingUp
              NodeSynced{} -> SyncedStatus -> Maybe SyncedStatus
forall a. a -> Maybe a
Just SyncedStatus
InSync
              StateChanged SimpleTx
_ -> Maybe SyncedStatus
forall a. Maybe a
Nothing
            -- Fold ticks through 'update', threading the node state, and collect
            -- the sync-status transitions emitted along the way.
            runTicks :: [NominalDiffTime] -> [SyncedStatus]
            runTicks :: [NominalDiffTime] -> [SyncedStatus]
runTicks [NominalDiffTime]
drifts =
              let go :: (NodeState SimpleTx, [SyncedStatus]) -> (Int, NominalDiffTime) -> (NodeState SimpleTx, [SyncedStatus])
                  go :: (NodeState SimpleTx, [SyncedStatus])
-> (Int, NominalDiffTime) -> (NodeState SimpleTx, [SyncedStatus])
go (NodeState SimpleTx
st, [SyncedStatus]
transitions) (Int
i, NominalDiffTime
d) =
                    let outcome :: Outcome SimpleTx
outcome = Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
demoEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
st (NominalDiffTime -> Int -> Input SimpleTx
tickWith NominalDiffTime
d Int
i)
                        changes :: [StateChanged SimpleTx]
changes = case Outcome SimpleTx
outcome of Continue{[StateChanged SimpleTx]
stateChanges :: [StateChanged SimpleTx]
$sel:stateChanges:Continue :: forall tx. Outcome tx -> [StateChanged tx]
stateChanges} -> [StateChanged SimpleTx]
stateChanges; Outcome SimpleTx
_ -> []
                     in (NodeState SimpleTx -> Outcome SimpleTx -> NodeState SimpleTx
forall tx.
IsChainState tx =>
NodeState tx -> Outcome tx -> NodeState tx
aggregateState NodeState SimpleTx
st Outcome SimpleTx
outcome, [SyncedStatus]
transitions [SyncedStatus] -> [SyncedStatus] -> [SyncedStatus]
forall a. Semigroup a => a -> a -> a
<> (StateChanged SimpleTx -> Maybe SyncedStatus)
-> [StateChanged SimpleTx] -> [SyncedStatus]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe StateChanged SimpleTx -> Maybe SyncedStatus
syncTransition [StateChanged SimpleTx]
changes)
               in (NodeState SimpleTx, [SyncedStatus]) -> [SyncedStatus]
forall a b. (a, b) -> b
snd (((NodeState SimpleTx, [SyncedStatus])
 -> (Int, NominalDiffTime) -> (NodeState SimpleTx, [SyncedStatus]))
-> (NodeState SimpleTx, [SyncedStatus])
-> [(Int, NominalDiffTime)]
-> (NodeState SimpleTx, [SyncedStatus])
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (NodeState SimpleTx, [SyncedStatus])
-> (Int, NominalDiffTime) -> (NodeState SimpleTx, [SyncedStatus])
go (HeadState SimpleTx -> NodeState SimpleTx
forall tx. IsTx tx => HeadState tx -> NodeState tx
inSync HeadState SimpleTx
hs, []) ([Int] -> [NominalDiffTime] -> [(Int, NominalDiffTime)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1 :: Int ..] [NominalDiffTime]
drifts))
        -- Staying in sync => no transitions.
        [NominalDiffTime] -> [SyncedStatus]
runTicks (Int -> NominalDiffTime -> [NominalDiffTime]
forall a. Int -> a -> [a]
replicate Int
10 NominalDiffTime
1.3) [SyncedStatus] -> [SyncedStatus] -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` []
        -- Staying unsynced => a single transition on entering, then silent.
        [NominalDiffTime] -> [SyncedStatus]
runTicks (Int -> NominalDiffTime -> [NominalDiffTime]
forall a. Int -> a -> [a]
replicate Int
10 NominalDiffTime
2.0) [SyncedStatus] -> [SyncedStatus] -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` [SyncedStatus
CatchingUp]
        -- One transition per crossing: in-sync -> catching-up -> in-sync.
        [NominalDiffTime] -> [SyncedStatus]
runTicks [NominalDiffTime
0.5, NominalDiffTime
2.0, NominalDiffTime
2.0, NominalDiffTime
0.5, NominalDiffTime
0.5] [SyncedStatus] -> [SyncedStatus] -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` [SyncedStatus
CatchingUp, SyncedStatus
InSync]

      String
-> ((Natural, Connectivity, NodeState SimpleTx) -> IO ()) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"connectivity messages passthrough without affecting the current state" (((Natural, Connectivity, NodeState SimpleTx) -> IO ()) -> Spec)
-> ((Natural, Connectivity, NodeState SimpleTx) -> IO ()) -> Spec
forall a b. (a -> b) -> a -> b
$
        \(Natural
ttl, Connectivity
connectivityMessage, NodeState SimpleTx
nodeState) -> do
          let input :: Input SimpleTx
input = Natural -> Connectivity -> Input SimpleTx
connectivityChanged Natural
ttl Connectivity
connectivityMessage
          case NodeState SimpleTx
nodeState of
            NodeCatchingUp{} -> do
              UTCTime
now <- IO UTCTime
forall (m :: * -> *). MonadTime m => m UTCTime
getCurrentTime
              let outcome :: Outcome SimpleTx
outcome = Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
nodeState Input SimpleTx
input
              Outcome SimpleTx
outcome Outcome SimpleTx -> (Outcome SimpleTx -> Bool) -> IO ()
forall a. (HasCallStack, Show a) => a -> (a -> Bool) -> IO ()
`shouldSatisfy` \case
                Wait{$sel:reason:Continue :: forall tx. Outcome tx -> WaitReason tx
reason = WaitOnNodeInSync{ChainSlot
currentSlot :: ChainSlot
$sel:currentSlot:WaitOnNotApplicableTx :: forall tx. WaitReason tx -> ChainSlot
currentSlot}, [StateChanged SimpleTx]
$sel:stateChanges:Continue :: forall tx. Outcome tx -> [StateChanged tx]
stateChanges :: [StateChanged SimpleTx]
stateChanges} ->
                  [StateChanged SimpleTx] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [StateChanged SimpleTx]
stateChanges Bool -> Bool -> Bool
&& ChainSlot
currentSlot ChainSlot -> ChainSlot -> Bool
forall a. Eq a => a -> a -> Bool
== NodeState SimpleTx
nodeState.chainPointTime.currentSlot
                Outcome SimpleTx
_ -> Bool
False
            NodeInSync{} -> do
              UTCTime
now <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
nodeState.chainPointTime.currentSlot
              let outcome :: Outcome SimpleTx
outcome = Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
nodeState Input SimpleTx
input
              Outcome SimpleTx
outcome Outcome SimpleTx -> (Outcome SimpleTx -> Bool) -> IO ()
forall a. (HasCallStack, Show a) => a -> (a -> Bool) -> IO ()
`shouldSatisfy` \case
                Continue{[StateChanged SimpleTx]
$sel:stateChanges:Continue :: forall tx. Outcome tx -> [StateChanged tx]
stateChanges :: [StateChanged SimpleTx]
stateChanges, [Effect SimpleTx]
effects :: [Effect SimpleTx]
$sel:effects:Continue :: forall tx. Outcome tx -> [Effect tx]
effects} ->
                  [Effect SimpleTx] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Effect SimpleTx]
effects
                    Bool -> Bool -> Bool
&& (StateChanged SimpleTx -> Bool) -> [StateChanged SimpleTx] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all
                      ( \case
                          -- NOTE: match only network related outcomes
                          PeerConnected{} -> Bool
True
                          PeerDisconnected{} -> Bool
True
                          NetworkVersionMismatch{} -> Bool
True
                          NetworkClusterIDMismatch{} -> Bool
True
                          NetworkConnected{} -> Bool
True
                          NetworkDisconnected{} -> Bool
True
                          StateChanged SimpleTx
_ -> Bool
False
                      )
                      [StateChanged SimpleTx]
stateChanges
                Outcome SimpleTx
_ -> Bool
False

      String -> (HeadId -> IO ()) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"ignores decrementTx of another head" ((HeadId -> IO ()) -> Spec) -> (HeadId -> IO ()) -> Spec
forall a b. (a -> b) -> a -> b
$ \HeadId
otherHeadId -> do
        let decrementOtherHead :: Input SimpleTx
decrementOtherHead = OnChainTx SimpleTx -> Input SimpleTx
observeTx (OnChainTx SimpleTx -> Input SimpleTx)
-> OnChainTx SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ OnDecrementTx{$sel:headId:OnInitTx :: HeadId
headId = HeadId
otherHeadId, $sel:newVersion:OnInitTx :: SnapshotVersion
newVersion = SnapshotVersion
1, $sel:distributedUTxO:OnInitTx :: UTxOType SimpleTx
distributedUTxO = Set SimpleTxOut
UTxOType SimpleTx
forall a. Monoid a => a
mempty}
            st :: NodeState SimpleTx
st = [Party] -> NodeState SimpleTx
inOpenState [Party]
threeParties
        UTCTime
now <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
st.chainPointTime.currentSlot
        Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
st Input SimpleTx
decrementOtherHead
          Outcome SimpleTx -> Outcome SimpleTx -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` LogicError SimpleTx -> Outcome SimpleTx
forall tx. LogicError tx -> Outcome tx
Error (NotOurHead{$sel:ourHeadId:UnhandledInput :: HeadId
ourHeadId = HeadId
testHeadId, HeadId
otherHeadId :: HeadId
$sel:otherHeadId:UnhandledInput :: HeadId
otherHeadId})

      String -> (HeadId -> SnapshotNumber -> UTCTime -> IO ()) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"ignores closeTx of another head" ((HeadId -> SnapshotNumber -> UTCTime -> IO ()) -> Spec)
-> (HeadId -> SnapshotNumber -> UTCTime -> IO ()) -> Spec
forall a b. (a -> b) -> a -> b
$ \HeadId
otherHeadId SnapshotNumber
snapshotNumber UTCTime
contestationDeadline -> do
        let closeOtherHead :: Input SimpleTx
closeOtherHead = OnChainTx SimpleTx -> Input SimpleTx
observeTx (OnChainTx SimpleTx -> Input SimpleTx)
-> OnChainTx SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ OnCloseTx{$sel:headId:OnInitTx :: HeadId
headId = HeadId
otherHeadId, SnapshotNumber
$sel:snapshotNumber:OnInitTx :: SnapshotNumber
snapshotNumber :: SnapshotNumber
snapshotNumber, UTCTime
$sel:contestationDeadline:OnInitTx :: UTCTime
contestationDeadline :: UTCTime
contestationDeadline}
            st :: NodeState SimpleTx
st = [Party] -> NodeState SimpleTx
inOpenState [Party]
threeParties
        UTCTime
now <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
st.chainPointTime.currentSlot
        Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
st Input SimpleTx
closeOtherHead
          Outcome SimpleTx -> Outcome SimpleTx -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` LogicError SimpleTx -> Outcome SimpleTx
forall tx. LogicError tx -> Outcome tx
Error (NotOurHead{$sel:ourHeadId:UnhandledInput :: HeadId
ourHeadId = HeadId
testHeadId, HeadId
$sel:otherHeadId:UnhandledInput :: HeadId
otherHeadId :: HeadId
otherHeadId})

      String -> (HeadId -> SnapshotNumber -> UTCTime -> IO ()) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"ignores contestTx of another head" ((HeadId -> SnapshotNumber -> UTCTime -> IO ()) -> Spec)
-> (HeadId -> SnapshotNumber -> UTCTime -> IO ()) -> Spec
forall a b. (a -> b) -> a -> b
$ \HeadId
otherHeadId SnapshotNumber
snapshotNumber UTCTime
contestationDeadline -> do
        let contestOtherHead :: Input SimpleTx
contestOtherHead = OnChainTx SimpleTx -> Input SimpleTx
observeTx (OnChainTx SimpleTx -> Input SimpleTx)
-> OnChainTx SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ OnContestTx{$sel:headId:OnInitTx :: HeadId
headId = HeadId
otherHeadId, SnapshotNumber
$sel:snapshotNumber:OnInitTx :: SnapshotNumber
snapshotNumber :: SnapshotNumber
snapshotNumber, UTCTime
$sel:contestationDeadline:OnInitTx :: UTCTime
contestationDeadline :: UTCTime
contestationDeadline}
            st :: NodeState SimpleTx
st = [Party] -> NodeState SimpleTx
inClosedState [Party]
threeParties
        UTCTime
now <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
st.chainPointTime.currentSlot
        Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
st Input SimpleTx
contestOtherHead
          Outcome SimpleTx -> Outcome SimpleTx -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` LogicError SimpleTx -> Outcome SimpleTx
forall tx. LogicError tx -> Outcome tx
Error (NotOurHead{$sel:ourHeadId:UnhandledInput :: HeadId
ourHeadId = HeadId
testHeadId, HeadId
$sel:otherHeadId:UnhandledInput :: HeadId
otherHeadId :: HeadId
otherHeadId})

      String -> (HeadId -> Set SimpleTxOut -> IO ()) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"ignores fanoutTx of another head" ((HeadId -> Set SimpleTxOut -> IO ()) -> Spec)
-> (HeadId -> Set SimpleTxOut -> IO ()) -> Spec
forall a b. (a -> b) -> a -> b
$ \HeadId
otherHeadId Set SimpleTxOut
fanoutUTxO -> do
        let collectOtherHead :: Input SimpleTx
collectOtherHead = OnChainTx SimpleTx -> Input SimpleTx
observeTx (OnChainTx SimpleTx -> Input SimpleTx)
-> OnChainTx SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ OnFanoutTx{$sel:headId:OnInitTx :: HeadId
headId = HeadId
otherHeadId, Set SimpleTxOut
UTxOType SimpleTx
fanoutUTxO :: Set SimpleTxOut
$sel:fanoutUTxO:OnInitTx :: UTxOType SimpleTx
fanoutUTxO}
            st :: NodeState SimpleTx
st = [Party] -> NodeState SimpleTx
inClosedState [Party]
threeParties
        UTCTime
now <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
st.chainPointTime.currentSlot
        Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
st Input SimpleTx
collectOtherHead
          Outcome SimpleTx -> Outcome SimpleTx -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` LogicError SimpleTx -> Outcome SimpleTx
forall tx. LogicError tx -> Outcome tx
Error (NotOurHead{$sel:ourHeadId:UnhandledInput :: HeadId
ourHeadId = HeadId
testHeadId, HeadId
$sel:otherHeadId:UnhandledInput :: HeadId
otherHeadId :: HeadId
otherHeadId})

      String -> (Set SimpleTxOut -> Property) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"fanout utxo always relies on observed utxo" ((Set SimpleTxOut -> Property) -> Spec)
-> (Set SimpleTxOut -> Property) -> Spec
forall a b. (a -> b) -> a -> b
$ \Set SimpleTxOut
fanoutUTxO ->
        Gen (NodeState SimpleTx)
-> (NodeState SimpleTx -> [NodeState SimpleTx])
-> (NodeState SimpleTx -> Property)
-> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> [a]) -> (a -> prop) -> Property
forAllShrink Gen (NodeState SimpleTx)
genClosedState NodeState SimpleTx -> [NodeState SimpleTx]
forall a. Arbitrary a => a -> [a]
shrink ((NodeState SimpleTx -> Property) -> Property)
-> (NodeState SimpleTx -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \NodeState SimpleTx
closedState -> PropertyM IO () -> Property
forall a. Testable a => PropertyM IO a -> Property
monadicIO (PropertyM IO () -> Property) -> PropertyM IO () -> Property
forall a b. (a -> b) -> a -> b
$ do
          let fanoutHead :: Input SimpleTx
fanoutHead = OnChainTx SimpleTx -> Input SimpleTx
observeTx (OnChainTx SimpleTx -> Input SimpleTx)
-> OnChainTx SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ OnFanoutTx{$sel:headId:OnInitTx :: HeadId
headId = HeadId
testHeadId, Set SimpleTxOut
UTxOType SimpleTx
$sel:fanoutUTxO:OnInitTx :: UTxOType SimpleTx
fanoutUTxO :: Set SimpleTxOut
fanoutUTxO}
          UTCTime
now <- IO UTCTime -> PropertyM IO UTCTime
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (IO UTCTime -> PropertyM IO UTCTime)
-> IO UTCTime -> PropertyM IO UTCTime
forall a b. (a -> b) -> a -> b
$ ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
closedState.chainPointTime.currentSlot
          let outcome :: Outcome SimpleTx
outcome = Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
closedState Input SimpleTx
fanoutHead
          (Property -> Property) -> PropertyM IO ()
forall (m :: * -> *).
Monad m =>
(Property -> Property) -> PropertyM m ()
monitor ((Property -> Property) -> PropertyM IO ())
-> (Property -> Property) -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Outcome: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Outcome SimpleTx -> String
forall b a. (Show a, IsString b) => a -> b
show Outcome SimpleTx
outcome)
          IO () -> PropertyM IO ()
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (IO () -> PropertyM IO ()) -> IO () -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$
            Outcome SimpleTx
outcome Outcome SimpleTx -> (StateChanged SimpleTx -> Bool) -> IO ()
forall tx.
(HasCallStack, IsChainState tx) =>
Outcome tx -> (StateChanged tx -> Bool) -> IO ()
`hasStateChangedSatisfying` \case
              HeadFannedOut{UTxOType SimpleTx
$sel:finalizedOutputs:NetworkConnected :: forall tx. StateChanged tx -> UTxOType tx
finalizedOutputs :: UTxOType SimpleTx
finalizedOutputs} -> Set SimpleTxOut
UTxOType SimpleTx
finalizedOutputs Set SimpleTxOut -> Set SimpleTxOut -> Bool
forall a. Eq a => a -> a -> Bool
== Set SimpleTxOut
fanoutUTxO
              StateChanged SimpleTx
_ -> Bool
False

      String -> (Set SimpleTxOut -> Set SimpleTxOut -> Property) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"fanout utxo includes accumulated UTxO from prior partial fanouts" ((Set SimpleTxOut -> Set SimpleTxOut -> Property) -> Spec)
-> (Set SimpleTxOut -> Set SimpleTxOut -> Property) -> Spec
forall a b. (a -> b) -> a -> b
$
        \Set SimpleTxOut
fanoutUTxO Set SimpleTxOut
priorDistributed ->
          Gen (NodeState SimpleTx)
-> (NodeState SimpleTx -> [NodeState SimpleTx])
-> (NodeState SimpleTx -> Property)
-> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> [a]) -> (a -> prop) -> Property
forAllShrink Gen (NodeState SimpleTx)
genClosedState NodeState SimpleTx -> [NodeState SimpleTx]
forall a. Arbitrary a => a -> [a]
shrink ((NodeState SimpleTx -> Property) -> Property)
-> (NodeState SimpleTx -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \NodeState SimpleTx
closedState -> PropertyM IO () -> Property
forall a. Testable a => PropertyM IO a -> Property
monadicIO (PropertyM IO () -> Property) -> PropertyM IO () -> Property
forall a b. (a -> b) -> a -> b
$ do
            -- Prior partial fanouts mean the head is on-chain in FanoutProgress.
            let stWithPrior :: NodeState SimpleTx
stWithPrior = case NodeState SimpleTx
closedState.headState of
                  Closed ClosedState{HeadParameters
parameters :: HeadParameters
$sel:parameters:ClosedState :: forall tx. ClosedState tx -> HeadParameters
parameters, ConfirmedSnapshot SimpleTx
confirmedSnapshot :: ConfirmedSnapshot SimpleTx
$sel:confirmedSnapshot:ClosedState :: forall tx. ClosedState tx -> ConfirmedSnapshot tx
confirmedSnapshot, UTCTime
contestationDeadline :: UTCTime
$sel:contestationDeadline:ClosedState :: forall tx. ClosedState tx -> UTCTime
contestationDeadline, ChainStateType SimpleTx
chainState :: ChainStateType SimpleTx
$sel:chainState:ClosedState :: forall tx. ClosedState tx -> ChainStateType tx
chainState, HeadId
headId :: HeadId
$sel:headId:ClosedState :: forall tx. ClosedState tx -> HeadId
headId, HeadSeed
headSeed :: HeadSeed
$sel:headSeed:ClosedState :: forall tx. ClosedState tx -> HeadSeed
headSeed, SnapshotVersion
version :: SnapshotVersion
$sel:version:ClosedState :: forall tx. ClosedState tx -> SnapshotVersion
version} ->
                    NodeState SimpleTx
closedState
                      { headState =
                          FanoutProgress
                            PartialFanoutState
                              { parameters
                              , confirmedSnapshot
                              , contestationDeadline
                              , chainState
                              , headId
                              , headSeed
                              , version
                              , remainingOutputs = mempty
                              , distributedOutputs = priorDistributed
                              , mode = AutoDrain
                              }
                      }
                  HeadState SimpleTx
_ -> NodeState SimpleTx
closedState
                fanoutHead :: Input SimpleTx
fanoutHead = OnChainTx SimpleTx -> Input SimpleTx
observeTx (OnChainTx SimpleTx -> Input SimpleTx)
-> OnChainTx SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ OnFanoutTx{$sel:headId:OnInitTx :: HeadId
headId = HeadId
testHeadId, Set SimpleTxOut
UTxOType SimpleTx
$sel:fanoutUTxO:OnInitTx :: UTxOType SimpleTx
fanoutUTxO :: Set SimpleTxOut
fanoutUTxO}
            UTCTime
now <- IO UTCTime -> PropertyM IO UTCTime
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (IO UTCTime -> PropertyM IO UTCTime)
-> IO UTCTime -> PropertyM IO UTCTime
forall a b. (a -> b) -> a -> b
$ ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
closedState.chainPointTime.currentSlot
            let outcome :: Outcome SimpleTx
outcome = Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
stWithPrior Input SimpleTx
fanoutHead
            (Property -> Property) -> PropertyM IO ()
forall (m :: * -> *).
Monad m =>
(Property -> Property) -> PropertyM m ()
monitor ((Property -> Property) -> PropertyM IO ())
-> (Property -> Property) -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Outcome: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Outcome SimpleTx -> String
forall b a. (Show a, IsString b) => a -> b
show Outcome SimpleTx
outcome)
            IO () -> PropertyM IO ()
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (IO () -> PropertyM IO ()) -> IO () -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$
              Outcome SimpleTx
outcome Outcome SimpleTx -> (StateChanged SimpleTx -> Bool) -> IO ()
forall tx.
(HasCallStack, IsChainState tx) =>
Outcome tx -> (StateChanged tx -> Bool) -> IO ()
`hasStateChangedSatisfying` \case
                HeadFannedOut{UTxOType SimpleTx
$sel:finalizedOutputs:NetworkConnected :: forall tx. StateChanged tx -> UTxOType tx
finalizedOutputs :: UTxOType SimpleTx
finalizedOutputs} -> Set SimpleTxOut
UTxOType SimpleTx
finalizedOutputs Set SimpleTxOut -> Set SimpleTxOut -> Bool
forall a. Eq a => a -> a -> Bool
== Set SimpleTxOut
priorDistributed Set SimpleTxOut -> Set SimpleTxOut -> Set SimpleTxOut
forall a. Semigroup a => a -> a -> a
<> Set SimpleTxOut
fanoutUTxO
                StateChanged SimpleTx
_ -> Bool
False

      String -> (HeadId -> Set SimpleTxOut -> IO ()) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"ignores partial fanoutTx of another head" ((HeadId -> Set SimpleTxOut -> IO ()) -> Spec)
-> (HeadId -> Set SimpleTxOut -> IO ()) -> Spec
forall a b. (a -> b) -> a -> b
$ \HeadId
otherHeadId Set SimpleTxOut
distributedUTxO -> do
        let partialFanoutOtherHead :: Input SimpleTx
partialFanoutOtherHead = OnChainTx SimpleTx -> Input SimpleTx
observeTx (OnChainTx SimpleTx -> Input SimpleTx)
-> OnChainTx SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ OnPartialFanoutTx{$sel:headId:OnInitTx :: HeadId
headId = HeadId
otherHeadId, distributedOutputs :: UTxOType SimpleTx
distributedOutputs = Set SimpleTxOut
UTxOType SimpleTx
distributedUTxO}
            st :: NodeState SimpleTx
st = [Party] -> NodeState SimpleTx
inClosedState [Party]
threeParties
        UTCTime
now <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
st.chainPointTime.currentSlot
        Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
st Input SimpleTx
partialFanoutOtherHead
          Outcome SimpleTx -> Outcome SimpleTx -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` LogicError SimpleTx -> Outcome SimpleTx
forall tx. LogicError tx -> Outcome tx
Error (NotOurHead{$sel:ourHeadId:UnhandledInput :: HeadId
ourHeadId = HeadId
testHeadId, HeadId
$sel:otherHeadId:UnhandledInput :: HeadId
otherHeadId :: HeadId
otherHeadId})

      String -> (Set SimpleTxOut -> Property) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"observing another party's partial fanout records it but does NOT auto-drive" ((Set SimpleTxOut -> Property) -> Spec)
-> (Set SimpleTxOut -> Property) -> Spec
forall a b. (a -> b) -> a -> b
$ \Set SimpleTxOut
distributedUTxO ->
        Gen (NodeState SimpleTx)
-> (NodeState SimpleTx -> [NodeState SimpleTx])
-> (NodeState SimpleTx -> Property)
-> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> [a]) -> (a -> prop) -> Property
forAllShrink Gen (NodeState SimpleTx)
genClosedState NodeState SimpleTx -> [NodeState SimpleTx]
forall a. Arbitrary a => a -> [a]
shrink ((NodeState SimpleTx -> Property) -> Property)
-> (NodeState SimpleTx -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \NodeState SimpleTx
closedState -> PropertyM IO () -> Property
forall a. Testable a => PropertyM IO a -> Property
monadicIO (PropertyM IO () -> Property) -> PropertyM IO () -> Property
forall a b. (a -> b) -> a -> b
$ do
          -- A node still in 'Closed' observing a partial fanout it did not initiate
          -- is a passive observer: it records the step (HeadPartialFannedOut, mode
          -- AwaitingSelection) but must NOT post the next fanout — otherwise it
          -- would steamroll a selective fanout another party deliberately paused.
          let partialFanoutHead :: Input SimpleTx
partialFanoutHead = OnChainTx SimpleTx -> Input SimpleTx
observeTx (OnChainTx SimpleTx -> Input SimpleTx)
-> OnChainTx SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ OnPartialFanoutTx{$sel:headId:OnInitTx :: HeadId
headId = HeadId
testHeadId, distributedOutputs :: UTxOType SimpleTx
distributedOutputs = Set SimpleTxOut
UTxOType SimpleTx
distributedUTxO}
          UTCTime
now <- IO UTCTime -> PropertyM IO UTCTime
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (IO UTCTime -> PropertyM IO UTCTime)
-> IO UTCTime -> PropertyM IO UTCTime
forall a b. (a -> b) -> a -> b
$ ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
closedState.chainPointTime.currentSlot
          let outcome :: Outcome SimpleTx
outcome = Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
closedState Input SimpleTx
partialFanoutHead
          (Property -> Property) -> PropertyM IO ()
forall (m :: * -> *).
Monad m =>
(Property -> Property) -> PropertyM m ()
monitor ((Property -> Property) -> PropertyM IO ())
-> (Property -> Property) -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Outcome: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Outcome SimpleTx -> String
forall b a. (Show a, IsString b) => a -> b
show Outcome SimpleTx
outcome)
          IO () -> PropertyM IO ()
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (IO () -> PropertyM IO ()) -> IO () -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$
            Outcome SimpleTx
outcome Outcome SimpleTx -> (StateChanged SimpleTx -> Bool) -> IO ()
forall tx.
(HasCallStack, IsChainState tx) =>
Outcome tx -> (StateChanged tx -> Bool) -> IO ()
`hasStateChangedSatisfying` \case
              HeadPartialFannedOut{$sel:mode:NetworkConnected :: forall tx. StateChanged tx -> FanoutMode tx
mode = FanoutMode SimpleTx
AwaitingSelection} -> Bool
True
              StateChanged SimpleTx
_ -> Bool
False
          IO () -> PropertyM IO ()
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (IO () -> PropertyM IO ()) -> IO () -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$
            Outcome SimpleTx
outcome Outcome SimpleTx -> (Effect SimpleTx -> Bool) -> IO ()
forall tx.
(HasCallStack, IsChainState tx) =>
Outcome tx -> (Effect tx -> Bool) -> IO ()
`hasNoEffectSatisfying` \case
              OnChainEffect{$sel:postChainTx:ClientEffect :: forall tx. Effect tx -> PostChainTx tx
postChainTx = FinalPartialFanoutTx{}} -> Bool
True
              OnChainEffect{$sel:postChainTx:ClientEffect :: forall tx. Effect tx -> PostChainTx tx
postChainTx = PartialFanoutTx{}} -> Bool
True
              Effect SimpleTx
_ -> Bool
False

      String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"client Fanout makes this node the driver (FanoutProgress AutoDrain) and posts FanoutTx" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
        Gen (NodeState SimpleTx)
-> (NodeState SimpleTx -> [NodeState SimpleTx])
-> (NodeState SimpleTx -> Property)
-> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> [a]) -> (a -> prop) -> Property
forAllShrink Gen (NodeState SimpleTx)
genClosedState NodeState SimpleTx -> [NodeState SimpleTx]
forall a. Arbitrary a => a -> [a]
shrink ((NodeState SimpleTx -> Property) -> Property)
-> (NodeState SimpleTx -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \NodeState SimpleTx
closedState -> PropertyM IO () -> Property
forall a. Testable a => PropertyM IO a -> Property
monadicIO (PropertyM IO () -> Property) -> PropertyM IO () -> Property
forall a b. (a -> b) -> a -> b
$ do
          UTCTime
now <- IO UTCTime -> PropertyM IO UTCTime
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (IO UTCTime -> PropertyM IO UTCTime)
-> IO UTCTime -> PropertyM IO UTCTime
forall a b. (a -> b) -> a -> b
$ ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
closedState.chainPointTime.currentSlot
          let outcome :: Outcome SimpleTx
outcome = Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
closedState (ClientInput SimpleTx -> Input SimpleTx
forall tx. ClientInput tx -> Input tx
ClientInput ClientInput SimpleTx
forall tx. ClientInput tx
Fanout)
          (Property -> Property) -> PropertyM IO ()
forall (m :: * -> *).
Monad m =>
(Property -> Property) -> PropertyM m ()
monitor ((Property -> Property) -> PropertyM IO ())
-> (Property -> Property) -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Outcome: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Outcome SimpleTx -> String
forall b a. (Show a, IsString b) => a -> b
show Outcome SimpleTx
outcome)
          IO () -> PropertyM IO ()
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (IO () -> PropertyM IO ()) -> IO () -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$
            Outcome SimpleTx
outcome Outcome SimpleTx -> (Effect SimpleTx -> Bool) -> IO ()
forall tx.
(HasCallStack, IsChainState tx) =>
Outcome tx -> (Effect tx -> Bool) -> IO ()
`hasEffectSatisfying` \case
              OnChainEffect{$sel:postChainTx:ClientEffect :: forall tx. Effect tx -> PostChainTx tx
postChainTx = FanoutTx{}} -> Bool
True
              Effect SimpleTx
_ -> Bool
False
          -- And it enters FanoutProgress in AutoDrain mode so subsequent chunk
          -- observations auto-continue on this (driving) node.
          case NodeState SimpleTx -> HeadState SimpleTx
forall tx. NodeState tx -> HeadState tx
headState (NodeState SimpleTx -> Outcome SimpleTx -> NodeState SimpleTx
forall tx.
IsChainState tx =>
NodeState tx -> Outcome tx -> NodeState tx
aggregateState NodeState SimpleTx
closedState Outcome SimpleTx
outcome) of
            FanoutProgress PartialFanoutState{$sel:mode:PartialFanoutState :: forall tx. PartialFanoutState tx -> FanoutMode tx
mode = FanoutMode SimpleTx
AutoDrain} -> () -> PropertyM IO ()
forall a. a -> PropertyM IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            HeadState SimpleTx
other -> IO () -> PropertyM IO ()
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (IO () -> PropertyM IO ()) -> IO () -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Expected FanoutProgress AutoDrain, got: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> HeadState SimpleTx -> String
forall b a. (Show a, IsString b) => a -> b
show HeadState SimpleTx
other

      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"partial fanout with large remaining triggers FinalPartialFanoutTx" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        let bigRemaining :: Set SimpleTxOut
bigRemaining = [SimpleTxOut] -> Set SimpleTxOut
forall a. Ord a => [a] -> Set a
Set.fromList [SimpleId -> SimpleTxOut
SimpleTxOut SimpleId
i | SimpleId
i <- [SimpleId
1 .. Int -> SimpleId
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
fanoutOutputThreshold SimpleId -> SimpleId -> SimpleId
forall a. Num a => a -> a -> a
+ SimpleId
1]]
            st :: NodeState SimpleTx
st = [Party] -> Set SimpleTxOut -> NodeState SimpleTx
inAutoDrainProgress [Party]
threeParties Set SimpleTxOut
bigRemaining
        UTCTime
now <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
st.chainPointTime.currentSlot
        let outcome :: Outcome SimpleTx
outcome = Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
st (OnChainTx SimpleTx -> Input SimpleTx
observeTx OnPartialFanoutTx{$sel:headId:OnInitTx :: HeadId
headId = HeadId
testHeadId, distributedOutputs :: UTxOType SimpleTx
distributedOutputs = Set SimpleTxOut
UTxOType SimpleTx
forall a. Monoid a => a
mempty})
        Outcome SimpleTx
outcome Outcome SimpleTx -> (Effect SimpleTx -> Bool) -> IO ()
forall tx.
(HasCallStack, IsChainState tx) =>
Outcome tx -> (Effect tx -> Bool) -> IO ()
`hasEffectSatisfying` \case
          OnChainEffect{$sel:postChainTx:ClientEffect :: forall tx. Effect tx -> PostChainTx tx
postChainTx = FinalPartialFanoutTx{UTxOType SimpleTx
utxoToDistribute :: UTxOType SimpleTx
$sel:utxoToDistribute:InitTx :: forall tx. PostChainTx tx -> UTxOType tx
utxoToDistribute}} ->
            Set SimpleTxOut -> Int
forall a. Set a -> Int
Set.size Set SimpleTxOut
UTxOType SimpleTx
utxoToDistribute Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Set SimpleTxOut -> Int
forall a. Set a -> Int
Set.size Set SimpleTxOut
bigRemaining
          Effect SimpleTx
_ -> Bool
False

      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"partial fanout reduces remainingUTxO by distributedUTxO" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        let allItems :: Set SimpleTxOut
allItems = [SimpleTxOut] -> Set SimpleTxOut
forall a. Ord a => [a] -> Set a
Set.fromList [SimpleId -> SimpleTxOut
SimpleTxOut SimpleId
i | SimpleId
i <- [SimpleId
1 .. Int -> SimpleId
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
fanoutOutputThreshold SimpleId -> SimpleId -> SimpleId
forall a. Num a => a -> a -> a
+ Int -> SimpleId
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
fanoutChunkSize SimpleId -> SimpleId -> SimpleId
forall a. Num a => a -> a -> a
+ SimpleId
1]]
            ([SimpleTxOut]
distributedList, [SimpleTxOut]
_) = Int -> [SimpleTxOut] -> ([SimpleTxOut], [SimpleTxOut])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
fanoutChunkSize (Set SimpleTxOut -> [SimpleTxOut]
forall a. Set a -> [a]
Set.toList Set SimpleTxOut
allItems)
            distributed :: Set SimpleTxOut
distributed = [SimpleTxOut] -> Set SimpleTxOut
forall a. Ord a => [a] -> Set a
Set.fromList [SimpleTxOut]
distributedList
            st :: NodeState SimpleTx
st = [Party] -> Set SimpleTxOut -> NodeState SimpleTx
inAutoDrainProgress [Party]
threeParties Set SimpleTxOut
allItems
        UTCTime
now <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
st.chainPointTime.currentSlot
        let outcome :: Outcome SimpleTx
outcome = Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
st (OnChainTx SimpleTx -> Input SimpleTx
observeTx OnPartialFanoutTx{$sel:headId:OnInitTx :: HeadId
headId = HeadId
testHeadId, distributedOutputs :: UTxOType SimpleTx
distributedOutputs = Set SimpleTxOut
UTxOType SimpleTx
distributed})
        Outcome SimpleTx
outcome Outcome SimpleTx -> (StateChanged SimpleTx -> Bool) -> IO ()
forall tx.
(HasCallStack, IsChainState tx) =>
Outcome tx -> (StateChanged tx -> Bool) -> IO ()
`hasStateChangedSatisfying` \case
          HeadPartialFannedOut{UTxOType SimpleTx
remainingOutputs :: UTxOType SimpleTx
$sel:remainingOutputs:NetworkConnected :: forall tx. StateChanged tx -> UTxOType tx
remainingOutputs} ->
            Set SimpleTxOut -> Int
forall a. Set a -> Int
Set.size Set SimpleTxOut
UTxOType SimpleTx
remainingOutputs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Set SimpleTxOut -> Int
forall a. Set a -> Int
Set.size Set SimpleTxOut
allItems Int -> Int -> Int
forall a. Num a => a -> a -> a
- Set SimpleTxOut -> Int
forall a. Set a -> Int
Set.size Set SimpleTxOut
distributed
          StateChanged SimpleTx
_ -> Bool
False

      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"partial fanout of non-prefix items tracks remaining by content, not by count" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        -- An adversary can submit a valid partial fanout of UTxOs that are NOT the
        -- prefix of the full set. The remaining computation must use content-based
        -- set-difference, not a count-based positional split.
        let total :: Int
total = Int
fanoutOutputThreshold Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
fanoutChunkSize Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
            allItems :: Set SimpleTxOut
allItems = [SimpleTxOut] -> Set SimpleTxOut
forall a. Ord a => [a] -> Set a
Set.fromList [SimpleId -> SimpleTxOut
SimpleTxOut SimpleId
i | SimpleId
i <- [SimpleId
1 .. Int -> SimpleId
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
total]]
            -- Adversarial distribution: the LAST fanoutChunkSize items, not the first.
            attackedDistributed :: Set SimpleTxOut
attackedDistributed =
              [SimpleTxOut] -> Set SimpleTxOut
forall a. Ord a => [a] -> Set a
Set.fromList
                [SimpleId -> SimpleTxOut
SimpleTxOut SimpleId
i | SimpleId
i <- [Int -> SimpleId
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
total Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
fanoutChunkSize Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) .. Int -> SimpleId
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
total]]
            st :: NodeState SimpleTx
st = [Party] -> Set SimpleTxOut -> NodeState SimpleTx
inAutoDrainProgress [Party]
threeParties Set SimpleTxOut
allItems
        UTCTime
now <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
st.chainPointTime.currentSlot
        let outcome :: Outcome SimpleTx
outcome =
              Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update
                Environment
bobEnv
                Ledger SimpleTx
ledger
                UTCTime
now
                NodeState SimpleTx
st
                (OnChainTx SimpleTx -> Input SimpleTx
observeTx OnPartialFanoutTx{$sel:headId:OnInitTx :: HeadId
headId = HeadId
testHeadId, distributedOutputs :: UTxOType SimpleTx
distributedOutputs = Set SimpleTxOut
UTxOType SimpleTx
attackedDistributed})
        Outcome SimpleTx
outcome Outcome SimpleTx -> (StateChanged SimpleTx -> Bool) -> IO ()
forall tx.
(HasCallStack, IsChainState tx) =>
Outcome tx -> (StateChanged tx -> Bool) -> IO ()
`hasStateChangedSatisfying` \case
          HeadPartialFannedOut{UTxOType SimpleTx
$sel:remainingOutputs:NetworkConnected :: forall tx. StateChanged tx -> UTxOType tx
remainingOutputs :: UTxOType SimpleTx
remainingOutputs} ->
            Set SimpleTxOut
UTxOType SimpleTx
remainingOutputs Set SimpleTxOut -> Set SimpleTxOut -> Bool
forall a. Eq a => a -> a -> Bool
== Set SimpleTxOut -> Set SimpleTxOut -> Set SimpleTxOut
forall a. Ord a => Set a -> Set a -> Set a
Set.difference Set SimpleTxOut
allItems Set SimpleTxOut
attackedDistributed
          StateChanged SimpleTx
_ -> Bool
False

      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"partial fanout with small remaining triggers FinalPartialFanoutTx" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        let smallRemaining :: Set SimpleTxOut
smallRemaining = [SimpleTxOut] -> Set SimpleTxOut
forall a. Ord a => [a] -> Set a
Set.fromList [SimpleId -> SimpleTxOut
SimpleTxOut SimpleId
1, SimpleId -> SimpleTxOut
SimpleTxOut SimpleId
2]
            st :: NodeState SimpleTx
st = [Party] -> Set SimpleTxOut -> NodeState SimpleTx
inAutoDrainProgress [Party]
threeParties Set SimpleTxOut
smallRemaining
        UTCTime
now <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
st.chainPointTime.currentSlot
        let outcome :: Outcome SimpleTx
outcome = Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
st (OnChainTx SimpleTx -> Input SimpleTx
observeTx OnPartialFanoutTx{$sel:headId:OnInitTx :: HeadId
headId = HeadId
testHeadId, distributedOutputs :: UTxOType SimpleTx
distributedOutputs = Set SimpleTxOut
UTxOType SimpleTx
forall a. Monoid a => a
mempty})
        Outcome SimpleTx
outcome Outcome SimpleTx -> (Effect SimpleTx -> Bool) -> IO ()
forall tx.
(HasCallStack, IsChainState tx) =>
Outcome tx -> (Effect tx -> Bool) -> IO ()
`hasEffectSatisfying` \case
          OnChainEffect{$sel:postChainTx:ClientEffect :: forall tx. Effect tx -> PostChainTx tx
postChainTx = FinalPartialFanoutTx{UTxOType SimpleTx
$sel:utxoToDistribute:InitTx :: forall tx. PostChainTx tx -> UTxOType tx
utxoToDistribute :: UTxOType SimpleTx
utxoToDistribute}} -> Set SimpleTxOut
UTxOType SimpleTx
utxoToDistribute Set SimpleTxOut -> Set SimpleTxOut -> Bool
forall a. Eq a => a -> a -> Bool
== Set SimpleTxOut
smallRemaining
          Effect SimpleTx
_ -> Bool
False

      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"client partial fanout selecting all remaining UTxO drains via FinalPartialFanoutTx" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        let remaining :: Set SimpleTxOut
remaining = [SimpleTxOut] -> Set SimpleTxOut
forall a. Ord a => [a] -> Set a
Set.fromList [SimpleId -> SimpleTxOut
SimpleTxOut SimpleId
3, SimpleId -> SimpleTxOut
SimpleTxOut SimpleId
4]
            st :: NodeState SimpleTx
st = [Party] -> Set SimpleTxOut -> NodeState SimpleTx
inAutoDrainProgress [Party]
threeParties Set SimpleTxOut
remaining
        UTCTime
now <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
st.chainPointTime.currentSlot
        let outcome :: Outcome SimpleTx
outcome = Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
st (ClientInput SimpleTx -> Input SimpleTx
forall tx. ClientInput tx -> Input tx
ClientInput (UTxOType SimpleTx -> ClientInput SimpleTx
forall tx. UTxOType tx -> ClientInput tx
PartialFanout Set SimpleTxOut
UTxOType SimpleTx
remaining))
        Outcome SimpleTx
outcome Outcome SimpleTx -> (Effect SimpleTx -> Bool) -> IO ()
forall tx.
(HasCallStack, IsChainState tx) =>
Outcome tx -> (Effect tx -> Bool) -> IO ()
`hasEffectSatisfying` \case
          OnChainEffect{$sel:postChainTx:ClientEffect :: forall tx. Effect tx -> PostChainTx tx
postChainTx = FinalPartialFanoutTx{UTxOType SimpleTx
$sel:utxoToDistribute:InitTx :: forall tx. PostChainTx tx -> UTxOType tx
utxoToDistribute :: UTxOType SimpleTx
utxoToDistribute}} -> Set SimpleTxOut
UTxOType SimpleTx
utxoToDistribute Set SimpleTxOut -> Set SimpleTxOut -> Bool
forall a. Eq a => a -> a -> Bool
== Set SimpleTxOut
remaining
          Effect SimpleTx
_ -> Bool
False

      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"an awaiting (observer) node can drive the next step with its own PartialFanout" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        -- A node that only observed someone else's partial fanout sits in
        -- 'AwaitingSelection'; issuing its own 'PartialFanout' makes it the driver
        -- for that step (posts a non-final PartialFanoutTx for the subset). This is
        -- the "continue the fanout from a different party" path.
        let remaining :: Set SimpleTxOut
remaining = [SimpleTxOut] -> Set SimpleTxOut
forall a. Ord a => [a] -> Set a
Set.fromList [SimpleId -> SimpleTxOut
SimpleTxOut SimpleId
1, SimpleId -> SimpleTxOut
SimpleTxOut SimpleId
2, SimpleId -> SimpleTxOut
SimpleTxOut SimpleId
3]
            selection :: Set SimpleTxOut
selection = [SimpleTxOut] -> Set SimpleTxOut
forall a. Ord a => [a] -> Set a
Set.fromList [SimpleId -> SimpleTxOut
SimpleTxOut SimpleId
1]
            st :: NodeState SimpleTx
st = [Party]
-> Set SimpleTxOut -> FanoutMode SimpleTx -> NodeState SimpleTx
inFanoutProgressWith [Party]
threeParties Set SimpleTxOut
remaining FanoutMode SimpleTx
forall tx. FanoutMode tx
AwaitingSelection
        UTCTime
now <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
st.chainPointTime.currentSlot
        let outcome :: Outcome SimpleTx
outcome = Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
st (ClientInput SimpleTx -> Input SimpleTx
forall tx. ClientInput tx -> Input tx
ClientInput (UTxOType SimpleTx -> ClientInput SimpleTx
forall tx. UTxOType tx -> ClientInput tx
PartialFanout Set SimpleTxOut
UTxOType SimpleTx
selection))
        Outcome SimpleTx
outcome Outcome SimpleTx -> (Effect SimpleTx -> Bool) -> IO ()
forall tx.
(HasCallStack, IsChainState tx) =>
Outcome tx -> (Effect tx -> Bool) -> IO ()
`hasEffectSatisfying` \case
          OnChainEffect{$sel:postChainTx:ClientEffect :: forall tx. Effect tx -> PostChainTx tx
postChainTx = PartialFanoutTx{UTxOType SimpleTx
$sel:utxoToDistribute:InitTx :: forall tx. PostChainTx tx -> UTxOType tx
utxoToDistribute :: UTxOType SimpleTx
utxoToDistribute}} -> Set SimpleTxOut
UTxOType SimpleTx
utxoToDistribute Set SimpleTxOut -> Set SimpleTxOut -> Bool
forall a. Eq a => a -> a -> Bool
== Set SimpleTxOut
selection
          Effect SimpleTx
_ -> Bool
False
        case NodeState SimpleTx -> HeadState SimpleTx
forall tx. NodeState tx -> HeadState tx
headState (NodeState SimpleTx -> Outcome SimpleTx -> NodeState SimpleTx
forall tx.
IsChainState tx =>
NodeState tx -> Outcome tx -> NodeState tx
aggregateState NodeState SimpleTx
st Outcome SimpleTx
outcome) of
          FanoutProgress PartialFanoutState{$sel:mode:PartialFanoutState :: forall tx. PartialFanoutState tx -> FanoutMode tx
mode = DistributingSelection UTxOType SimpleTx
sel} -> Set SimpleTxOut
UTxOType SimpleTx
sel Set SimpleTxOut -> Set SimpleTxOut -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Set SimpleTxOut
selection
          HeadState SimpleTx
other -> String -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Expected FanoutProgress DistributingSelection, got: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> HeadState SimpleTx -> String
forall b a. (Show a, IsString b) => a -> b
show HeadState SimpleTx
other

      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"selective fanout that drains the whole remaining set finalizes instead of wedging" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        -- Regression: a 'DistributingSelection' step whose observed distribution
        -- empties 'remaining' (e.g. a chunk drained everything because a pre-settled
        -- UTxO kept the on-chain accumulator non-empty) must still emit the burning
        -- FinalPartialFanoutTx — not stop at AwaitingSelection and wedge the head.
        let remaining :: Set SimpleTxOut
remaining = [SimpleTxOut] -> Set SimpleTxOut
forall a. Ord a => [a] -> Set a
Set.fromList [SimpleId -> SimpleTxOut
SimpleTxOut SimpleId
1, SimpleId -> SimpleTxOut
SimpleTxOut SimpleId
2]
            st :: NodeState SimpleTx
st = [Party]
-> Set SimpleTxOut -> FanoutMode SimpleTx -> NodeState SimpleTx
inFanoutProgressWith [Party]
threeParties Set SimpleTxOut
remaining (UTxOType SimpleTx -> FanoutMode SimpleTx
forall tx. UTxOType tx -> FanoutMode tx
DistributingSelection Set SimpleTxOut
UTxOType SimpleTx
remaining)
        UTCTime
now <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
st.chainPointTime.currentSlot
        let outcome :: Outcome SimpleTx
outcome = Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
st (OnChainTx SimpleTx -> Input SimpleTx
observeTx OnPartialFanoutTx{$sel:headId:OnInitTx :: HeadId
headId = HeadId
testHeadId, distributedOutputs :: UTxOType SimpleTx
distributedOutputs = Set SimpleTxOut
UTxOType SimpleTx
remaining})
        Outcome SimpleTx
outcome Outcome SimpleTx -> (Effect SimpleTx -> Bool) -> IO ()
forall tx.
(HasCallStack, IsChainState tx) =>
Outcome tx -> (Effect tx -> Bool) -> IO ()
`hasEffectSatisfying` \case
          OnChainEffect{$sel:postChainTx:ClientEffect :: forall tx. Effect tx -> PostChainTx tx
postChainTx = FinalPartialFanoutTx{}} -> Bool
True
          Effect SimpleTx
_ -> Bool
False

      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"client PartialFanout from Closed selects a subset and enters FanoutProgress" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        let fullUTxO :: Set SimpleTxOut
fullUTxO = [SimpleTxOut] -> Set SimpleTxOut
forall a. Ord a => [a] -> Set a
Set.fromList [SimpleId -> SimpleTxOut
SimpleTxOut SimpleId
1, SimpleId -> SimpleTxOut
SimpleTxOut SimpleId
2, SimpleId -> SimpleTxOut
SimpleTxOut SimpleId
3]
            selection :: Set SimpleTxOut
selection = [SimpleTxOut] -> Set SimpleTxOut
forall a. Ord a => [a] -> Set a
Set.fromList [SimpleId -> SimpleTxOut
SimpleTxOut SimpleId
1, SimpleId -> SimpleTxOut
SimpleTxOut SimpleId
2]
            snap :: Snapshot SimpleTx
snap = SnapshotNumber
-> SnapshotVersion
-> [SimpleTx]
-> UTxOType SimpleTx
-> Snapshot SimpleTx
forall tx.
IsTx tx =>
SnapshotNumber
-> SnapshotVersion -> [tx] -> UTxOType tx -> Snapshot tx
testSnapshot SnapshotNumber
1 SnapshotVersion
0 [] Set SimpleTxOut
UTxOType SimpleTx
fullUTxO
            st :: NodeState SimpleTx
st = [Party] -> ConfirmedSnapshot SimpleTx -> NodeState SimpleTx
inClosedState' [Party]
threeParties (Snapshot SimpleTx
-> MultiSignature (Snapshot SimpleTx) -> ConfirmedSnapshot SimpleTx
forall tx.
Snapshot tx -> MultiSignature (Snapshot tx) -> ConfirmedSnapshot tx
ConfirmedSnapshot Snapshot SimpleTx
snap ([Signature (Snapshot SimpleTx)]
-> MultiSignature (Snapshot SimpleTx)
forall a. [Signature a] -> MultiSignature a
Crypto.aggregate []))
        UTCTime
now <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
st.chainPointTime.currentSlot
        let outcome :: Outcome SimpleTx
outcome = Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
st (ClientInput SimpleTx -> Input SimpleTx
forall tx. ClientInput tx -> Input tx
ClientInput (UTxOType SimpleTx -> ClientInput SimpleTx
forall tx. UTxOType tx -> ClientInput tx
PartialFanout Set SimpleTxOut
UTxOType SimpleTx
selection))
        -- Emits a non-final PartialFanoutTx drawing from the user selection.
        Outcome SimpleTx
outcome Outcome SimpleTx -> (Effect SimpleTx -> Bool) -> IO ()
forall tx.
(HasCallStack, IsChainState tx) =>
Outcome tx -> (Effect tx -> Bool) -> IO ()
`hasEffectSatisfying` \case
          OnChainEffect{$sel:postChainTx:ClientEffect :: forall tx. Effect tx -> PostChainTx tx
postChainTx = PartialFanoutTx{UTxOType SimpleTx
$sel:utxoToDistribute:InitTx :: forall tx. PostChainTx tx -> UTxOType tx
utxoToDistribute :: UTxOType SimpleTx
utxoToDistribute}} -> Set SimpleTxOut
UTxOType SimpleTx
utxoToDistribute Set SimpleTxOut -> Set SimpleTxOut -> Bool
forall a. Eq a => a -> a -> Bool
== Set SimpleTxOut
selection
          Effect SimpleTx
_ -> Bool
False
        -- And transitions the head into FanoutProgress with the full remaining set.
        case NodeState SimpleTx -> HeadState SimpleTx
forall tx. NodeState tx -> HeadState tx
headState (NodeState SimpleTx -> Outcome SimpleTx -> NodeState SimpleTx
forall tx.
IsChainState tx =>
NodeState tx -> Outcome tx -> NodeState tx
aggregateState NodeState SimpleTx
st Outcome SimpleTx
outcome) of
          FanoutProgress PartialFanoutState{UTxOType SimpleTx
$sel:remainingOutputs:PartialFanoutState :: forall tx. PartialFanoutState tx -> UTxOType tx
remainingOutputs :: UTxOType SimpleTx
remainingOutputs} -> Set SimpleTxOut
UTxOType SimpleTx
remainingOutputs Set SimpleTxOut -> Set SimpleTxOut -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Set SimpleTxOut
fullUTxO
          HeadState SimpleTx
other -> String -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Expected FanoutProgress state, got: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> HeadState SimpleTx -> String
forall b a. (Show a, IsString b) => a -> b
show HeadState SimpleTx
other

      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"client PartialFanout selecting ALL of a fresh head delegates to the full Fanout" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        -- Selecting everything is a full fanout: it must post a FanoutTx (auto
        -- drain), not an impossible non-final PartialFanoutTx of the whole set.
        let fullUTxO :: Set SimpleTxOut
fullUTxO = [SimpleTxOut] -> Set SimpleTxOut
forall a. Ord a => [a] -> Set a
Set.fromList [SimpleId -> SimpleTxOut
SimpleTxOut SimpleId
1, SimpleId -> SimpleTxOut
SimpleTxOut SimpleId
2, SimpleId -> SimpleTxOut
SimpleTxOut SimpleId
3]
            snap :: Snapshot SimpleTx
snap = SnapshotNumber
-> SnapshotVersion
-> [SimpleTx]
-> UTxOType SimpleTx
-> Snapshot SimpleTx
forall tx.
IsTx tx =>
SnapshotNumber
-> SnapshotVersion -> [tx] -> UTxOType tx -> Snapshot tx
testSnapshot SnapshotNumber
1 SnapshotVersion
0 [] Set SimpleTxOut
UTxOType SimpleTx
fullUTxO
            st :: NodeState SimpleTx
st = [Party] -> ConfirmedSnapshot SimpleTx -> NodeState SimpleTx
inClosedState' [Party]
threeParties (Snapshot SimpleTx
-> MultiSignature (Snapshot SimpleTx) -> ConfirmedSnapshot SimpleTx
forall tx.
Snapshot tx -> MultiSignature (Snapshot tx) -> ConfirmedSnapshot tx
ConfirmedSnapshot Snapshot SimpleTx
snap ([Signature (Snapshot SimpleTx)]
-> MultiSignature (Snapshot SimpleTx)
forall a. [Signature a] -> MultiSignature a
Crypto.aggregate []))
        UTCTime
now <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
st.chainPointTime.currentSlot
        let outcome :: Outcome SimpleTx
outcome = Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
st (ClientInput SimpleTx -> Input SimpleTx
forall tx. ClientInput tx -> Input tx
ClientInput (UTxOType SimpleTx -> ClientInput SimpleTx
forall tx. UTxOType tx -> ClientInput tx
PartialFanout Set SimpleTxOut
UTxOType SimpleTx
fullUTxO))
        Outcome SimpleTx
outcome Outcome SimpleTx -> (Effect SimpleTx -> Bool) -> IO ()
forall tx.
(HasCallStack, IsChainState tx) =>
Outcome tx -> (Effect tx -> Bool) -> IO ()
`hasEffectSatisfying` \case
          OnChainEffect{$sel:postChainTx:ClientEffect :: forall tx. Effect tx -> PostChainTx tx
postChainTx = FanoutTx{}} -> Bool
True
          Effect SimpleTx
_ -> Bool
False

      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Fanout is rejected once a partial fanout is in progress (sticky)" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        let st :: NodeState SimpleTx
st = [Party] -> Set SimpleTxOut -> NodeState SimpleTx
inAutoDrainProgress [Party]
threeParties ([SimpleTxOut] -> Set SimpleTxOut
forall a. Ord a => [a] -> Set a
Set.fromList [SimpleId -> SimpleTxOut
SimpleTxOut SimpleId
1, SimpleId -> SimpleTxOut
SimpleTxOut SimpleId
2])
        UTCTime
now <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
st.chainPointTime.currentSlot
        let outcome :: Outcome SimpleTx
outcome = Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
st (ClientInput SimpleTx -> Input SimpleTx
forall tx. ClientInput tx -> Input tx
ClientInput ClientInput SimpleTx
forall tx. ClientInput tx
Fanout)
        Outcome SimpleTx
outcome Outcome SimpleTx -> (Effect SimpleTx -> Bool) -> IO ()
forall tx.
(HasCallStack, IsChainState tx) =>
Outcome tx -> (Effect tx -> Bool) -> IO ()
`hasEffectSatisfying` \case
          ClientEffect{$sel:clientMessage:ClientEffect :: forall tx. Effect tx -> ClientMessage tx
clientMessage = CommandFailed{}} -> Bool
True
          Effect SimpleTx
_ -> Bool
False

      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"PartialFanout with an empty selection fails" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        let st :: NodeState SimpleTx
st = [Party] -> Set SimpleTxOut -> NodeState SimpleTx
inAutoDrainProgress [Party]
threeParties ([SimpleTxOut] -> Set SimpleTxOut
forall a. Ord a => [a] -> Set a
Set.fromList [SimpleId -> SimpleTxOut
SimpleTxOut SimpleId
1])
        UTCTime
now <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
st.chainPointTime.currentSlot
        let outcome :: Outcome SimpleTx
outcome = Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
st (ClientInput SimpleTx -> Input SimpleTx
forall tx. ClientInput tx -> Input tx
ClientInput (UTxOType SimpleTx -> ClientInput SimpleTx
forall tx. UTxOType tx -> ClientInput tx
PartialFanout Set SimpleTxOut
UTxOType SimpleTx
forall a. Monoid a => a
mempty))
        Outcome SimpleTx
outcome Outcome SimpleTx -> (Effect SimpleTx -> Bool) -> IO ()
forall tx.
(HasCallStack, IsChainState tx) =>
Outcome tx -> (Effect tx -> Bool) -> IO ()
`hasEffectSatisfying` \case
          ClientEffect{$sel:clientMessage:ClientEffect :: forall tx. Effect tx -> ClientMessage tx
clientMessage = CommandFailed{}} -> Bool
True
          Effect SimpleTx
_ -> Bool
False

      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"PartialFanout with a non-subset selection fails" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        let remaining :: Set SimpleTxOut
remaining = [SimpleTxOut] -> Set SimpleTxOut
forall a. Ord a => [a] -> Set a
Set.fromList [SimpleId -> SimpleTxOut
SimpleTxOut SimpleId
1, SimpleId -> SimpleTxOut
SimpleTxOut SimpleId
2]
            notInRemaining :: Set SimpleTxOut
notInRemaining = [SimpleTxOut] -> Set SimpleTxOut
forall a. Ord a => [a] -> Set a
Set.fromList [SimpleId -> SimpleTxOut
SimpleTxOut SimpleId
9]
            st :: NodeState SimpleTx
st = [Party] -> Set SimpleTxOut -> NodeState SimpleTx
inAutoDrainProgress [Party]
threeParties Set SimpleTxOut
remaining
        UTCTime
now <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
st.chainPointTime.currentSlot
        let outcome :: Outcome SimpleTx
outcome = Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
st (ClientInput SimpleTx -> Input SimpleTx
forall tx. ClientInput tx -> Input tx
ClientInput (UTxOType SimpleTx -> ClientInput SimpleTx
forall tx. UTxOType tx -> ClientInput tx
PartialFanout Set SimpleTxOut
UTxOType SimpleTx
notInRemaining))
        Outcome SimpleTx
outcome Outcome SimpleTx -> (Effect SimpleTx -> Bool) -> IO ()
forall tx.
(HasCallStack, IsChainState tx) =>
Outcome tx -> (Effect tx -> Bool) -> IO ()
`hasEffectSatisfying` \case
          ClientEffect{$sel:clientMessage:ClientEffect :: forall tx. Effect tx -> ClientMessage tx
clientMessage = CommandFailed{}} -> Bool
True
          Effect SimpleTx
_ -> Bool
False

      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"reverts to Closed when the initiating Fanout tx fails to post before anything landed" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        -- The optimistic Closed -> FanoutProgress transition (which makes this
        -- node the fanout driver) must be rolled back if posting the initiating
        -- tx fails terminally before any partial fanout has landed on chain;
        -- otherwise the head wedges in FanoutProgress with Fanout rejected.
        let fullUTxO :: Set SimpleTxOut
fullUTxO = [SimpleTxOut] -> Set SimpleTxOut
forall a. Ord a => [a] -> Set a
Set.fromList [SimpleId -> SimpleTxOut
SimpleTxOut SimpleId
1, SimpleId -> SimpleTxOut
SimpleTxOut SimpleId
2, SimpleId -> SimpleTxOut
SimpleTxOut SimpleId
3]
            snap :: Snapshot SimpleTx
snap = SnapshotNumber
-> SnapshotVersion
-> [SimpleTx]
-> UTxOType SimpleTx
-> Snapshot SimpleTx
forall tx.
IsTx tx =>
SnapshotNumber
-> SnapshotVersion -> [tx] -> UTxOType tx -> Snapshot tx
testSnapshot SnapshotNumber
1 SnapshotVersion
0 [] Set SimpleTxOut
UTxOType SimpleTx
fullUTxO
            st :: NodeState SimpleTx
st = [Party] -> ConfirmedSnapshot SimpleTx -> NodeState SimpleTx
inClosedState' [Party]
threeParties (Snapshot SimpleTx
-> MultiSignature (Snapshot SimpleTx) -> ConfirmedSnapshot SimpleTx
forall tx.
Snapshot tx -> MultiSignature (Snapshot tx) -> ConfirmedSnapshot tx
ConfirmedSnapshot Snapshot SimpleTx
snap ([Signature (Snapshot SimpleTx)]
-> MultiSignature (Snapshot SimpleTx)
forall a. [Signature a] -> MultiSignature a
Crypto.aggregate []))
        UTCTime
now <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
st.chainPointTime.currentSlot
        let initiated :: Outcome SimpleTx
initiated = Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
st (ClientInput SimpleTx -> Input SimpleTx
forall tx. ClientInput tx -> Input tx
ClientInput ClientInput SimpleTx
forall tx. ClientInput tx
Fanout)
            st1 :: NodeState SimpleTx
st1 = NodeState SimpleTx -> Outcome SimpleTx -> NodeState SimpleTx
forall tx.
IsChainState tx =>
NodeState tx -> Outcome tx -> NodeState tx
aggregateState NodeState SimpleTx
st Outcome SimpleTx
initiated
        -- Sanity: optimistically in FanoutProgress with nothing distributed yet.
        case NodeState SimpleTx -> HeadState SimpleTx
forall tx. NodeState tx -> HeadState tx
headState NodeState SimpleTx
st1 of
          FanoutProgress PartialFanoutState{UTxOType SimpleTx
$sel:distributedOutputs:PartialFanoutState :: forall tx. PartialFanoutState tx -> UTxOType tx
distributedOutputs :: UTxOType SimpleTx
distributedOutputs} -> Set SimpleTxOut
UTxOType SimpleTx
distributedOutputs Set SimpleTxOut -> Set SimpleTxOut -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Set SimpleTxOut
forall a. Monoid a => a
mempty
          HeadState SimpleTx
other -> String -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Expected FanoutProgress, got: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> HeadState SimpleTx -> String
forall b a. (Show a, IsString b) => a -> b
show HeadState SimpleTx
other
        PostChainTx SimpleTx
postedTx <- case [PostChainTx SimpleTx
postChainTx | OnChainEffect{PostChainTx SimpleTx
$sel:postChainTx:ClientEffect :: forall tx. Effect tx -> PostChainTx tx
postChainTx :: PostChainTx SimpleTx
postChainTx} <- Outcome SimpleTx -> [Effect SimpleTx]
forall tx. Outcome tx -> [Effect tx]
effectsOf Outcome SimpleTx
initiated] of
          PostChainTx SimpleTx
tx : [PostChainTx SimpleTx]
_ -> PostChainTx SimpleTx -> IO (PostChainTx SimpleTx)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PostChainTx SimpleTx
tx
          [] -> String -> IO (PostChainTx SimpleTx)
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure String
"Expected a posted fanout tx from the initiating Fanout"
        let failed :: Outcome SimpleTx
failed =
              Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
st1 (Input SimpleTx -> Outcome SimpleTx)
-> (ChainEvent SimpleTx -> Input SimpleTx)
-> ChainEvent SimpleTx
-> Outcome SimpleTx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainEvent SimpleTx -> Input SimpleTx
forall tx. ChainEvent tx -> Input tx
ChainInput (ChainEvent SimpleTx -> Outcome SimpleTx)
-> ChainEvent SimpleTx -> Outcome SimpleTx
forall a b. (a -> b) -> a -> b
$
                PostTxError
                  { $sel:postChainTx:Observation :: PostChainTx SimpleTx
postChainTx = PostChainTx SimpleTx
postedTx
                  , $sel:postTxError:Observation :: PostTxError SimpleTx
postTxError = PostTxError SimpleTx
forall tx. PostTxError tx
FailedToConstructPartialFanoutTx
                  , $sel:failingTx:Observation :: Maybe SimpleTx
failingTx = Maybe SimpleTx
forall a. Maybe a
Nothing
                  }
        -- Reverts the head back to Closed and still reports the failure.
        Outcome SimpleTx
failed Outcome SimpleTx -> (StateChanged SimpleTx -> Bool) -> IO ()
forall tx.
(HasCallStack, IsChainState tx) =>
Outcome tx -> (StateChanged tx -> Bool) -> IO ()
`hasStateChangedSatisfying` \case
          HeadFanoutReverted{} -> Bool
True
          StateChanged SimpleTx
_ -> Bool
False
        Outcome SimpleTx
failed Outcome SimpleTx -> (Effect SimpleTx -> Bool) -> IO ()
forall tx.
(HasCallStack, IsChainState tx) =>
Outcome tx -> (Effect tx -> Bool) -> IO ()
`hasEffectSatisfying` \case
          ClientEffect{$sel:clientMessage:ClientEffect :: forall tx. Effect tx -> ClientMessage tx
clientMessage = PostTxOnChainFailed{}} -> Bool
True
          Effect SimpleTx
_ -> Bool
False
        case NodeState SimpleTx -> HeadState SimpleTx
forall tx. NodeState tx -> HeadState tx
headState (NodeState SimpleTx -> Outcome SimpleTx -> NodeState SimpleTx
forall tx.
IsChainState tx =>
NodeState tx -> Outcome tx -> NodeState tx
aggregateState NodeState SimpleTx
st1 Outcome SimpleTx
failed) of
          Closed ClosedState{Bool
readyToFanoutSent :: Bool
$sel:readyToFanoutSent:ClosedState :: forall tx. ClosedState tx -> Bool
readyToFanoutSent} -> Bool
readyToFanoutSent Bool -> Bool -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Bool
True
          HeadState SimpleTx
other -> String -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Expected Closed after revert, got: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> HeadState SimpleTx -> String
forall b a. (Show a, IsString b) => a -> b
show HeadState SimpleTx
other

      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"reverts to Closed when a selective PartialFanout tx fails to post before anything landed" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        let fullUTxO :: Set SimpleTxOut
fullUTxO = [SimpleTxOut] -> Set SimpleTxOut
forall a. Ord a => [a] -> Set a
Set.fromList [SimpleId -> SimpleTxOut
SimpleTxOut SimpleId
1, SimpleId -> SimpleTxOut
SimpleTxOut SimpleId
2, SimpleId -> SimpleTxOut
SimpleTxOut SimpleId
3]
            selection :: Set SimpleTxOut
selection = [SimpleTxOut] -> Set SimpleTxOut
forall a. Ord a => [a] -> Set a
Set.fromList [SimpleId -> SimpleTxOut
SimpleTxOut SimpleId
1, SimpleId -> SimpleTxOut
SimpleTxOut SimpleId
2]
            snap :: Snapshot SimpleTx
snap = SnapshotNumber
-> SnapshotVersion
-> [SimpleTx]
-> UTxOType SimpleTx
-> Snapshot SimpleTx
forall tx.
IsTx tx =>
SnapshotNumber
-> SnapshotVersion -> [tx] -> UTxOType tx -> Snapshot tx
testSnapshot SnapshotNumber
1 SnapshotVersion
0 [] Set SimpleTxOut
UTxOType SimpleTx
fullUTxO
            st :: NodeState SimpleTx
st = [Party] -> ConfirmedSnapshot SimpleTx -> NodeState SimpleTx
inClosedState' [Party]
threeParties (Snapshot SimpleTx
-> MultiSignature (Snapshot SimpleTx) -> ConfirmedSnapshot SimpleTx
forall tx.
Snapshot tx -> MultiSignature (Snapshot tx) -> ConfirmedSnapshot tx
ConfirmedSnapshot Snapshot SimpleTx
snap ([Signature (Snapshot SimpleTx)]
-> MultiSignature (Snapshot SimpleTx)
forall a. [Signature a] -> MultiSignature a
Crypto.aggregate []))
        UTCTime
now <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
st.chainPointTime.currentSlot
        let initiated :: Outcome SimpleTx
initiated = Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
st (ClientInput SimpleTx -> Input SimpleTx
forall tx. ClientInput tx -> Input tx
ClientInput (UTxOType SimpleTx -> ClientInput SimpleTx
forall tx. UTxOType tx -> ClientInput tx
PartialFanout Set SimpleTxOut
UTxOType SimpleTx
selection))
            st1 :: NodeState SimpleTx
st1 = NodeState SimpleTx -> Outcome SimpleTx -> NodeState SimpleTx
forall tx.
IsChainState tx =>
NodeState tx -> Outcome tx -> NodeState tx
aggregateState NodeState SimpleTx
st Outcome SimpleTx
initiated
        PostChainTx SimpleTx
postedTx <- case [PostChainTx SimpleTx
postChainTx | OnChainEffect{PostChainTx SimpleTx
$sel:postChainTx:ClientEffect :: forall tx. Effect tx -> PostChainTx tx
postChainTx :: PostChainTx SimpleTx
postChainTx} <- Outcome SimpleTx -> [Effect SimpleTx]
forall tx. Outcome tx -> [Effect tx]
effectsOf Outcome SimpleTx
initiated] of
          PostChainTx SimpleTx
tx : [PostChainTx SimpleTx]
_ -> PostChainTx SimpleTx -> IO (PostChainTx SimpleTx)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PostChainTx SimpleTx
tx
          [] -> String -> IO (PostChainTx SimpleTx)
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure String
"Expected a posted partial fanout tx from the initiating PartialFanout"
        let failed :: Outcome SimpleTx
failed =
              Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
st1 (Input SimpleTx -> Outcome SimpleTx)
-> (ChainEvent SimpleTx -> Input SimpleTx)
-> ChainEvent SimpleTx
-> Outcome SimpleTx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainEvent SimpleTx -> Input SimpleTx
forall tx. ChainEvent tx -> Input tx
ChainInput (ChainEvent SimpleTx -> Outcome SimpleTx)
-> ChainEvent SimpleTx -> Outcome SimpleTx
forall a b. (a -> b) -> a -> b
$
                PostTxError
                  { $sel:postChainTx:Observation :: PostChainTx SimpleTx
postChainTx = PostChainTx SimpleTx
postedTx
                  , $sel:postTxError:Observation :: PostTxError SimpleTx
postTxError = PostTxError SimpleTx
forall tx. PostTxError tx
FailedToConstructPartialFanoutTx
                  , $sel:failingTx:Observation :: Maybe SimpleTx
failingTx = Maybe SimpleTx
forall a. Maybe a
Nothing
                  }
        Outcome SimpleTx
failed Outcome SimpleTx -> (StateChanged SimpleTx -> Bool) -> IO ()
forall tx.
(HasCallStack, IsChainState tx) =>
Outcome tx -> (StateChanged tx -> Bool) -> IO ()
`hasStateChangedSatisfying` \case
          HeadFanoutReverted{} -> Bool
True
          StateChanged SimpleTx
_ -> Bool
False
        case NodeState SimpleTx -> HeadState SimpleTx
forall tx. NodeState tx -> HeadState tx
headState (NodeState SimpleTx -> Outcome SimpleTx -> NodeState SimpleTx
forall tx.
IsChainState tx =>
NodeState tx -> Outcome tx -> NodeState tx
aggregateState NodeState SimpleTx
st1 Outcome SimpleTx
failed) of
          Closed{} -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          HeadState SimpleTx
other -> String -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Expected Closed after revert, got: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> HeadState SimpleTx -> String
forall b a. (Show a, IsString b) => a -> b
show HeadState SimpleTx
other

      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"does NOT revert once a partial fanout has landed on chain" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        -- With outputs already distributed the on-chain datum is genuinely
        -- FanoutProgress, so a later post failure must NOT roll back to Closed.
        let remaining :: Set SimpleTxOut
remaining = [SimpleTxOut] -> Set SimpleTxOut
forall a. Ord a => [a] -> Set a
Set.fromList [SimpleId -> SimpleTxOut
SimpleTxOut SimpleId
1, SimpleId -> SimpleTxOut
SimpleTxOut SimpleId
2]
            st :: NodeState SimpleTx
st = [Party] -> Set SimpleTxOut -> NodeState SimpleTx
inAutoDrainProgress [Party]
threeParties Set SimpleTxOut
remaining
        UTCTime
now <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
st.chainPointTime.currentSlot
        let failed :: Outcome SimpleTx
failed =
              Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
st (Input SimpleTx -> Outcome SimpleTx)
-> (ChainEvent SimpleTx -> Input SimpleTx)
-> ChainEvent SimpleTx
-> Outcome SimpleTx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainEvent SimpleTx -> Input SimpleTx
forall tx. ChainEvent tx -> Input tx
ChainInput (ChainEvent SimpleTx -> Outcome SimpleTx)
-> ChainEvent SimpleTx -> Outcome SimpleTx
forall a b. (a -> b) -> a -> b
$
                PostTxError
                  { $sel:postChainTx:Observation :: PostChainTx SimpleTx
postChainTx =
                      PartialFanoutTx
                        { $sel:utxoToDistribute:InitTx :: UTxOType SimpleTx
utxoToDistribute = Set SimpleTxOut
UTxOType SimpleTx
remaining
                        , $sel:utxoForProof:InitTx :: UTxOType SimpleTx
utxoForProof = Set SimpleTxOut
UTxOType SimpleTx
remaining
                        , $sel:headSeed:InitTx :: HeadSeed
headSeed = HeadSeed
testHeadSeed
                        , $sel:contestationDeadline:InitTx :: UTCTime
contestationDeadline = Gen UTCTime
forall a. Arbitrary a => Gen a
arbitrary Gen UTCTime -> Int -> UTCTime
forall a. Gen a -> Int -> a
`generateWith` Int
42
                        }
                  , $sel:postTxError:Observation :: PostTxError SimpleTx
postTxError = PostTxError SimpleTx
forall tx. PostTxError tx
FailedToConstructPartialFanoutTx
                  , $sel:failingTx:Observation :: Maybe SimpleTx
failingTx = Maybe SimpleTx
forall a. Maybe a
Nothing
                  }
        Outcome SimpleTx
failed Outcome SimpleTx -> (StateChanged SimpleTx -> Bool) -> IO ()
forall tx.
(HasCallStack, IsChainState tx) =>
Outcome tx -> (StateChanged tx -> Bool) -> IO ()
`hasNoStateChangedSatisfying` \case
          HeadFanoutReverted{} -> Bool
True
          StateChanged SimpleTx
_ -> Bool
False
        case NodeState SimpleTx -> HeadState SimpleTx
forall tx. NodeState tx -> HeadState tx
headState (NodeState SimpleTx -> Outcome SimpleTx -> NodeState SimpleTx
forall tx.
IsChainState tx =>
NodeState tx -> Outcome tx -> NodeState tx
aggregateState NodeState SimpleTx
st Outcome SimpleTx
failed) of
          FanoutProgress{} -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          HeadState SimpleTx
other -> String -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Expected to stay in FanoutProgress, got: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> HeadState SimpleTx -> String
forall b a. (Show a, IsString b) => a -> b
show HeadState SimpleTx
other

      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"resumes the fanout after a chain rollback instead of stalling" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        -- A rollback mid-fanout may erase the in-flight fanout tx observation. The
        -- node must re-post the next fanout step so the fanout continues; otherwise
        -- it wedges in FanoutProgress with nothing driving it forward. Mirrors the
        -- Increment/Decrement re-post on rollback.
        let fullUTxO :: Set SimpleTxOut
fullUTxO = [SimpleTxOut] -> Set SimpleTxOut
forall a. Ord a => [a] -> Set a
Set.fromList [SimpleId -> SimpleTxOut
SimpleTxOut SimpleId
i | SimpleId
i <- [SimpleId
1 .. SimpleId
5]]
            snap :: Snapshot SimpleTx
snap = SnapshotNumber
-> SnapshotVersion
-> [SimpleTx]
-> UTxOType SimpleTx
-> Snapshot SimpleTx
forall tx.
IsTx tx =>
SnapshotNumber
-> SnapshotVersion -> [tx] -> UTxOType tx -> Snapshot tx
testSnapshot SnapshotNumber
1 SnapshotVersion
0 [] Set SimpleTxOut
UTxOType SimpleTx
fullUTxO
            st0 :: NodeState SimpleTx
st0 = [Party] -> ConfirmedSnapshot SimpleTx -> NodeState SimpleTx
inClosedState' [Party]
threeParties (Snapshot SimpleTx
-> MultiSignature (Snapshot SimpleTx) -> ConfirmedSnapshot SimpleTx
forall tx.
Snapshot tx -> MultiSignature (Snapshot tx) -> ConfirmedSnapshot tx
ConfirmedSnapshot Snapshot SimpleTx
snap ([Signature (Snapshot SimpleTx)]
-> MultiSignature (Snapshot SimpleTx)
forall a. [Signature a] -> MultiSignature a
Crypto.aggregate []))
        UTCTime
now <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
st0.chainPointTime.currentSlot
        -- Become the driver and observe one partial fanout distributing {1,2}.
        let st1 :: NodeState SimpleTx
st1 = NodeState SimpleTx -> Outcome SimpleTx -> NodeState SimpleTx
forall tx.
IsChainState tx =>
NodeState tx -> Outcome tx -> NodeState tx
aggregateState NodeState SimpleTx
st0 (Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
st0 (ClientInput SimpleTx -> Input SimpleTx
forall tx. ClientInput tx -> Input tx
ClientInput ClientInput SimpleTx
forall tx. ClientInput tx
Fanout))
            distributed :: Set SimpleTxOut
distributed = [SimpleTxOut] -> Set SimpleTxOut
forall a. Ord a => [a] -> Set a
Set.fromList [SimpleId -> SimpleTxOut
SimpleTxOut SimpleId
1, SimpleId -> SimpleTxOut
SimpleTxOut SimpleId
2]
            observed :: Outcome SimpleTx
observed = Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
st1 (ChainSlot -> OnChainTx SimpleTx -> Input SimpleTx
observeTxAtSlot ChainSlot
1 OnPartialFanoutTx{$sel:headId:OnInitTx :: HeadId
headId = HeadId
testHeadId, distributedOutputs :: UTxOType SimpleTx
distributedOutputs = Set SimpleTxOut
UTxOType SimpleTx
distributed})
            st2 :: NodeState SimpleTx
st2 = NodeState SimpleTx -> Outcome SimpleTx -> NodeState SimpleTx
forall tx.
IsChainState tx =>
NodeState tx -> Outcome tx -> NodeState tx
aggregateState NodeState SimpleTx
st1 Outcome SimpleTx
observed
        -- Sanity: mid-fanout with a narrowed remaining set.
        case NodeState SimpleTx -> HeadState SimpleTx
forall tx. NodeState tx -> HeadState tx
headState NodeState SimpleTx
st2 of
          FanoutProgress PartialFanoutState{UTxOType SimpleTx
$sel:remainingOutputs:PartialFanoutState :: forall tx. PartialFanoutState tx -> UTxOType tx
remainingOutputs :: UTxOType SimpleTx
remainingOutputs} ->
            Set SimpleTxOut
UTxOType SimpleTx
remainingOutputs Set SimpleTxOut -> Set SimpleTxOut -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` [SimpleTxOut] -> Set SimpleTxOut
forall a. Ord a => [a] -> Set a
Set.fromList [SimpleId -> SimpleTxOut
SimpleTxOut SimpleId
3, SimpleId -> SimpleTxOut
SimpleTxOut SimpleId
4, SimpleId -> SimpleTxOut
SimpleTxOut SimpleId
5]
          HeadState SimpleTx
other -> String -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Expected FanoutProgress, got: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> HeadState SimpleTx -> String
forall b a. (Show a, IsString b) => a -> b
show HeadState SimpleTx
other
        -- Roll back the partial fanout observation; the node must re-post a fanout
        -- step to resume rather than stall.
        let rolledBack :: Outcome SimpleTx
rolledBack = Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
st2 (ChainEvent SimpleTx -> Input SimpleTx
forall tx. ChainEvent tx -> Input tx
ChainInput Rollback{$sel:rolledBackChainState:Observation :: ChainStateType SimpleTx
rolledBackChainState = ChainSlot -> SimpleChainState
SimpleChainState ChainSlot
0, $sel:chainTime:Observation :: UTCTime
chainTime = UTCTime
now})
        Outcome SimpleTx
rolledBack Outcome SimpleTx -> (Effect SimpleTx -> Bool) -> IO ()
forall tx.
(HasCallStack, IsChainState tx) =>
Outcome tx -> (Effect tx -> Bool) -> IO ()
`hasEffectSatisfying` \case
          OnChainEffect{$sel:postChainTx:ClientEffect :: forall tx. Effect tx -> PostChainTx tx
postChainTx = FanoutTx{}} -> Bool
True
          OnChainEffect{$sel:postChainTx:ClientEffect :: forall tx. Effect tx -> PostChainTx tx
postChainTx = FinalPartialFanoutTx{}} -> Bool
True
          OnChainEffect{$sel:postChainTx:ClientEffect :: forall tx. Effect tx -> PostChainTx tx
postChainTx = PartialFanoutTx{}} -> Bool
True
          Effect SimpleTx
_ -> Bool
False

      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"decodes a legacy HeadPartialFannedOut without 'mode' as AwaitingSelection" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        -- Backwards compatibility: events persisted before the 'mode' field
        -- existed must still decode, so a node mid-fanout can restart after
        -- upgrading rather than failing to replay its event log.
        let event :: StateChanged SimpleTx
event =
              HeadPartialFannedOut
                { $sel:headId:NetworkConnected :: HeadId
headId = HeadId
testHeadId
                , distributedOutputs :: UTxOType SimpleTx
distributedOutputs = [SimpleId] -> UTxOType SimpleTx
utxoRefs [SimpleId
1]
                , $sel:remainingOutputs:NetworkConnected :: UTxOType SimpleTx
remainingOutputs = [SimpleId] -> UTxOType SimpleTx
utxoRefs [SimpleId
2]
                , $sel:chainState:NetworkConnected :: ChainStateType SimpleTx
chainState = ChainSlot -> SimpleChainState
SimpleChainState ChainSlot
0
                , $sel:mode:NetworkConnected :: FanoutMode SimpleTx
mode = FanoutMode SimpleTx
forall tx. FanoutMode tx
AutoDrain
                } ::
                StateChanged SimpleTx
            legacy :: Value
legacy = case StateChanged SimpleTx -> Value
forall a. ToJSON a => a -> Value
toJSON StateChanged SimpleTx
event of
              Object Object
o -> Object -> Value
Object (Key -> Object -> Object
forall v. Key -> KeyMap v -> KeyMap v
KeyMap.delete Key
"mode" Object
o)
              Value
v -> Value
v
        case Value -> Result (StateChanged SimpleTx)
forall a. FromJSON a => Value -> Result a
fromJSON Value
legacy :: Result (StateChanged SimpleTx) of
          Success HeadPartialFannedOut{FanoutMode SimpleTx
$sel:mode:NetworkConnected :: forall tx. StateChanged tx -> FanoutMode tx
mode :: FanoutMode SimpleTx
mode} -> FanoutMode SimpleTx
mode FanoutMode SimpleTx -> FanoutMode SimpleTx -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` FanoutMode SimpleTx
forall tx. FanoutMode tx
AwaitingSelection
          Result (StateChanged SimpleTx)
other -> String -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Expected HeadPartialFannedOut, got: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Result (StateChanged SimpleTx) -> String
forall b a. (Show a, IsString b) => a -> b
show Result (StateChanged SimpleTx)
other

      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"records a deposit observed while fanning out (stays recoverable)" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        -- Regression: a deposit observed mid-fanout must be recorded (as when the
        -- head was still Closed), otherwise it is dropped and cannot be recovered.
        let st :: NodeState SimpleTx
st = [Party] -> Set SimpleTxOut -> NodeState SimpleTx
inAutoDrainProgress [Party]
threeParties ([SimpleId] -> UTxOType SimpleTx
utxoRefs [SimpleId
1, SimpleId
2])
        UTCTime
now <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
st.chainPointTime.currentSlot
        let deposit :: OnChainTx SimpleTx
deposit =
              OnDepositTx
                { $sel:headId:OnInitTx :: HeadId
headId = HeadId
testHeadId
                , $sel:depositTxId:OnInitTx :: TxIdType SimpleTx
depositTxId = SimpleId
TxIdType SimpleTx
7
                , $sel:deposited:OnInitTx :: UTxOType SimpleTx
deposited = SimpleId -> UTxOType SimpleTx
utxoRef SimpleId
9
                , $sel:created:OnInitTx :: UTCTime
created = UTCTime
now
                , $sel:deadline:OnInitTx :: UTCTime
deadline = UTCTime
now
                }
            outcome :: Outcome SimpleTx
outcome = Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
st (OnChainTx SimpleTx -> Input SimpleTx
observeTx OnChainTx SimpleTx
deposit)
        Outcome SimpleTx
outcome Outcome SimpleTx -> (StateChanged SimpleTx -> Bool) -> IO ()
forall tx.
(HasCallStack, IsChainState tx) =>
Outcome tx -> (StateChanged tx -> Bool) -> IO ()
`hasStateChangedSatisfying` \case
          DepositRecorded{TxIdType SimpleTx
$sel:depositTxId:NetworkConnected :: forall tx. StateChanged tx -> TxIdType tx
depositTxId :: TxIdType SimpleTx
depositTxId} -> SimpleId
TxIdType SimpleTx
depositTxId SimpleId -> SimpleId -> Bool
forall a. Eq a => a -> a -> Bool
== SimpleId
7
          StateChanged SimpleTx
_ -> Bool
False

      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"client fanout without prior partial fanout uses full snapshot utxo" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        let st :: NodeState SimpleTx
st = [Party] -> NodeState SimpleTx
inClosedState [Party]
threeParties
        UTCTime
now <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
st.chainPointTime.currentSlot
        let outcome :: Outcome SimpleTx
outcome = Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
st (ClientInput SimpleTx -> Input SimpleTx
forall tx. ClientInput tx -> Input tx
ClientInput ClientInput SimpleTx
forall tx. ClientInput tx
Fanout)
        Outcome SimpleTx
outcome Outcome SimpleTx -> (Effect SimpleTx -> Bool) -> IO ()
forall tx.
(HasCallStack, IsChainState tx) =>
Outcome tx -> (Effect tx -> Bool) -> IO ()
`hasEffectSatisfying` \case
          OnChainEffect{$sel:postChainTx:ClientEffect :: forall tx. Effect tx -> PostChainTx tx
postChainTx = FanoutTx{UTxOType SimpleTx
utxo :: UTxOType SimpleTx
$sel:utxo:InitTx :: forall tx. PostChainTx tx -> UTxOType tx
utxo}} -> Set SimpleTxOut
UTxOType SimpleTx
utxo Set SimpleTxOut -> Set SimpleTxOut -> Bool
forall a. Eq a => a -> a -> Bool
== Set SimpleTxOut
forall a. Monoid a => a
mempty
          Effect SimpleTx
_ -> Bool
False

      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"client fanout always triggers FanoutTx for FreshFanout phase" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        let bigUTxO :: Set SimpleTxOut
bigUTxO = [SimpleTxOut] -> Set SimpleTxOut
forall a. Ord a => [a] -> Set a
Set.fromList [SimpleId -> SimpleTxOut
SimpleTxOut SimpleId
i | SimpleId
i <- [SimpleId
1 .. Int -> SimpleId
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
fanoutOutputThreshold SimpleId -> SimpleId -> SimpleId
forall a. Num a => a -> a -> a
+ SimpleId
1]]
            snap :: Snapshot SimpleTx
snap = SnapshotNumber
-> SnapshotVersion
-> [SimpleTx]
-> UTxOType SimpleTx
-> Snapshot SimpleTx
forall tx.
IsTx tx =>
SnapshotNumber
-> SnapshotVersion -> [tx] -> UTxOType tx -> Snapshot tx
testSnapshot SnapshotNumber
1 SnapshotVersion
0 [] Set SimpleTxOut
UTxOType SimpleTx
bigUTxO
            st :: NodeState SimpleTx
st = [Party] -> ConfirmedSnapshot SimpleTx -> NodeState SimpleTx
inClosedState' [Party]
threeParties (Snapshot SimpleTx
-> MultiSignature (Snapshot SimpleTx) -> ConfirmedSnapshot SimpleTx
forall tx.
Snapshot tx -> MultiSignature (Snapshot tx) -> ConfirmedSnapshot tx
ConfirmedSnapshot Snapshot SimpleTx
snap ([Signature (Snapshot SimpleTx)]
-> MultiSignature (Snapshot SimpleTx)
forall a. [Signature a] -> MultiSignature a
Crypto.aggregate []))
        UTCTime
now <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
st.chainPointTime.currentSlot
        let outcome :: Outcome SimpleTx
outcome = Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
st (ClientInput SimpleTx -> Input SimpleTx
forall tx. ClientInput tx -> Input tx
ClientInput ClientInput SimpleTx
forall tx. ClientInput tx
Fanout)
        Outcome SimpleTx
outcome Outcome SimpleTx -> (Effect SimpleTx -> Bool) -> IO ()
forall tx.
(HasCallStack, IsChainState tx) =>
Outcome tx -> (Effect tx -> Bool) -> IO ()
`hasEffectSatisfying` \case
          OnChainEffect{$sel:postChainTx:ClientEffect :: forall tx. Effect tx -> PostChainTx tx
postChainTx = FanoutTx{UTxOType SimpleTx
$sel:utxo:InitTx :: forall tx. PostChainTx tx -> UTxOType tx
utxo :: UTxOType SimpleTx
utxo}} -> Set SimpleTxOut
UTxOType SimpleTx
utxo Set SimpleTxOut -> Set SimpleTxOut -> Bool
forall a. Eq a => a -> a -> Bool
== Set SimpleTxOut
bigUTxO
          Effect SimpleTx
_ -> Bool
False

      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"client fanout resumes from remaining UTxOs when prior step posting failed due to insufficient funds" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        -- Build a snapshot large enough to require at least two partial fanout steps:
        -- first step distributes fanoutChunkSize, leaving fanoutOutputThreshold + 1 → FinalPartialFanoutTx.
        let totalCount :: Int
totalCount = Int
fanoutOutputThreshold Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
fanoutChunkSize Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
            allUTxO :: Set SimpleTxOut
allUTxO = [SimpleTxOut] -> Set SimpleTxOut
forall a. Ord a => [a] -> Set a
Set.fromList [SimpleId -> SimpleTxOut
SimpleTxOut SimpleId
i | SimpleId
i <- [SimpleId
1 .. Int -> SimpleId
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
totalCount]]
            snap :: Snapshot SimpleTx
snap = SnapshotNumber
-> SnapshotVersion
-> [SimpleTx]
-> UTxOType SimpleTx
-> Snapshot SimpleTx
forall tx.
IsTx tx =>
SnapshotNumber
-> SnapshotVersion -> [tx] -> UTxOType tx -> Snapshot tx
testSnapshot SnapshotNumber
1 SnapshotVersion
0 [] Set SimpleTxOut
UTxOType SimpleTx
allUTxO
            initialSt :: NodeState SimpleTx
initialSt = [Party] -> ConfirmedSnapshot SimpleTx -> NodeState SimpleTx
inClosedState' [Party]
threeParties (Snapshot SimpleTx
-> MultiSignature (Snapshot SimpleTx) -> ConfirmedSnapshot SimpleTx
forall tx.
Snapshot tx -> MultiSignature (Snapshot tx) -> ConfirmedSnapshot tx
ConfirmedSnapshot Snapshot SimpleTx
snap ([Signature (Snapshot SimpleTx)]
-> MultiSignature (Snapshot SimpleTx)
forall a. [Signature a] -> MultiSignature a
Crypto.aggregate []))
        -- Compute exactly what the first partial fanout step would have distributed.
        let ([SimpleTxOut]
distributed1List, [SimpleTxOut]
remaining1List) = Int -> [SimpleTxOut] -> ([SimpleTxOut], [SimpleTxOut])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
fanoutChunkSize (Set SimpleTxOut -> [SimpleTxOut]
forall a. Set a -> [a]
Set.toList Set SimpleTxOut
allUTxO)
            distributed1 :: Set SimpleTxOut
distributed1 = [SimpleTxOut] -> Set SimpleTxOut
forall a. Ord a => [a] -> Set a
Set.fromList [SimpleTxOut]
distributed1List
            remaining1 :: Set SimpleTxOut
remaining1 = [SimpleTxOut] -> Set SimpleTxOut
forall a. Ord a => [a] -> Set a
Set.fromList [SimpleTxOut]
remaining1List
        -- Step 1 was confirmed on-chain (HeadPartialFannedOut observed). The
        -- auto-emitted step 2 effect was never posted because the operator ran
        -- out of funds. The head is now in FanoutProgress with remaining1 left.
        let step1 :: StateChanged SimpleTx
step1 =
              HeadPartialFannedOut
                { $sel:headId:NetworkConnected :: HeadId
headId = HeadId
testHeadId
                , distributedOutputs :: UTxOType SimpleTx
distributedOutputs = Set SimpleTxOut
UTxOType SimpleTx
distributed1
                , $sel:remainingOutputs:NetworkConnected :: UTxOType SimpleTx
remainingOutputs = Set SimpleTxOut
UTxOType SimpleTx
remaining1
                , $sel:chainState:NetworkConnected :: ChainStateType SimpleTx
chainState = SimpleChainState{$sel:slot:SimpleChainState :: ChainSlot
slot = ChainSlot
0}
                , $sel:mode:NetworkConnected :: FanoutMode SimpleTx
mode = FanoutMode SimpleTx
forall tx. FanoutMode tx
AutoDrain
                }
            stAfterStep1 :: NodeState SimpleTx
stAfterStep1 = NodeState SimpleTx -> Outcome SimpleTx -> NodeState SimpleTx
forall tx.
IsChainState tx =>
NodeState tx -> Outcome tx -> NodeState tx
aggregateState NodeState SimpleTx
initialSt (StateChanged SimpleTx -> Outcome SimpleTx
forall tx. StateChanged tx -> Outcome tx
newState StateChanged SimpleTx
step1)
        case NodeState SimpleTx -> HeadState SimpleTx
forall tx. NodeState tx -> HeadState tx
headState NodeState SimpleTx
stAfterStep1 of
          FanoutProgress PartialFanoutState{UTxOType SimpleTx
$sel:remainingOutputs:PartialFanoutState :: forall tx. PartialFanoutState tx -> UTxOType tx
remainingOutputs :: UTxOType SimpleTx
remainingOutputs} ->
            Set SimpleTxOut
UTxOType SimpleTx
remainingOutputs Set SimpleTxOut -> Set SimpleTxOut -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Set SimpleTxOut
remaining1
          HeadState SimpleTx
other -> String -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Expected FanoutProgress state, got: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> HeadState SimpleTx -> String
forall b a. (Show a, IsString b) => a -> b
show HeadState SimpleTx
other
        -- Operator tops up funds and resumes by selecting the remaining UTxO.
        UTCTime
now <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
stAfterStep1.chainPointTime.currentSlot
        let outcome :: Outcome SimpleTx
outcome = Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
stAfterStep1 (ClientInput SimpleTx -> Input SimpleTx
forall tx. ClientInput tx -> Input tx
ClientInput (UTxOType SimpleTx -> ClientInput SimpleTx
forall tx. UTxOType tx -> ClientInput tx
PartialFanout Set SimpleTxOut
UTxOType SimpleTx
remaining1))
        -- Must continue from remaining1: the next chunk is disjoint from distributed1.
        -- If fanout restarted from scratch it would re-distribute distributed1,
        -- making Set.disjoint fail.
        Outcome SimpleTx
outcome Outcome SimpleTx -> (Effect SimpleTx -> Bool) -> IO ()
forall tx.
(HasCallStack, IsChainState tx) =>
Outcome tx -> (Effect tx -> Bool) -> IO ()
`hasEffectSatisfying` \case
          OnChainEffect{$sel:postChainTx:ClientEffect :: forall tx. Effect tx -> PostChainTx tx
postChainTx = FinalPartialFanoutTx{UTxOType SimpleTx
$sel:utxoToDistribute:InitTx :: forall tx. PostChainTx tx -> UTxOType tx
utxoToDistribute :: UTxOType SimpleTx
utxoToDistribute}} ->
            Set SimpleTxOut -> Set SimpleTxOut -> Bool
forall a. Ord a => Set a -> Set a -> Bool
Set.isSubsetOf Set SimpleTxOut
UTxOType SimpleTx
utxoToDistribute Set SimpleTxOut
remaining1
              Bool -> Bool -> Bool
&& Set SimpleTxOut -> Set SimpleTxOut -> Bool
forall a. Ord a => Set a -> Set a -> Bool
Set.disjoint Set SimpleTxOut
UTxOType SimpleTx
utxoToDistribute Set SimpleTxOut
distributed1
          Effect SimpleTx
_ -> Bool
False

      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"StalePartialFanoutTx PostTxError is silently ignored (no PostTxOnChainFailed to client)" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        -- This covers the race condition where another node already posted the
        -- same partial fanout step. The chain observation loop self-heals by
        -- emitting the correct next effect; the stale attempt must not surface
        -- as an error to the API client.
        let st :: NodeState SimpleTx
st = [Party] -> NodeState SimpleTx
inClosedState [Party]
threeParties
        UTCTime
now <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
st.chainPointTime.currentSlot
        let postTxError :: Input SimpleTx
postTxError = ChainEvent SimpleTx -> Input SimpleTx
forall tx. ChainEvent tx -> Input tx
ChainInput PostTxError{$sel:postChainTx:Observation :: PostChainTx SimpleTx
postChainTx = FinalPartialFanoutTx{$sel:utxoToDistribute:InitTx :: UTxOType SimpleTx
utxoToDistribute = UTxOType SimpleTx
forall a. Monoid a => a
mempty, $sel:presettledUTxO:InitTx :: UTxOType SimpleTx
presettledUTxO = UTxOType SimpleTx
forall a. Monoid a => a
mempty, $sel:headSeed:InitTx :: HeadSeed
headSeed = HeadSeed
testHeadSeed, $sel:contestationDeadline:InitTx :: UTCTime
contestationDeadline = Gen UTCTime
forall a. Arbitrary a => Gen a
arbitrary Gen UTCTime -> Int -> UTCTime
forall a. Gen a -> Int -> a
`generateWith` Int
42}, $sel:postTxError:Observation :: PostTxError SimpleTx
postTxError = PostTxError SimpleTx
forall tx. PostTxError tx
StalePartialFanoutTx, $sel:failingTx:Observation :: Maybe SimpleTx
failingTx = Maybe SimpleTx
forall a. Maybe a
Nothing}
            outcome :: Outcome SimpleTx
outcome = Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
st Input SimpleTx
postTxError
        Outcome SimpleTx
outcome Outcome SimpleTx -> (Effect SimpleTx -> Bool) -> IO ()
forall tx.
(HasCallStack, IsChainState tx) =>
Outcome tx -> (Effect tx -> Bool) -> IO ()
`hasNoEffectSatisfying` \case
          ClientEffect{} -> Bool
True
          Effect SimpleTx
_ -> Bool
False

      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"aggregate HeadPartialFannedOut transitions to FanoutProgress with remaining UTxO" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        let remaining :: Set SimpleTxOut
remaining = [SimpleTxOut] -> Set SimpleTxOut
forall a. Ord a => [a] -> Set a
Set.fromList [SimpleId -> SimpleTxOut
SimpleTxOut SimpleId
5, SimpleId -> SimpleTxOut
SimpleTxOut SimpleId
6]
            distributed :: Set SimpleTxOut
distributed = [SimpleTxOut] -> Set SimpleTxOut
forall a. Ord a => [a] -> Set a
Set.fromList [SimpleId -> SimpleTxOut
SimpleTxOut SimpleId
1, SimpleId -> SimpleTxOut
SimpleTxOut SimpleId
2]
            closedSt :: NodeState SimpleTx
closedSt = [Party] -> NodeState SimpleTx
inClosedState [Party]
threeParties
        case NodeState SimpleTx -> HeadState SimpleTx
forall tx. NodeState tx -> HeadState tx
headState NodeState SimpleTx
closedSt of
          Closed{} ->
            let stateChange :: StateChanged SimpleTx
stateChange =
                  HeadPartialFannedOut
                    { $sel:headId:NetworkConnected :: HeadId
headId = HeadId
testHeadId
                    , distributedOutputs :: UTxOType SimpleTx
distributedOutputs = Set SimpleTxOut
UTxOType SimpleTx
distributed
                    , $sel:remainingOutputs:NetworkConnected :: UTxOType SimpleTx
remainingOutputs = Set SimpleTxOut
UTxOType SimpleTx
remaining
                    , $sel:chainState:NetworkConnected :: ChainStateType SimpleTx
chainState = SimpleChainState{$sel:slot:SimpleChainState :: ChainSlot
slot = ChainSlot
0}
                    , $sel:mode:NetworkConnected :: FanoutMode SimpleTx
mode = FanoutMode SimpleTx
forall tx. FanoutMode tx
AutoDrain
                    }
                result :: NodeState SimpleTx
result = NodeState SimpleTx -> Outcome SimpleTx -> NodeState SimpleTx
forall tx.
IsChainState tx =>
NodeState tx -> Outcome tx -> NodeState tx
aggregateState NodeState SimpleTx
closedSt (StateChanged SimpleTx -> Outcome SimpleTx
forall tx. StateChanged tx -> Outcome tx
newState StateChanged SimpleTx
stateChange)
             in case NodeState SimpleTx -> HeadState SimpleTx
forall tx. NodeState tx -> HeadState tx
headState NodeState SimpleTx
result of
                  FanoutProgress PartialFanoutState{UTxOType SimpleTx
$sel:remainingOutputs:PartialFanoutState :: forall tx. PartialFanoutState tx -> UTxOType tx
remainingOutputs :: UTxOType SimpleTx
remainingOutputs, UTxOType SimpleTx
$sel:distributedOutputs:PartialFanoutState :: forall tx. PartialFanoutState tx -> UTxOType tx
distributedOutputs :: UTxOType SimpleTx
distributedOutputs} -> do
                    Set SimpleTxOut
UTxOType SimpleTx
remainingOutputs Set SimpleTxOut -> Set SimpleTxOut -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Set SimpleTxOut
remaining
                    Set SimpleTxOut
UTxOType SimpleTx
distributedOutputs Set SimpleTxOut -> Set SimpleTxOut -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Set SimpleTxOut
distributed
                  HeadState SimpleTx
other -> String -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Expected FanoutProgress state, got: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> HeadState SimpleTx -> String
forall b a. (Show a, IsString b) => a -> b
show HeadState SimpleTx
other
          HeadState SimpleTx
other -> String -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Expected Closed state, got: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> HeadState SimpleTx -> String
forall b a. (Show a, IsString b) => a -> b
show HeadState SimpleTx
other

      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"aggregate HeadPartialFannedOut accumulates distributedOutputs across steps" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        let firstDistributed :: Set SimpleTxOut
firstDistributed = [SimpleTxOut] -> Set SimpleTxOut
forall a. Ord a => [a] -> Set a
Set.fromList [SimpleId -> SimpleTxOut
SimpleTxOut SimpleId
1, SimpleId -> SimpleTxOut
SimpleTxOut SimpleId
2]
            secondDistributed :: Set SimpleTxOut
secondDistributed = [SimpleTxOut] -> Set SimpleTxOut
forall a. Ord a => [a] -> Set a
Set.fromList [SimpleId -> SimpleTxOut
SimpleTxOut SimpleId
3, SimpleId -> SimpleTxOut
SimpleTxOut SimpleId
4]
            remaining :: Set SimpleTxOut
remaining = [SimpleTxOut] -> Set SimpleTxOut
forall a. Ord a => [a] -> Set a
Set.fromList [SimpleId -> SimpleTxOut
SimpleTxOut SimpleId
5, SimpleId -> SimpleTxOut
SimpleTxOut SimpleId
6]
            closedSt :: NodeState SimpleTx
closedSt = [Party] -> NodeState SimpleTx
inClosedState [Party]
threeParties
        case NodeState SimpleTx -> HeadState SimpleTx
forall tx. NodeState tx -> HeadState tx
headState NodeState SimpleTx
closedSt of
          Closed{} ->
            let step1 :: StateChanged SimpleTx
step1 =
                  HeadPartialFannedOut
                    { $sel:headId:NetworkConnected :: HeadId
headId = HeadId
testHeadId
                    , distributedOutputs :: UTxOType SimpleTx
distributedOutputs = Set SimpleTxOut
UTxOType SimpleTx
firstDistributed
                    , $sel:remainingOutputs:NetworkConnected :: UTxOType SimpleTx
remainingOutputs = Set SimpleTxOut
secondDistributed Set SimpleTxOut -> Set SimpleTxOut -> Set SimpleTxOut
forall a. Semigroup a => a -> a -> a
<> Set SimpleTxOut
remaining
                    , $sel:chainState:NetworkConnected :: ChainStateType SimpleTx
chainState = SimpleChainState{$sel:slot:SimpleChainState :: ChainSlot
slot = ChainSlot
0}
                    , $sel:mode:NetworkConnected :: FanoutMode SimpleTx
mode = FanoutMode SimpleTx
forall tx. FanoutMode tx
AutoDrain
                    }
                afterStep1 :: NodeState SimpleTx
afterStep1 = NodeState SimpleTx -> Outcome SimpleTx -> NodeState SimpleTx
forall tx.
IsChainState tx =>
NodeState tx -> Outcome tx -> NodeState tx
aggregateState NodeState SimpleTx
closedSt (StateChanged SimpleTx -> Outcome SimpleTx
forall tx. StateChanged tx -> Outcome tx
newState StateChanged SimpleTx
step1)
                step2 :: StateChanged SimpleTx
step2 =
                  HeadPartialFannedOut
                    { $sel:headId:NetworkConnected :: HeadId
headId = HeadId
testHeadId
                    , distributedOutputs :: UTxOType SimpleTx
distributedOutputs = Set SimpleTxOut
UTxOType SimpleTx
secondDistributed
                    , $sel:remainingOutputs:NetworkConnected :: UTxOType SimpleTx
remainingOutputs = Set SimpleTxOut
UTxOType SimpleTx
remaining
                    , $sel:chainState:NetworkConnected :: ChainStateType SimpleTx
chainState = SimpleChainState{$sel:slot:SimpleChainState :: ChainSlot
slot = ChainSlot
0}
                    , $sel:mode:NetworkConnected :: FanoutMode SimpleTx
mode = FanoutMode SimpleTx
forall tx. FanoutMode tx
AutoDrain
                    }
                afterStep2 :: NodeState SimpleTx
afterStep2 = NodeState SimpleTx -> Outcome SimpleTx -> NodeState SimpleTx
forall tx.
IsChainState tx =>
NodeState tx -> Outcome tx -> NodeState tx
aggregateState NodeState SimpleTx
afterStep1 (StateChanged SimpleTx -> Outcome SimpleTx
forall tx. StateChanged tx -> Outcome tx
newState StateChanged SimpleTx
step2)
             in case NodeState SimpleTx -> HeadState SimpleTx
forall tx. NodeState tx -> HeadState tx
headState NodeState SimpleTx
afterStep2 of
                  FanoutProgress PartialFanoutState{UTxOType SimpleTx
$sel:distributedOutputs:PartialFanoutState :: forall tx. PartialFanoutState tx -> UTxOType tx
distributedOutputs :: UTxOType SimpleTx
distributedOutputs} ->
                    Set SimpleTxOut
UTxOType SimpleTx
distributedOutputs Set SimpleTxOut -> Set SimpleTxOut -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Set SimpleTxOut
firstDistributed Set SimpleTxOut -> Set SimpleTxOut -> Set SimpleTxOut
forall a. Semigroup a => a -> a -> a
<> Set SimpleTxOut
secondDistributed
                  HeadState SimpleTx
other -> String -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Expected FanoutProgress state, got: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> HeadState SimpleTx -> String
forall b a. (Show a, IsString b) => a -> b
show HeadState SimpleTx
other
          HeadState SimpleTx
other -> String -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Expected Closed state, got: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> HeadState SimpleTx -> String
forall b a. (Show a, IsString b) => a -> b
show HeadState SimpleTx
other

      String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"SideLoad InitialSnapshot" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
        String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"accept side load initial snapshot with idempotence" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
          let s0 :: NodeState SimpleTx
s0 = [Party] -> NodeState SimpleTx
inOpenState [Party]
threeParties
              initialSn :: ConfirmedSnapshot SimpleTx
initialSn = forall tx. HeadId -> ConfirmedSnapshot tx
InitialSnapshot @SimpleTx HeadId
testHeadId
              snapshot0 :: Snapshot SimpleTx
snapshot0 = ConfirmedSnapshot SimpleTx -> Snapshot SimpleTx
forall tx. IsTx tx => ConfirmedSnapshot tx -> Snapshot tx
getSnapshot ConfirmedSnapshot SimpleTx
initialSn
          NodeState SimpleTx -> Maybe (Snapshot SimpleTx)
forall tx. IsTx tx => NodeState tx -> Maybe (Snapshot tx)
getConfirmedSnapshot NodeState SimpleTx
s0 Maybe (Snapshot SimpleTx) -> Maybe (Snapshot SimpleTx) -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Snapshot SimpleTx -> Maybe (Snapshot SimpleTx)
forall a. a -> Maybe a
Just Snapshot SimpleTx
snapshot0
          NodeState SimpleTx
sideLoadedState <- Environment
-> Ledger SimpleTx
-> NodeState SimpleTx
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall (m :: * -> *) tx a.
Monad m =>
Environment
-> Ledger tx -> NodeState tx -> StateT (StepState tx) m a -> m a
runHeadLogic Environment
bobEnv Ledger SimpleTx
ledger NodeState SimpleTx
s0 (StateT (StepState SimpleTx) IO (NodeState SimpleTx)
 -> IO (NodeState SimpleTx))
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall a b. (a -> b) -> a -> b
$ do
            Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step (Input SimpleTx
 -> StateT (StepState SimpleTx) IO (Outcome SimpleTx))
-> Input SimpleTx
-> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall a b. (a -> b) -> a -> b
$ ClientInput SimpleTx -> Input SimpleTx
forall tx. ClientInput tx -> Input tx
ClientInput (ConfirmedSnapshot SimpleTx -> ClientInput SimpleTx
forall tx. ConfirmedSnapshot tx -> ClientInput tx
SideLoadSnapshot ConfirmedSnapshot SimpleTx
initialSn)
            StateT (StepState SimpleTx) IO (NodeState SimpleTx)
forall tx (m :: * -> *).
MonadState (StepState tx) m =>
m (NodeState tx)
getState
          NodeState SimpleTx -> Maybe (Snapshot SimpleTx)
forall tx. IsTx tx => NodeState tx -> Maybe (Snapshot tx)
getConfirmedSnapshot NodeState SimpleTx
sideLoadedState Maybe (Snapshot SimpleTx) -> Maybe (Snapshot SimpleTx) -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Snapshot SimpleTx -> Maybe (Snapshot SimpleTx)
forall a. a -> Maybe a
Just Snapshot SimpleTx
snapshot0

        String -> (HeadId -> IO ()) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"ignores side load initial snapshot of another head" ((HeadId -> IO ()) -> Spec) -> (HeadId -> IO ()) -> Spec
forall a b. (a -> b) -> a -> b
$ \HeadId
otherHeadId -> do
          let s0 :: NodeState SimpleTx
s0 = [Party] -> NodeState SimpleTx
inOpenState [Party]
threeParties
              initialSn :: ConfirmedSnapshot SimpleTx
initialSn = forall tx. HeadId -> ConfirmedSnapshot tx
InitialSnapshot @SimpleTx HeadId
testHeadId
              snapshot0 :: Snapshot SimpleTx
snapshot0 = ConfirmedSnapshot SimpleTx -> Snapshot SimpleTx
forall tx. IsTx tx => ConfirmedSnapshot tx -> Snapshot tx
getSnapshot ConfirmedSnapshot SimpleTx
initialSn
          NodeState SimpleTx -> Maybe (Snapshot SimpleTx)
forall tx. IsTx tx => NodeState tx -> Maybe (Snapshot tx)
getConfirmedSnapshot NodeState SimpleTx
s0 Maybe (Snapshot SimpleTx) -> Maybe (Snapshot SimpleTx) -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Snapshot SimpleTx -> Maybe (Snapshot SimpleTx)
forall a. a -> Maybe a
Just Snapshot SimpleTx
snapshot0
          let initialSnapshotOtherHead :: ConfirmedSnapshot SimpleTx
initialSnapshotOtherHead = HeadId -> ConfirmedSnapshot SimpleTx
forall tx. HeadId -> ConfirmedSnapshot tx
InitialSnapshot HeadId
otherHeadId
          UTCTime
now <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
s0.chainPointTime.currentSlot
          Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
s0 (ClientInput SimpleTx -> Input SimpleTx
forall tx. ClientInput tx -> Input tx
ClientInput (ConfirmedSnapshot SimpleTx -> ClientInput SimpleTx
forall tx. ConfirmedSnapshot tx -> ClientInput tx
SideLoadSnapshot ConfirmedSnapshot SimpleTx
initialSnapshotOtherHead))
            Outcome SimpleTx -> Outcome SimpleTx -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` LogicError SimpleTx -> Outcome SimpleTx
forall tx. LogicError tx -> Outcome tx
Error (NotOurHead{$sel:ourHeadId:UnhandledInput :: HeadId
ourHeadId = HeadId
testHeadId, HeadId
$sel:otherHeadId:UnhandledInput :: HeadId
otherHeadId :: HeadId
otherHeadId})
          NodeState SimpleTx -> Maybe (Snapshot SimpleTx)
forall tx. IsTx tx => NodeState tx -> Maybe (Snapshot tx)
getConfirmedSnapshot NodeState SimpleTx
s0 Maybe (Snapshot SimpleTx) -> Maybe (Snapshot SimpleTx) -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Snapshot SimpleTx -> Maybe (Snapshot SimpleTx)
forall a. a -> Maybe a
Just Snapshot SimpleTx
snapshot0

      String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"SideLoad ConfirmedSnapshot" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
        -- Given a list of transactions each depending on the previous.
        let tx1 :: SimpleTx
tx1 = SimpleId -> UTxOType SimpleTx -> UTxOType SimpleTx -> SimpleTx
SimpleTx SimpleId
1 Set SimpleTxOut
UTxOType SimpleTx
forall a. Monoid a => a
mempty (SimpleId -> UTxOType SimpleTx
utxoRef SimpleId
2) -- No inputs, requires no specific starting state
            tx2 :: SimpleTx
tx2 = SimpleId -> UTxOType SimpleTx -> UTxOType SimpleTx -> SimpleTx
SimpleTx SimpleId
2 (SimpleId -> UTxOType SimpleTx
utxoRef SimpleId
2) (SimpleId -> UTxOType SimpleTx
utxoRef SimpleId
3)
            tx3 :: SimpleTx
tx3 = SimpleId -> UTxOType SimpleTx -> UTxOType SimpleTx -> SimpleTx
SimpleTx SimpleId
3 (SimpleId -> UTxOType SimpleTx
utxoRef SimpleId
3) (SimpleId -> UTxOType SimpleTx
utxoRef SimpleId
4)
            snapshot1 :: Snapshot SimpleTx
snapshot1 = SnapshotNumber
-> SnapshotVersion
-> [SimpleTx]
-> UTxOType SimpleTx
-> Snapshot SimpleTx
forall tx.
IsTx tx =>
SnapshotNumber
-> SnapshotVersion -> [tx] -> UTxOType tx -> Snapshot tx
testSnapshot SnapshotNumber
1 SnapshotVersion
0 [SimpleTx
tx1] (SimpleId -> UTxOType SimpleTx
utxoRef SimpleId
2)
            multisig1 :: MultiSignature (Snapshot SimpleTx)
multisig1 = [Signature (Snapshot SimpleTx)]
-> MultiSignature (Snapshot SimpleTx)
forall a. [Signature a] -> MultiSignature a
aggregate [Secret (SigningKey HydraKey)
-> Snapshot SimpleTx -> Signature (Snapshot SimpleTx)
forall a.
SignableRepresentation a =>
Secret (SigningKey HydraKey) -> a -> Signature a
sign Secret (SigningKey HydraKey)
aliceSk Snapshot SimpleTx
snapshot1, Secret (SigningKey HydraKey)
-> Snapshot SimpleTx -> Signature (Snapshot SimpleTx)
forall a.
SignableRepresentation a =>
Secret (SigningKey HydraKey) -> a -> Signature a
sign Secret (SigningKey HydraKey)
bobSk Snapshot SimpleTx
snapshot1, Secret (SigningKey HydraKey)
-> Snapshot SimpleTx -> Signature (Snapshot SimpleTx)
forall a.
SignableRepresentation a =>
Secret (SigningKey HydraKey) -> a -> Signature a
sign Secret (SigningKey HydraKey)
carolSk Snapshot SimpleTx
snapshot1]
        -- Given a starting state with:
        -- \* All txs were submitted and locally applied.
        -- \* Snapshot 1 containing tx1 got confirmed.
        -- \* tx2 and tx2 are pending confirmation.
        -- \* Snapshot 2 is inflight.
        let startingState :: NodeState SimpleTx
startingState =
              [Party] -> CoordinatedHeadState SimpleTx -> NodeState SimpleTx
inOpenState'
                [Party]
threeParties
                CoordinatedHeadState SimpleTx
coordinatedHeadState
                  { localUTxO = utxoRef 4
                  , allTxs = Map.fromList [(txId tx2, tx2), (txId tx3, tx3)]
                  , localTxs = Seq.fromList [tx2, tx3]
                  , confirmedSnapshot = ConfirmedSnapshot snapshot1 multisig1
                  , seenSnapshot = RequestedSnapshot{lastSeen = 1, requested = 2}
                  }

        String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"accept new side load confirmed snapshot" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
          NodeState SimpleTx -> Maybe (Snapshot SimpleTx)
forall tx. IsTx tx => NodeState tx -> Maybe (Snapshot tx)
getConfirmedSnapshot NodeState SimpleTx
startingState Maybe (Snapshot SimpleTx) -> Maybe (Snapshot SimpleTx) -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Snapshot SimpleTx -> Maybe (Snapshot SimpleTx)
forall a. a -> Maybe a
Just Snapshot SimpleTx
snapshot1

          let snapshot2 :: Snapshot SimpleTx
snapshot2 = SnapshotNumber
-> SnapshotVersion
-> [SimpleTx]
-> UTxOType SimpleTx
-> Snapshot SimpleTx
forall tx.
IsTx tx =>
SnapshotNumber
-> SnapshotVersion -> [tx] -> UTxOType tx -> Snapshot tx
testSnapshot SnapshotNumber
2 SnapshotVersion
0 [SimpleTx
tx2] (SimpleId -> UTxOType SimpleTx
utxoRef SimpleId
3)
              multisig2 :: MultiSignature (Snapshot SimpleTx)
multisig2 = [Signature (Snapshot SimpleTx)]
-> MultiSignature (Snapshot SimpleTx)
forall a. [Signature a] -> MultiSignature a
aggregate [Secret (SigningKey HydraKey)
-> Snapshot SimpleTx -> Signature (Snapshot SimpleTx)
forall a.
SignableRepresentation a =>
Secret (SigningKey HydraKey) -> a -> Signature a
sign Secret (SigningKey HydraKey)
aliceSk Snapshot SimpleTx
snapshot2, Secret (SigningKey HydraKey)
-> Snapshot SimpleTx -> Signature (Snapshot SimpleTx)
forall a.
SignableRepresentation a =>
Secret (SigningKey HydraKey) -> a -> Signature a
sign Secret (SigningKey HydraKey)
bobSk Snapshot SimpleTx
snapshot2, Secret (SigningKey HydraKey)
-> Snapshot SimpleTx -> Signature (Snapshot SimpleTx)
forall a.
SignableRepresentation a =>
Secret (SigningKey HydraKey) -> a -> Signature a
sign Secret (SigningKey HydraKey)
carolSk Snapshot SimpleTx
snapshot2]

          NodeState SimpleTx
sideLoadedState <- Environment
-> Ledger SimpleTx
-> NodeState SimpleTx
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall (m :: * -> *) tx a.
Monad m =>
Environment
-> Ledger tx -> NodeState tx -> StateT (StepState tx) m a -> m a
runHeadLogic Environment
bobEnv Ledger SimpleTx
ledger NodeState SimpleTx
startingState (StateT (StepState SimpleTx) IO (NodeState SimpleTx)
 -> IO (NodeState SimpleTx))
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall a b. (a -> b) -> a -> b
$ do
            Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step (Input SimpleTx
 -> StateT (StepState SimpleTx) IO (Outcome SimpleTx))
-> Input SimpleTx
-> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall a b. (a -> b) -> a -> b
$ ClientInput SimpleTx -> Input SimpleTx
forall tx. ClientInput tx -> Input tx
ClientInput (ConfirmedSnapshot SimpleTx -> ClientInput SimpleTx
forall tx. ConfirmedSnapshot tx -> ClientInput tx
SideLoadSnapshot (ConfirmedSnapshot SimpleTx -> ClientInput SimpleTx)
-> ConfirmedSnapshot SimpleTx -> ClientInput SimpleTx
forall a b. (a -> b) -> a -> b
$ Snapshot SimpleTx
-> MultiSignature (Snapshot SimpleTx) -> ConfirmedSnapshot SimpleTx
forall tx.
Snapshot tx -> MultiSignature (Snapshot tx) -> ConfirmedSnapshot tx
ConfirmedSnapshot Snapshot SimpleTx
snapshot2 MultiSignature (Snapshot SimpleTx)
multisig2)
            StateT (StepState SimpleTx) IO (NodeState SimpleTx)
forall tx (m :: * -> *).
MonadState (StepState tx) m =>
m (NodeState tx)
getState

          NodeState SimpleTx -> Maybe (Snapshot SimpleTx)
forall tx. IsTx tx => NodeState tx -> Maybe (Snapshot tx)
getConfirmedSnapshot NodeState SimpleTx
sideLoadedState Maybe (Snapshot SimpleTx) -> Maybe (Snapshot SimpleTx) -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Snapshot SimpleTx -> Maybe (Snapshot SimpleTx)
forall a. a -> Maybe a
Just Snapshot SimpleTx
snapshot2

        String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"reject side load confirmed snapshot because old snapshot number" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
          NodeState SimpleTx -> Maybe (Snapshot SimpleTx)
forall tx. IsTx tx => NodeState tx -> Maybe (Snapshot tx)
getConfirmedSnapshot NodeState SimpleTx
startingState Maybe (Snapshot SimpleTx) -> Maybe (Snapshot SimpleTx) -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Snapshot SimpleTx -> Maybe (Snapshot SimpleTx)
forall a. a -> Maybe a
Just Snapshot SimpleTx
snapshot1

          let snapshot2 :: Snapshot SimpleTx
snapshot2 = SnapshotNumber
-> SnapshotVersion
-> [SimpleTx]
-> UTxOType SimpleTx
-> Snapshot SimpleTx
forall tx.
IsTx tx =>
SnapshotNumber
-> SnapshotVersion -> [tx] -> UTxOType tx -> Snapshot tx
testSnapshot SnapshotNumber
2 SnapshotVersion
0 [SimpleTx
tx2] (SimpleId -> UTxOType SimpleTx
utxoRef SimpleId
3)
              multisig2 :: MultiSignature (Snapshot SimpleTx)
multisig2 = [Signature (Snapshot SimpleTx)]
-> MultiSignature (Snapshot SimpleTx)
forall a. [Signature a] -> MultiSignature a
aggregate [Secret (SigningKey HydraKey)
-> Snapshot SimpleTx -> Signature (Snapshot SimpleTx)
forall a.
SignableRepresentation a =>
Secret (SigningKey HydraKey) -> a -> Signature a
sign Secret (SigningKey HydraKey)
aliceSk Snapshot SimpleTx
snapshot2, Secret (SigningKey HydraKey)
-> Snapshot SimpleTx -> Signature (Snapshot SimpleTx)
forall a.
SignableRepresentation a =>
Secret (SigningKey HydraKey) -> a -> Signature a
sign Secret (SigningKey HydraKey)
bobSk Snapshot SimpleTx
snapshot2, Secret (SigningKey HydraKey)
-> Snapshot SimpleTx -> Signature (Snapshot SimpleTx)
forall a.
SignableRepresentation a =>
Secret (SigningKey HydraKey) -> a -> Signature a
sign Secret (SigningKey HydraKey)
carolSk Snapshot SimpleTx
snapshot2]

          NodeState SimpleTx
sideLoadedState <- Environment
-> Ledger SimpleTx
-> NodeState SimpleTx
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall (m :: * -> *) tx a.
Monad m =>
Environment
-> Ledger tx -> NodeState tx -> StateT (StepState tx) m a -> m a
runHeadLogic Environment
bobEnv Ledger SimpleTx
ledger NodeState SimpleTx
startingState (StateT (StepState SimpleTx) IO (NodeState SimpleTx)
 -> IO (NodeState SimpleTx))
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall a b. (a -> b) -> a -> b
$ do
            Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step (Input SimpleTx
 -> StateT (StepState SimpleTx) IO (Outcome SimpleTx))
-> Input SimpleTx
-> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall a b. (a -> b) -> a -> b
$ ClientInput SimpleTx -> Input SimpleTx
forall tx. ClientInput tx -> Input tx
ClientInput (ConfirmedSnapshot SimpleTx -> ClientInput SimpleTx
forall tx. ConfirmedSnapshot tx -> ClientInput tx
SideLoadSnapshot (ConfirmedSnapshot SimpleTx -> ClientInput SimpleTx)
-> ConfirmedSnapshot SimpleTx -> ClientInput SimpleTx
forall a b. (a -> b) -> a -> b
$ Snapshot SimpleTx
-> MultiSignature (Snapshot SimpleTx) -> ConfirmedSnapshot SimpleTx
forall tx.
Snapshot tx -> MultiSignature (Snapshot tx) -> ConfirmedSnapshot tx
ConfirmedSnapshot Snapshot SimpleTx
snapshot2 MultiSignature (Snapshot SimpleTx)
multisig2)
            StateT (StepState SimpleTx) IO (NodeState SimpleTx)
forall tx (m :: * -> *).
MonadState (StepState tx) m =>
m (NodeState tx)
getState

          NodeState SimpleTx -> Maybe (Snapshot SimpleTx)
forall tx. IsTx tx => NodeState tx -> Maybe (Snapshot tx)
getConfirmedSnapshot NodeState SimpleTx
sideLoadedState Maybe (Snapshot SimpleTx) -> Maybe (Snapshot SimpleTx) -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Snapshot SimpleTx -> Maybe (Snapshot SimpleTx)
forall a. a -> Maybe a
Just Snapshot SimpleTx
snapshot2

          UTCTime
now <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
sideLoadedState.chainPointTime.currentSlot
          let outcome :: Outcome SimpleTx
outcome = Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
sideLoadedState (ClientInput SimpleTx -> Input SimpleTx
forall tx. ClientInput tx -> Input tx
ClientInput (ConfirmedSnapshot SimpleTx -> ClientInput SimpleTx
forall tx. ConfirmedSnapshot tx -> ClientInput tx
SideLoadSnapshot (ConfirmedSnapshot SimpleTx -> ClientInput SimpleTx)
-> ConfirmedSnapshot SimpleTx -> ClientInput SimpleTx
forall a b. (a -> b) -> a -> b
$ Snapshot SimpleTx
-> MultiSignature (Snapshot SimpleTx) -> ConfirmedSnapshot SimpleTx
forall tx.
Snapshot tx -> MultiSignature (Snapshot tx) -> ConfirmedSnapshot tx
ConfirmedSnapshot Snapshot SimpleTx
snapshot1 MultiSignature (Snapshot SimpleTx)
multisig1))
          Outcome SimpleTx
outcome Outcome SimpleTx -> (Effect SimpleTx -> Bool) -> IO ()
forall tx.
(HasCallStack, IsChainState tx) =>
Outcome tx -> (Effect tx -> Bool) -> IO ()
`hasEffectSatisfying` \case
            ClientEffect (SideLoadSnapshotRejected{$sel:requirementFailure:CommandFailed :: forall tx. ClientMessage tx -> SideLoadRequirementFailure tx
requirementFailure = SideLoadSnNumberInvalid SnapshotNumber
1 SnapshotNumber
2}) -> Bool
True
            Effect SimpleTx
_ -> Bool
False

        String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"reject side load confirmed snapshot because missing signature" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
          NodeState SimpleTx -> Maybe (Snapshot SimpleTx)
forall tx. IsTx tx => NodeState tx -> Maybe (Snapshot tx)
getConfirmedSnapshot NodeState SimpleTx
startingState Maybe (Snapshot SimpleTx) -> Maybe (Snapshot SimpleTx) -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Snapshot SimpleTx -> Maybe (Snapshot SimpleTx)
forall a. a -> Maybe a
Just Snapshot SimpleTx
snapshot1

          let snapshot2 :: Snapshot SimpleTx
snapshot2 = SnapshotNumber
-> SnapshotVersion
-> [SimpleTx]
-> UTxOType SimpleTx
-> Snapshot SimpleTx
forall tx.
IsTx tx =>
SnapshotNumber
-> SnapshotVersion -> [tx] -> UTxOType tx -> Snapshot tx
testSnapshot SnapshotNumber
2 SnapshotVersion
0 [SimpleTx
tx2] (SimpleId -> UTxOType SimpleTx
utxoRef SimpleId
3)
              multisig2 :: MultiSignature (Snapshot SimpleTx)
multisig2 = [Signature (Snapshot SimpleTx)]
-> MultiSignature (Snapshot SimpleTx)
forall a. [Signature a] -> MultiSignature a
aggregate [Secret (SigningKey HydraKey)
-> Snapshot SimpleTx -> Signature (Snapshot SimpleTx)
forall a.
SignableRepresentation a =>
Secret (SigningKey HydraKey) -> a -> Signature a
sign Secret (SigningKey HydraKey)
aliceSk Snapshot SimpleTx
snapshot2, Secret (SigningKey HydraKey)
-> Snapshot SimpleTx -> Signature (Snapshot SimpleTx)
forall a.
SignableRepresentation a =>
Secret (SigningKey HydraKey) -> a -> Signature a
sign Secret (SigningKey HydraKey)
bobSk Snapshot SimpleTx
snapshot2]

          UTCTime
now <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
startingState.chainPointTime.currentSlot
          let outcome :: Outcome SimpleTx
outcome = Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
startingState (ClientInput SimpleTx -> Input SimpleTx
forall tx. ClientInput tx -> Input tx
ClientInput (ConfirmedSnapshot SimpleTx -> ClientInput SimpleTx
forall tx. ConfirmedSnapshot tx -> ClientInput tx
SideLoadSnapshot (ConfirmedSnapshot SimpleTx -> ClientInput SimpleTx)
-> ConfirmedSnapshot SimpleTx -> ClientInput SimpleTx
forall a b. (a -> b) -> a -> b
$ Snapshot SimpleTx
-> MultiSignature (Snapshot SimpleTx) -> ConfirmedSnapshot SimpleTx
forall tx.
Snapshot tx -> MultiSignature (Snapshot tx) -> ConfirmedSnapshot tx
ConfirmedSnapshot Snapshot SimpleTx
snapshot2 MultiSignature (Snapshot SimpleTx)
multisig2))
          Outcome SimpleTx
outcome Outcome SimpleTx -> (Effect SimpleTx -> Bool) -> IO ()
forall tx.
(HasCallStack, IsChainState tx) =>
Outcome tx -> (Effect tx -> Bool) -> IO ()
`hasEffectSatisfying` \case
            ClientEffect (SideLoadSnapshotRejected{$sel:requirementFailure:CommandFailed :: forall tx. ClientMessage tx -> SideLoadRequirementFailure tx
requirementFailure = SideLoadInvalidMultisignature{[VerificationKey HydraKey]
vkeys :: [VerificationKey HydraKey]
$sel:vkeys:SideLoadInitialSnapshotMismatch :: forall tx.
SideLoadRequirementFailure tx -> [VerificationKey HydraKey]
vkeys}}) ->
              [VerificationKey HydraKey]
vkeys [VerificationKey HydraKey] -> [VerificationKey HydraKey] -> Bool
forall a. Eq a => a -> a -> Bool
== [Party -> VerificationKey HydraKey
vkey Party
alice, Party -> VerificationKey HydraKey
vkey Party
bob, Party -> VerificationKey HydraKey
vkey Party
carol]
            Effect SimpleTx
_ -> Bool
False

        String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"reject side load confirmed snapshot because wrong snapshot version" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
          NodeState SimpleTx -> Maybe (Snapshot SimpleTx)
forall tx. IsTx tx => NodeState tx -> Maybe (Snapshot tx)
getConfirmedSnapshot NodeState SimpleTx
startingState Maybe (Snapshot SimpleTx) -> Maybe (Snapshot SimpleTx) -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Snapshot SimpleTx -> Maybe (Snapshot SimpleTx)
forall a. a -> Maybe a
Just Snapshot SimpleTx
snapshot1

          let snapshot2 :: Snapshot SimpleTx
snapshot2 = SnapshotNumber
-> SnapshotVersion
-> [SimpleTx]
-> UTxOType SimpleTx
-> Snapshot SimpleTx
forall tx.
IsTx tx =>
SnapshotNumber
-> SnapshotVersion -> [tx] -> UTxOType tx -> Snapshot tx
testSnapshot SnapshotNumber
2 SnapshotVersion
1 [SimpleTx
tx2] (SimpleId -> UTxOType SimpleTx
utxoRef SimpleId
3)
              multisig2 :: MultiSignature (Snapshot SimpleTx)
multisig2 = [Signature (Snapshot SimpleTx)]
-> MultiSignature (Snapshot SimpleTx)
forall a. [Signature a] -> MultiSignature a
aggregate [Secret (SigningKey HydraKey)
-> Snapshot SimpleTx -> Signature (Snapshot SimpleTx)
forall a.
SignableRepresentation a =>
Secret (SigningKey HydraKey) -> a -> Signature a
sign Secret (SigningKey HydraKey)
aliceSk Snapshot SimpleTx
snapshot2, Secret (SigningKey HydraKey)
-> Snapshot SimpleTx -> Signature (Snapshot SimpleTx)
forall a.
SignableRepresentation a =>
Secret (SigningKey HydraKey) -> a -> Signature a
sign Secret (SigningKey HydraKey)
bobSk Snapshot SimpleTx
snapshot2]

          UTCTime
now <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
startingState.chainPointTime.currentSlot
          let outcome :: Outcome SimpleTx
outcome = Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
startingState (ClientInput SimpleTx -> Input SimpleTx
forall tx. ClientInput tx -> Input tx
ClientInput (ConfirmedSnapshot SimpleTx -> ClientInput SimpleTx
forall tx. ConfirmedSnapshot tx -> ClientInput tx
SideLoadSnapshot (ConfirmedSnapshot SimpleTx -> ClientInput SimpleTx)
-> ConfirmedSnapshot SimpleTx -> ClientInput SimpleTx
forall a b. (a -> b) -> a -> b
$ Snapshot SimpleTx
-> MultiSignature (Snapshot SimpleTx) -> ConfirmedSnapshot SimpleTx
forall tx.
Snapshot tx -> MultiSignature (Snapshot tx) -> ConfirmedSnapshot tx
ConfirmedSnapshot Snapshot SimpleTx
snapshot2 MultiSignature (Snapshot SimpleTx)
multisig2))
          Outcome SimpleTx
outcome Outcome SimpleTx -> (Effect SimpleTx -> Bool) -> IO ()
forall tx.
(HasCallStack, IsChainState tx) =>
Outcome tx -> (Effect tx -> Bool) -> IO ()
`hasEffectSatisfying` \case
            ClientEffect (SideLoadSnapshotRejected{$sel:requirementFailure:CommandFailed :: forall tx. ClientMessage tx -> SideLoadRequirementFailure tx
requirementFailure = SideLoadSvNumberInvalid SnapshotVersion
1 SnapshotVersion
0}) -> Bool
True
            Effect SimpleTx
_ -> Bool
False

        String -> (Set SimpleTxOut -> IO ()) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"reject side load confirmed snapshot because wrong snapshot utxoToDecommit" ((Set SimpleTxOut -> IO ()) -> Spec)
-> (Set SimpleTxOut -> IO ()) -> Spec
forall a b. (a -> b) -> a -> b
$ \Set SimpleTxOut
utxoToDecommit -> do
          NodeState SimpleTx -> Maybe (Snapshot SimpleTx)
forall tx. IsTx tx => NodeState tx -> Maybe (Snapshot tx)
getConfirmedSnapshot NodeState SimpleTx
startingState Maybe (Snapshot SimpleTx) -> Maybe (Snapshot SimpleTx) -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Snapshot SimpleTx -> Maybe (Snapshot SimpleTx)
forall a. a -> Maybe a
Just Snapshot SimpleTx
snapshot1
          let utxo' :: UTxOType SimpleTx
utxo' = SimpleId -> UTxOType SimpleTx
utxoRef SimpleId
3
              utxoToDecom :: Maybe (Set SimpleTxOut)
utxoToDecom = Set SimpleTxOut -> Maybe (Set SimpleTxOut)
forall a. a -> Maybe a
Just Set SimpleTxOut
utxoToDecommit
              accumulator :: HydraAccumulator
accumulator = UTxOType SimpleTx
-> Maybe (UTxOType SimpleTx)
-> Maybe (UTxOType SimpleTx)
-> HydraAccumulator
forall tx.
IsTx tx =>
UTxOType tx
-> Maybe (UTxOType tx) -> Maybe (UTxOType tx) -> HydraAccumulator
Accumulator.buildFromSnapshotUTxOs Set SimpleTxOut
UTxOType SimpleTx
utxo' Maybe (Set SimpleTxOut)
Maybe (UTxOType SimpleTx)
forall a. Maybe a
Nothing Maybe (Set SimpleTxOut)
Maybe (UTxOType SimpleTx)
utxoToDecom
              snapshot2 :: Snapshot SimpleTx
snapshot2 = HeadId
-> SnapshotVersion
-> SnapshotNumber
-> [SimpleTx]
-> UTxOType SimpleTx
-> Maybe (UTxOType SimpleTx)
-> Maybe (TxIdType SimpleTx)
-> Maybe (UTxOType SimpleTx)
-> HydraAccumulator
-> Snapshot SimpleTx
forall tx.
HeadId
-> SnapshotVersion
-> SnapshotNumber
-> [tx]
-> UTxOType tx
-> Maybe (UTxOType tx)
-> Maybe (TxIdType tx)
-> Maybe (UTxOType tx)
-> HydraAccumulator
-> Snapshot tx
Snapshot HeadId
testHeadId SnapshotVersion
0 SnapshotNumber
2 [SimpleTx
tx2] Set SimpleTxOut
UTxOType SimpleTx
utxo' Maybe (Set SimpleTxOut)
Maybe (UTxOType SimpleTx)
forall a. Maybe a
Nothing Maybe SimpleId
Maybe (TxIdType SimpleTx)
forall a. Maybe a
Nothing Maybe (Set SimpleTxOut)
Maybe (UTxOType SimpleTx)
utxoToDecom HydraAccumulator
accumulator
              multisig2 :: MultiSignature (Snapshot SimpleTx)
multisig2 = [Signature (Snapshot SimpleTx)]
-> MultiSignature (Snapshot SimpleTx)
forall a. [Signature a] -> MultiSignature a
aggregate [Secret (SigningKey HydraKey)
-> Snapshot SimpleTx -> Signature (Snapshot SimpleTx)
forall a.
SignableRepresentation a =>
Secret (SigningKey HydraKey) -> a -> Signature a
sign Secret (SigningKey HydraKey)
aliceSk Snapshot SimpleTx
snapshot2, Secret (SigningKey HydraKey)
-> Snapshot SimpleTx -> Signature (Snapshot SimpleTx)
forall a.
SignableRepresentation a =>
Secret (SigningKey HydraKey) -> a -> Signature a
sign Secret (SigningKey HydraKey)
bobSk Snapshot SimpleTx
snapshot2]

          UTCTime
now <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
startingState.chainPointTime.currentSlot
          let outcome :: Outcome SimpleTx
outcome = Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
startingState (ClientInput SimpleTx -> Input SimpleTx
forall tx. ClientInput tx -> Input tx
ClientInput (ConfirmedSnapshot SimpleTx -> ClientInput SimpleTx
forall tx. ConfirmedSnapshot tx -> ClientInput tx
SideLoadSnapshot (ConfirmedSnapshot SimpleTx -> ClientInput SimpleTx)
-> ConfirmedSnapshot SimpleTx -> ClientInput SimpleTx
forall a b. (a -> b) -> a -> b
$ Snapshot SimpleTx
-> MultiSignature (Snapshot SimpleTx) -> ConfirmedSnapshot SimpleTx
forall tx.
Snapshot tx -> MultiSignature (Snapshot tx) -> ConfirmedSnapshot tx
ConfirmedSnapshot Snapshot SimpleTx
snapshot2 MultiSignature (Snapshot SimpleTx)
multisig2))
          Outcome SimpleTx
outcome Outcome SimpleTx -> (Effect SimpleTx -> Bool) -> IO ()
forall tx.
(HasCallStack, IsChainState tx) =>
Outcome tx -> (Effect tx -> Bool) -> IO ()
`hasEffectSatisfying` \case
            ClientEffect (SideLoadSnapshotRejected{$sel:requirementFailure:CommandFailed :: forall tx. ClientMessage tx -> SideLoadRequirementFailure tx
requirementFailure = SideLoadUTxOToDecommitInvalid (Just UTxOType SimpleTx
utxoToDecommit') Maybe (UTxOType SimpleTx)
Nothing}) ->
              Set SimpleTxOut
UTxOType SimpleTx
utxoToDecommit' Set SimpleTxOut -> Set SimpleTxOut -> Bool
forall a. Eq a => a -> a -> Bool
== Set SimpleTxOut
utxoToDecommit
            Effect SimpleTx
_ -> Bool
False

        String -> (Set SimpleTxOut -> IO ()) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"reject side load confirmed snapshot because wrong snapshot utxoToCommit" ((Set SimpleTxOut -> IO ()) -> Spec)
-> (Set SimpleTxOut -> IO ()) -> Spec
forall a b. (a -> b) -> a -> b
$ \Set SimpleTxOut
utxoToCommit -> do
          NodeState SimpleTx -> Maybe (Snapshot SimpleTx)
forall tx. IsTx tx => NodeState tx -> Maybe (Snapshot tx)
getConfirmedSnapshot NodeState SimpleTx
startingState Maybe (Snapshot SimpleTx) -> Maybe (Snapshot SimpleTx) -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Snapshot SimpleTx -> Maybe (Snapshot SimpleTx)
forall a. a -> Maybe a
Just Snapshot SimpleTx
snapshot1

          let utxo' :: UTxOType SimpleTx
utxo' = SimpleId -> UTxOType SimpleTx
utxoRef SimpleId
3
              utxoToCom :: Maybe (Set SimpleTxOut)
utxoToCom = Set SimpleTxOut -> Maybe (Set SimpleTxOut)
forall a. a -> Maybe a
Just Set SimpleTxOut
utxoToCommit
              accumulator :: HydraAccumulator
accumulator = UTxOType SimpleTx
-> Maybe (UTxOType SimpleTx)
-> Maybe (UTxOType SimpleTx)
-> HydraAccumulator
forall tx.
IsTx tx =>
UTxOType tx
-> Maybe (UTxOType tx) -> Maybe (UTxOType tx) -> HydraAccumulator
Accumulator.buildFromSnapshotUTxOs Set SimpleTxOut
UTxOType SimpleTx
utxo' Maybe (Set SimpleTxOut)
Maybe (UTxOType SimpleTx)
utxoToCom Maybe (Set SimpleTxOut)
Maybe (UTxOType SimpleTx)
forall a. Maybe a
Nothing
              snapshot2 :: Snapshot SimpleTx
snapshot2 = HeadId
-> SnapshotVersion
-> SnapshotNumber
-> [SimpleTx]
-> UTxOType SimpleTx
-> Maybe (UTxOType SimpleTx)
-> Maybe (TxIdType SimpleTx)
-> Maybe (UTxOType SimpleTx)
-> HydraAccumulator
-> Snapshot SimpleTx
forall tx.
HeadId
-> SnapshotVersion
-> SnapshotNumber
-> [tx]
-> UTxOType tx
-> Maybe (UTxOType tx)
-> Maybe (TxIdType tx)
-> Maybe (UTxOType tx)
-> HydraAccumulator
-> Snapshot tx
Snapshot HeadId
testHeadId SnapshotVersion
0 SnapshotNumber
2 [SimpleTx
tx2] Set SimpleTxOut
UTxOType SimpleTx
utxo' Maybe (Set SimpleTxOut)
Maybe (UTxOType SimpleTx)
utxoToCom (SimpleId -> Maybe SimpleId
forall a. a -> Maybe a
Just SimpleId
2) Maybe (Set SimpleTxOut)
Maybe (UTxOType SimpleTx)
forall a. Maybe a
Nothing HydraAccumulator
accumulator
              multisig2 :: MultiSignature (Snapshot SimpleTx)
multisig2 = [Signature (Snapshot SimpleTx)]
-> MultiSignature (Snapshot SimpleTx)
forall a. [Signature a] -> MultiSignature a
aggregate [Secret (SigningKey HydraKey)
-> Snapshot SimpleTx -> Signature (Snapshot SimpleTx)
forall a.
SignableRepresentation a =>
Secret (SigningKey HydraKey) -> a -> Signature a
sign Secret (SigningKey HydraKey)
aliceSk Snapshot SimpleTx
snapshot2, Secret (SigningKey HydraKey)
-> Snapshot SimpleTx -> Signature (Snapshot SimpleTx)
forall a.
SignableRepresentation a =>
Secret (SigningKey HydraKey) -> a -> Signature a
sign Secret (SigningKey HydraKey)
bobSk Snapshot SimpleTx
snapshot2]

          UTCTime
now <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
startingState.chainPointTime.currentSlot
          let outcome :: Outcome SimpleTx
outcome = Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
startingState (ClientInput SimpleTx -> Input SimpleTx
forall tx. ClientInput tx -> Input tx
ClientInput (ConfirmedSnapshot SimpleTx -> ClientInput SimpleTx
forall tx. ConfirmedSnapshot tx -> ClientInput tx
SideLoadSnapshot (ConfirmedSnapshot SimpleTx -> ClientInput SimpleTx)
-> ConfirmedSnapshot SimpleTx -> ClientInput SimpleTx
forall a b. (a -> b) -> a -> b
$ Snapshot SimpleTx
-> MultiSignature (Snapshot SimpleTx) -> ConfirmedSnapshot SimpleTx
forall tx.
Snapshot tx -> MultiSignature (Snapshot tx) -> ConfirmedSnapshot tx
ConfirmedSnapshot Snapshot SimpleTx
snapshot2 MultiSignature (Snapshot SimpleTx)
multisig2))
          Outcome SimpleTx
outcome Outcome SimpleTx -> (Effect SimpleTx -> Bool) -> IO ()
forall tx.
(HasCallStack, IsChainState tx) =>
Outcome tx -> (Effect tx -> Bool) -> IO ()
`hasEffectSatisfying` \case
            ClientEffect (SideLoadSnapshotRejected{$sel:requirementFailure:CommandFailed :: forall tx. ClientMessage tx -> SideLoadRequirementFailure tx
requirementFailure = SideLoadUTxOToCommitInvalid (Just UTxOType SimpleTx
utxoToCommit') Maybe (UTxOType SimpleTx)
Nothing}) ->
              Set SimpleTxOut
UTxOType SimpleTx
utxoToCommit' Set SimpleTxOut -> Set SimpleTxOut -> Bool
forall a. Eq a => a -> a -> Bool
== Set SimpleTxOut
utxoToCommit
            Effect SimpleTx
_ -> Bool
False

        String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"accept side load confirmed snapshot with idempotence" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
          NodeState SimpleTx -> Maybe (Snapshot SimpleTx)
forall tx. IsTx tx => NodeState tx -> Maybe (Snapshot tx)
getConfirmedSnapshot NodeState SimpleTx
startingState Maybe (Snapshot SimpleTx) -> Maybe (Snapshot SimpleTx) -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Snapshot SimpleTx -> Maybe (Snapshot SimpleTx)
forall a. a -> Maybe a
Just Snapshot SimpleTx
snapshot1

          NodeState SimpleTx
sideLoadedState <- Environment
-> Ledger SimpleTx
-> NodeState SimpleTx
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall (m :: * -> *) tx a.
Monad m =>
Environment
-> Ledger tx -> NodeState tx -> StateT (StepState tx) m a -> m a
runHeadLogic Environment
bobEnv Ledger SimpleTx
ledger NodeState SimpleTx
startingState (StateT (StepState SimpleTx) IO (NodeState SimpleTx)
 -> IO (NodeState SimpleTx))
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall a b. (a -> b) -> a -> b
$ do
            Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step (Input SimpleTx
 -> StateT (StepState SimpleTx) IO (Outcome SimpleTx))
-> Input SimpleTx
-> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall a b. (a -> b) -> a -> b
$ ClientInput SimpleTx -> Input SimpleTx
forall tx. ClientInput tx -> Input tx
ClientInput (ConfirmedSnapshot SimpleTx -> ClientInput SimpleTx
forall tx. ConfirmedSnapshot tx -> ClientInput tx
SideLoadSnapshot (ConfirmedSnapshot SimpleTx -> ClientInput SimpleTx)
-> ConfirmedSnapshot SimpleTx -> ClientInput SimpleTx
forall a b. (a -> b) -> a -> b
$ Snapshot SimpleTx
-> MultiSignature (Snapshot SimpleTx) -> ConfirmedSnapshot SimpleTx
forall tx.
Snapshot tx -> MultiSignature (Snapshot tx) -> ConfirmedSnapshot tx
ConfirmedSnapshot Snapshot SimpleTx
snapshot1 MultiSignature (Snapshot SimpleTx)
multisig1)
            StateT (StepState SimpleTx) IO (NodeState SimpleTx)
forall tx (m :: * -> *).
MonadState (StepState tx) m =>
m (NodeState tx)
getState

          NodeState SimpleTx -> Maybe (Snapshot SimpleTx)
forall tx. IsTx tx => NodeState tx -> Maybe (Snapshot tx)
getConfirmedSnapshot NodeState SimpleTx
sideLoadedState Maybe (Snapshot SimpleTx) -> Maybe (Snapshot SimpleTx) -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Snapshot SimpleTx -> Maybe (Snapshot SimpleTx)
forall a. a -> Maybe a
Just Snapshot SimpleTx
snapshot1

        String -> (HeadId -> IO ()) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"ignores side load confirmed snapshot of another head" ((HeadId -> IO ()) -> Spec) -> (HeadId -> IO ()) -> Spec
forall a b. (a -> b) -> a -> b
$ \HeadId
otherHeadId -> do
          NodeState SimpleTx -> Maybe (Snapshot SimpleTx)
forall tx. IsTx tx => NodeState tx -> Maybe (Snapshot tx)
getConfirmedSnapshot NodeState SimpleTx
startingState Maybe (Snapshot SimpleTx) -> Maybe (Snapshot SimpleTx) -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Snapshot SimpleTx -> Maybe (Snapshot SimpleTx)
forall a. a -> Maybe a
Just Snapshot SimpleTx
snapshot1

          let snapshot1OtherHead :: Snapshot SimpleTx
snapshot1OtherHead = (SnapshotNumber
-> SnapshotVersion
-> [SimpleTx]
-> UTxOType SimpleTx
-> Snapshot SimpleTx
forall tx.
IsTx tx =>
SnapshotNumber
-> SnapshotVersion -> [tx] -> UTxOType tx -> Snapshot tx
testSnapshot SnapshotNumber
1 SnapshotVersion
0 [SimpleTx
tx1] (SimpleId -> UTxOType SimpleTx
utxoRef SimpleId
2)){headId = otherHeadId} :: Snapshot SimpleTx
              multisig1OtherHead :: MultiSignature (Snapshot SimpleTx)
multisig1OtherHead = [Signature (Snapshot SimpleTx)]
-> MultiSignature (Snapshot SimpleTx)
forall a. [Signature a] -> MultiSignature a
aggregate [Secret (SigningKey HydraKey)
-> Snapshot SimpleTx -> Signature (Snapshot SimpleTx)
forall a.
SignableRepresentation a =>
Secret (SigningKey HydraKey) -> a -> Signature a
sign Secret (SigningKey HydraKey)
aliceSk Snapshot SimpleTx
snapshot1OtherHead, Secret (SigningKey HydraKey)
-> Snapshot SimpleTx -> Signature (Snapshot SimpleTx)
forall a.
SignableRepresentation a =>
Secret (SigningKey HydraKey) -> a -> Signature a
sign Secret (SigningKey HydraKey)
bobSk Snapshot SimpleTx
snapshot1OtherHead, Secret (SigningKey HydraKey)
-> Snapshot SimpleTx -> Signature (Snapshot SimpleTx)
forall a.
SignableRepresentation a =>
Secret (SigningKey HydraKey) -> a -> Signature a
sign Secret (SigningKey HydraKey)
carolSk Snapshot SimpleTx
snapshot1OtherHead]
              confirmedSnapshotOtherHead :: ConfirmedSnapshot SimpleTx
confirmedSnapshotOtherHead = Snapshot SimpleTx
-> MultiSignature (Snapshot SimpleTx) -> ConfirmedSnapshot SimpleTx
forall tx.
Snapshot tx -> MultiSignature (Snapshot tx) -> ConfirmedSnapshot tx
ConfirmedSnapshot Snapshot SimpleTx
snapshot1OtherHead MultiSignature (Snapshot SimpleTx)
multisig1OtherHead

          UTCTime
now <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState SimpleTx
startingState.chainPointTime.currentSlot
          Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger UTCTime
now NodeState SimpleTx
startingState (ClientInput SimpleTx -> Input SimpleTx
forall tx. ClientInput tx -> Input tx
ClientInput (ConfirmedSnapshot SimpleTx -> ClientInput SimpleTx
forall tx. ConfirmedSnapshot tx -> ClientInput tx
SideLoadSnapshot ConfirmedSnapshot SimpleTx
confirmedSnapshotOtherHead))
            Outcome SimpleTx -> Outcome SimpleTx -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` LogicError SimpleTx -> Outcome SimpleTx
forall tx. LogicError tx -> Outcome tx
Error (NotOurHead{$sel:ourHeadId:UnhandledInput :: HeadId
ourHeadId = HeadId
testHeadId, HeadId
$sel:otherHeadId:UnhandledInput :: HeadId
otherHeadId :: HeadId
otherHeadId})

        String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"recovered deposit must not appear in new snapshot utxo after sideload" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
          -- Regression test for https://github.com/cardano-scaling/hydra/issues/2629
          --
          -- After a deposit snapshot is confirmed but IncrementTx never finalises
          -- and the deposit is recovered on L1, sideloading that snapshot and then
          -- triggering a new L2 snapshot must not reintroduce the recovered deposit
          -- into the new snapshot's utxo.
          UTCTime
now <- IO UTCTime
forall (m :: * -> *). MonadTime m => m UTCTime
getCurrentTime
          let 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
              depositTime :: NominalDiffTime -> UTCTime
depositTime = UTCTime -> NominalDiffTime -> UTCTime
plusTime UTCTime
now
              depositTxId :: SimpleId
depositTxId = SimpleId
42 :: Integer
              depositedUTxO :: UTxOType SimpleTx
depositedUTxO = SimpleId -> UTxOType SimpleTx
utxoRef SimpleId
depositTxId
              aliceEnv' :: Environment
aliceEnv' =
                Environment
aliceEnv
                  { otherParties = []
                  , participants = deriveOnChainId <$> [alice]
                  }
              singleParty :: [Party]
singleParty = [Party
alice]
              activeDeposit :: Deposit SimpleTx
activeDeposit =
                Deposit
                  { $sel:headId:Deposit :: HeadId
headId = HeadId
testHeadId
                  , $sel:deposited:Deposit :: UTxOType SimpleTx
deposited = Set SimpleTxOut
UTxOType SimpleTx
depositedUTxO
                  , $sel:created:Deposit :: UTCTime
created = NominalDiffTime -> UTCTime
depositTime NominalDiffTime
1
                  , $sel:deadline:Deposit :: UTCTime
deadline = NominalDiffTime -> UTCTime
depositTime NominalDiffTime
600
                  , $sel:status:Deposit :: DepositStatus
status = DepositStatus
Active
                  }
              depositSnapshot :: Snapshot SimpleTx
depositSnapshot =
                Snapshot
                  { $sel:headId:Snapshot :: HeadId
headId = HeadId
testHeadId
                  , $sel:version:Snapshot :: SnapshotVersion
version = SnapshotVersion
0
                  , $sel:number:Snapshot :: SnapshotNumber
number = SnapshotNumber
1
                  , $sel:confirmed:Snapshot :: [SimpleTx]
confirmed = []
                  , $sel:utxo:Snapshot :: UTxOType SimpleTx
utxo = UTxOType SimpleTx
forall a. Monoid a => a
mempty
                  , $sel:utxoToCommit:Snapshot :: Maybe (UTxOType SimpleTx)
utxoToCommit = Set SimpleTxOut -> Maybe (Set SimpleTxOut)
forall a. a -> Maybe a
Just Set SimpleTxOut
depositedUTxO
                  , $sel:utxoToDecommit:Snapshot :: Maybe (UTxOType SimpleTx)
utxoToDecommit = Maybe (Set SimpleTxOut)
Maybe (UTxOType SimpleTx)
forall a. Maybe a
Nothing
                  , $sel:depositTxId:Snapshot :: Maybe (TxIdType SimpleTx)
depositTxId = SimpleId -> Maybe SimpleId
forall a. a -> Maybe a
Just SimpleId
depositTxId
                  , $sel:accumulator:Snapshot :: HydraAccumulator
accumulator = UTxOType SimpleTx
-> Maybe (UTxOType SimpleTx)
-> Maybe (UTxOType SimpleTx)
-> HydraAccumulator
forall tx.
IsTx tx =>
UTxOType tx
-> Maybe (UTxOType tx) -> Maybe (UTxOType tx) -> HydraAccumulator
Accumulator.buildFromSnapshotUTxOs UTxOType SimpleTx
forall a. Monoid a => a
mempty (Set SimpleTxOut -> Maybe (Set SimpleTxOut)
forall a. a -> Maybe a
Just Set SimpleTxOut
depositedUTxO) Maybe (Set SimpleTxOut)
Maybe (UTxOType SimpleTx)
forall a. Maybe a
Nothing
                  }
              depositMultisig :: MultiSignature (Snapshot SimpleTx)
depositMultisig = [Signature (Snapshot SimpleTx)]
-> MultiSignature (Snapshot SimpleTx)
forall a. [Signature a] -> MultiSignature a
aggregate [Secret (SigningKey HydraKey)
-> Snapshot SimpleTx -> Signature (Snapshot SimpleTx)
forall a.
SignableRepresentation a =>
Secret (SigningKey HydraKey) -> a -> Signature a
sign Secret (SigningKey HydraKey)
aliceSk Snapshot SimpleTx
depositSnapshot]
          -- Start with deposit already active and tracked
          let s0 :: NodeState SimpleTx
s0 =
                ( [Party] -> CoordinatedHeadState SimpleTx -> NodeState SimpleTx
inOpenState' [Party]
singleParty (CoordinatedHeadState SimpleTx -> NodeState SimpleTx)
-> CoordinatedHeadState SimpleTx -> NodeState SimpleTx
forall a b. (a -> b) -> a -> b
$
                    CoordinatedHeadState SimpleTx
coordinatedHeadState{currentDepositTxId = Just depositTxId}
                )
                  { pendingDeposits = Map.singleton depositTxId activeDeposit
                  }
          -- Step 1: Confirm snapshot 1 including the deposit in utxoToCommit
          NodeState SimpleTx
s1 <- Environment
-> Ledger SimpleTx
-> NodeState SimpleTx
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall (m :: * -> *) tx a.
Monad m =>
Environment
-> Ledger tx -> NodeState tx -> StateT (StepState tx) m a -> m a
runHeadLogic Environment
aliceEnv' Ledger SimpleTx
ledger NodeState SimpleTx
s0 (StateT (StepState SimpleTx) IO (NodeState SimpleTx)
 -> IO (NodeState SimpleTx))
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall a b. (a -> b) -> a -> b
$ do
            Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step (Input SimpleTx
 -> StateT (StepState SimpleTx) IO (Outcome SimpleTx))
-> Input SimpleTx
-> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall a b. (a -> b) -> a -> b
$ Message SimpleTx -> Input SimpleTx
forall tx. Message tx -> Input tx
receiveMessage (Message SimpleTx -> Input SimpleTx)
-> Message SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ SnapshotVersion
-> SnapshotNumber
-> [TxIdType SimpleTx]
-> Maybe SimpleTx
-> Maybe (TxIdType SimpleTx)
-> Message SimpleTx
forall tx.
SnapshotVersion
-> SnapshotNumber
-> [TxIdType tx]
-> Maybe tx
-> Maybe (TxIdType tx)
-> Message tx
ReqSn SnapshotVersion
0 SnapshotNumber
1 [] Maybe SimpleTx
forall a. Maybe a
Nothing (SimpleId -> Maybe SimpleId
forall a. a -> Maybe a
Just SimpleId
depositTxId)
            Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step (Input SimpleTx
 -> StateT (StepState SimpleTx) IO (Outcome SimpleTx))
-> Input SimpleTx
-> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall a b. (a -> b) -> a -> b
$ Message SimpleTx -> Input SimpleTx
forall tx. Message tx -> Input tx
receiveMessage (Message SimpleTx -> Input SimpleTx)
-> Message SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ Signature (Snapshot SimpleTx) -> SnapshotNumber -> Message SimpleTx
forall tx. Signature (Snapshot tx) -> SnapshotNumber -> Message tx
AckSn (Secret (SigningKey HydraKey)
-> Snapshot SimpleTx -> Signature (Snapshot SimpleTx)
forall a.
SignableRepresentation a =>
Secret (SigningKey HydraKey) -> a -> Signature a
sign Secret (SigningKey HydraKey)
aliceSk Snapshot SimpleTx
depositSnapshot) SnapshotNumber
1
            StateT (StepState SimpleTx) IO (NodeState SimpleTx)
forall tx (m :: * -> *).
MonadState (StepState tx) m =>
m (NodeState tx)
getState
          -- Step 2: Recover the deposit (IncrementTx never finalized on-chain)
          NodeState SimpleTx
s2 <- Environment
-> Ledger SimpleTx
-> NodeState SimpleTx
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall (m :: * -> *) tx a.
Monad m =>
Environment
-> Ledger tx -> NodeState tx -> StateT (StepState tx) m a -> m a
runHeadLogic Environment
aliceEnv' Ledger SimpleTx
ledger NodeState SimpleTx
s1 (StateT (StepState SimpleTx) IO (NodeState SimpleTx)
 -> IO (NodeState SimpleTx))
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall a b. (a -> b) -> a -> b
$ do
            Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step (Input SimpleTx
 -> StateT (StepState SimpleTx) IO (Outcome SimpleTx))
-> Input SimpleTx
-> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall a b. (a -> b) -> a -> b
$
              ChainSlot -> OnChainTx SimpleTx -> Input SimpleTx
observeTxAtSlot ChainSlot
2 (OnChainTx SimpleTx -> Input SimpleTx)
-> OnChainTx SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$
                OnRecoverTx
                  { $sel:headId:OnInitTx :: HeadId
headId = HeadId
testHeadId
                  , $sel:recoveredTxId:OnInitTx :: TxIdType SimpleTx
recoveredTxId = SimpleId
TxIdType SimpleTx
depositTxId
                  , $sel:recoveredUTxO:OnInitTx :: UTxOType SimpleTx
recoveredUTxO = Set SimpleTxOut
UTxOType SimpleTx
depositedUTxO
                  }
            StateT (StepState SimpleTx) IO (NodeState SimpleTx)
forall tx (m :: * -> *).
MonadState (StepState tx) m =>
m (NodeState tx)
getState
          SimpleId
-> Map SimpleId (Deposit SimpleTx) -> Maybe (Deposit SimpleTx)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup SimpleId
depositTxId NodeState SimpleTx
s2.pendingDeposits Maybe (Deposit SimpleTx) -> Maybe (Deposit SimpleTx) -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Maybe (Deposit SimpleTx)
forall a. Maybe a
Nothing
          -- Step 3: Sideload snapshot 1 to unstick the head
          NodeState SimpleTx
s3 <- Environment
-> Ledger SimpleTx
-> NodeState SimpleTx
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall (m :: * -> *) tx a.
Monad m =>
Environment
-> Ledger tx -> NodeState tx -> StateT (StepState tx) m a -> m a
runHeadLogic Environment
aliceEnv' Ledger SimpleTx
ledger NodeState SimpleTx
s2 (StateT (StepState SimpleTx) IO (NodeState SimpleTx)
 -> IO (NodeState SimpleTx))
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall a b. (a -> b) -> a -> b
$ do
            Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step (Input SimpleTx
 -> StateT (StepState SimpleTx) IO (Outcome SimpleTx))
-> Input SimpleTx
-> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall a b. (a -> b) -> a -> b
$ ClientInput SimpleTx -> Input SimpleTx
forall tx. ClientInput tx -> Input tx
ClientInput (ClientInput SimpleTx -> Input SimpleTx)
-> ClientInput SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ ConfirmedSnapshot SimpleTx -> ClientInput SimpleTx
forall tx. ConfirmedSnapshot tx -> ClientInput tx
SideLoadSnapshot (ConfirmedSnapshot SimpleTx -> ClientInput SimpleTx)
-> ConfirmedSnapshot SimpleTx -> ClientInput SimpleTx
forall a b. (a -> b) -> a -> b
$ Snapshot SimpleTx
-> MultiSignature (Snapshot SimpleTx) -> ConfirmedSnapshot SimpleTx
forall tx.
Snapshot tx -> MultiSignature (Snapshot tx) -> ConfirmedSnapshot tx
ConfirmedSnapshot Snapshot SimpleTx
depositSnapshot MultiSignature (Snapshot SimpleTx)
depositMultisig
            StateT (StepState SimpleTx) IO (NodeState SimpleTx)
forall tx (m :: * -> *).
MonadState (StepState tx) m =>
m (NodeState tx)
getState
          -- Step 4: Submit a new L2 transaction
          let newTx :: SimpleTx
newTx = SimpleId -> SimpleTx
aValidTx SimpleId
1
          NodeState SimpleTx
s4 <- Environment
-> Ledger SimpleTx
-> NodeState SimpleTx
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall (m :: * -> *) tx a.
Monad m =>
Environment
-> Ledger tx -> NodeState tx -> StateT (StepState tx) m a -> m a
runHeadLogic Environment
aliceEnv' Ledger SimpleTx
ledger NodeState SimpleTx
s3 (StateT (StepState SimpleTx) IO (NodeState SimpleTx)
 -> IO (NodeState SimpleTx))
-> StateT (StepState SimpleTx) IO (NodeState SimpleTx)
-> IO (NodeState SimpleTx)
forall a b. (a -> b) -> a -> b
$ do
            Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step (Input SimpleTx
 -> StateT (StepState SimpleTx) IO (Outcome SimpleTx))
-> Input SimpleTx
-> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall a b. (a -> b) -> a -> b
$ Message SimpleTx -> Input SimpleTx
forall tx. Message tx -> Input tx
receiveMessage (Message SimpleTx -> Input SimpleTx)
-> Message SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ SimpleTx -> Message SimpleTx
forall tx. tx -> Message tx
ReqTx SimpleTx
newTx
            StateT (StepState SimpleTx) IO (NodeState SimpleTx)
forall tx (m :: * -> *).
MonadState (StepState tx) m =>
m (NodeState tx)
getState
          -- Step 5: Process the new snapshot request — the recovered deposit must not
          -- appear in the new snapshot's utxo field
          let reqSn2 :: Input SimpleTx
reqSn2 = Message SimpleTx -> Input SimpleTx
forall tx. Message tx -> Input tx
receiveMessage (Message SimpleTx -> Input SimpleTx)
-> Message SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ SnapshotVersion
-> SnapshotNumber
-> [TxIdType SimpleTx]
-> Maybe SimpleTx
-> Maybe (TxIdType SimpleTx)
-> Message SimpleTx
forall tx.
SnapshotVersion
-> SnapshotNumber
-> [TxIdType tx]
-> Maybe tx
-> Maybe (TxIdType tx)
-> Message tx
ReqSn SnapshotVersion
0 SnapshotNumber
2 [SimpleTx -> TxIdType SimpleTx
forall tx. IsTx tx => tx -> TxIdType tx
txId SimpleTx
newTx] Maybe SimpleTx
forall a. Maybe a
Nothing Maybe SimpleId
Maybe (TxIdType SimpleTx)
forall a. Maybe a
Nothing
          Outcome SimpleTx
outcome <- Environment
-> Ledger SimpleTx
-> NodeState SimpleTx
-> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
-> IO (Outcome SimpleTx)
forall (m :: * -> *) tx a.
Monad m =>
Environment
-> Ledger tx -> NodeState tx -> StateT (StepState tx) m a -> m a
runHeadLogic Environment
aliceEnv' Ledger SimpleTx
ledger NodeState SimpleTx
s4 (StateT (StepState SimpleTx) IO (Outcome SimpleTx)
 -> IO (Outcome SimpleTx))
-> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
-> IO (Outcome SimpleTx)
forall a b. (a -> b) -> a -> b
$ Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step Input SimpleTx
reqSn2
          -- Extract the new snapshot's utxo and show both sides of the invariant:
          -- depositedUTxO is on L1 (it was recovered), and must not also be on L2.
          case Outcome SimpleTx
outcome of
            Continue{[StateChanged SimpleTx]
$sel:stateChanges:Continue :: forall tx. Outcome tx -> [StateChanged tx]
stateChanges :: [StateChanged SimpleTx]
stateChanges} -> do
              let mSnapUtxo :: Maybe (Set SimpleTxOut)
mSnapUtxo =
                    [Set SimpleTxOut] -> Maybe (Set SimpleTxOut)
forall a. [a] -> Maybe a
listToMaybe
                      [ Set SimpleTxOut
UTxOType SimpleTx
utxo
                      | SnapshotRequested{$sel:requestedSnapshot:NetworkConnected :: forall tx. StateChanged tx -> Snapshot tx
requestedSnapshot = Snapshot{UTxOType SimpleTx
$sel:utxo:Snapshot :: forall tx. Snapshot tx -> UTxOType tx
utxo :: UTxOType SimpleTx
utxo}} <- [StateChanged SimpleTx]
stateChanges
                      ]
              case Maybe (Set SimpleTxOut)
mSnapUtxo of
                Maybe (Set SimpleTxOut)
Nothing -> HasCallStack => String -> IO ()
String -> IO ()
expectationFailure String
"Expected SnapshotRequested state change"
                Just Set SimpleTxOut
snapUtxo ->
                  -- The intersection of {recovered L1 deposit} and {new L2 snapshot utxo}
                  -- must be empty — the same UTxO cannot exist on both layers.
                  Set SimpleTxOut -> Set SimpleTxOut -> Set SimpleTxOut
forall a. Ord a => Set a -> Set a -> Set a
Set.intersection Set SimpleTxOut
depositedUTxO Set SimpleTxOut
snapUtxo Set SimpleTxOut -> Set SimpleTxOut -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Set SimpleTxOut
forall a. Monoid a => a
mempty
            Outcome SimpleTx
_ -> HasCallStack => String -> IO ()
String -> IO ()
expectationFailure (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Expected Continue outcome, got: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Outcome SimpleTx -> String
forall b a. (Show a, IsString b) => a -> b
show Outcome SimpleTx
outcome

    String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Coordinated Head Protocol using real Tx" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
      let ledger :: Ledger Tx
ledger = Globals -> LedgerEnv LedgerEra -> Ledger Tx
cardanoLedger Globals
Fixture.defaultGlobals LedgerEnv LedgerEra
Fixture.defaultLedgerEnv

      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"stores a fully evaluated snapshot UTxO when processing ReqSn" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        -- Two outputs; the tx spends only the first. The second is carried over
        -- unchanged: 'forceNewEntries' deliberately trusts carried-over entries,
        -- so the design invariant is that every UTxO ingress forces - the seed
        -- models one (hence 'forceUTxO', as at the real ingress points) and the
        -- application must force the transaction's own outputs.
        (VerificationKey PaymentKey
vk, SigningKey PaymentKey
sk) <- Gen (VerificationKey PaymentKey, SigningKey PaymentKey)
-> IO (VerificationKey PaymentKey, SigningKey PaymentKey)
forall a. Gen a -> IO a
generate Gen (VerificationKey PaymentKey, SigningKey PaymentKey)
genKeyPair
        TxOut CtxUTxO
txOut1 <- Gen (TxOut CtxUTxO) -> IO (TxOut CtxUTxO)
forall a. Gen a -> IO a
generate (VerificationKey PaymentKey -> Gen (TxOut CtxUTxO)
forall ctx. VerificationKey PaymentKey -> Gen (TxOut ctx)
genOutputFor VerificationKey PaymentKey
vk)
        TxOut CtxUTxO
txOut2 <- Gen (TxOut CtxUTxO) -> IO (TxOut CtxUTxO)
forall a. Gen a -> IO a
generate (VerificationKey PaymentKey -> Gen (TxOut CtxUTxO)
forall ctx. VerificationKey PaymentKey -> Gen (TxOut ctx)
genOutputFor VerificationKey PaymentKey
vk)
        TxIn
txIn1 <- Gen TxIn -> IO TxIn
forall a. Gen a -> IO a
generate Gen TxIn
genTxIn
        TxIn
txIn2 <- Gen TxIn -> IO TxIn
forall a. Gen a -> IO a
generate Gen TxIn
genTxIn
        let u0 :: UTxO
u0 = UTxO -> UTxO
forceUTxO (UTxO -> UTxO) -> UTxO -> UTxO
forall a b. (a -> b) -> a -> b
$ [(TxIn, TxOut CtxUTxO)] -> UTxO
forall era. [(TxIn, TxOut CtxUTxO era)] -> UTxO era
UTxO.fromList [(TxIn
txIn1, TxOut CtxUTxO
txOut1), (TxIn
txIn2, TxOut CtxUTxO
txOut2)]
        Tx
tx <- case (TxIn, TxOut CtxUTxO)
-> (AddressInEra, Value)
-> Secret (SigningKey PaymentKey)
-> Either TxBodyError Tx
mkSimpleTx (TxIn
txIn1, TxOut CtxUTxO
txOut1) (NetworkId -> VerificationKey PaymentKey -> AddressInEra
forall era.
IsShelleyBasedEra era =>
NetworkId -> VerificationKey PaymentKey -> AddressInEra era
mkVkAddress NetworkId
Fixture.testNetworkId VerificationKey PaymentKey
vk, TxOut CtxUTxO -> Value
forall ctx. TxOut ctx -> Value
txOutValue TxOut CtxUTxO
txOut1) (SigningKey PaymentKey -> Secret (SigningKey PaymentKey)
forall a. a -> Secret a
mkSecret SigningKey PaymentKey
sk) of
          Left TxBodyError
err -> String -> IO Tx
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure (String -> IO Tx) -> String -> IO Tx
forall a b. (a -> b) -> a -> b
$ String
"cannot create tx: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> TxBodyError -> String
forall b a. (Show a, IsString b) => a -> b
show TxBodyError
err
          Right Tx
tx' -> Tx -> IO Tx
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Tx
tx'
        let st0 :: NodeState Tx
st0 =
              HeadState Tx -> NodeState Tx
forall tx. IsTx tx => HeadState tx -> NodeState tx
inSync (HeadState Tx -> NodeState Tx) -> HeadState Tx -> NodeState Tx
forall a b. (a -> b) -> a -> b
$
                OpenState Tx -> HeadState Tx
forall tx. OpenState tx -> HeadState tx
Open
                  OpenState
                    { $sel:parameters:OpenState :: HeadParameters
parameters = ContestationPeriod -> DepositPeriod -> [Party] -> HeadParameters
HeadParameters ContestationPeriod
defaultContestationPeriod DepositPeriod
defaultDepositPeriod [Party
alice]
                    , $sel:coordinatedHeadState:OpenState :: CoordinatedHeadState Tx
coordinatedHeadState =
                        CoordinatedHeadState
                          { $sel:localUTxO:CoordinatedHeadState :: UTxOType Tx
localUTxO = UTxOType Tx
UTxO
u0
                          , $sel:allTxs:CoordinatedHeadState :: Map (TxIdType Tx) Tx
allTxs = Map (TxIdType Tx) Tx
Map TxId 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 =
                              ConfirmedSnapshot{$sel:snapshot:InitialSnapshot :: Snapshot Tx
snapshot = SnapshotNumber
-> SnapshotVersion -> [Tx] -> UTxOType Tx -> Snapshot Tx
forall tx.
IsTx tx =>
SnapshotNumber
-> SnapshotVersion -> [tx] -> UTxOType tx -> Snapshot tx
testSnapshot SnapshotNumber
0 SnapshotVersion
0 [] UTxOType Tx
UTxO
u0, $sel:signatures:InitialSnapshot :: MultiSignature (Snapshot Tx)
signatures = MultiSignature (Snapshot Tx)
forall a. Monoid a => a
mempty}
                          , $sel:seenSnapshot:CoordinatedHeadState :: SeenSnapshot Tx
seenSnapshot = SeenSnapshot Tx
forall tx. SeenSnapshot tx
NoSeenSnapshot
                          , $sel:currentDepositTxId:CoordinatedHeadState :: Maybe (TxIdType Tx)
currentDepositTxId = Maybe (TxIdType Tx)
Maybe TxId
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:chainState:OpenState :: ChainStateType Tx
chainState = ChainStateAt{$sel:spendableUTxO:ChainStateAt :: UTxO
spendableUTxO = UTxO
forall a. Monoid a => a
mempty, $sel:recordedAt:ChainStateAt :: Maybe ChainPoint
recordedAt = Maybe ChainPoint
forall a. Maybe a
Nothing}
                    , $sel:headId:OpenState :: HeadId
headId = HeadId
testHeadId
                    , $sel:headSeed:OpenState :: HeadSeed
headSeed = HeadSeed
testHeadSeed
                    }
        NodeState Tx
s1 <- Environment
-> Ledger Tx
-> NodeState Tx
-> StateT (StepState Tx) IO (NodeState Tx)
-> IO (NodeState Tx)
forall (m :: * -> *) tx a.
Monad m =>
Environment
-> Ledger tx -> NodeState tx -> StateT (StepState tx) m a -> m a
runHeadLogic Environment
aliceEnv Ledger Tx
ledger NodeState Tx
st0 (StateT (StepState Tx) IO (NodeState Tx) -> IO (NodeState Tx))
-> StateT (StepState Tx) IO (NodeState Tx) -> IO (NodeState Tx)
forall a b. (a -> b) -> a -> b
$ do
          Input Tx -> StateT (StepState Tx) IO (Outcome Tx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step (Input Tx -> StateT (StepState Tx) IO (Outcome Tx))
-> Input Tx -> StateT (StepState Tx) IO (Outcome Tx)
forall a b. (a -> b) -> a -> b
$ Message Tx -> Input Tx
forall tx. Message tx -> Input tx
receiveMessage (Message Tx -> Input Tx) -> Message Tx -> Input Tx
forall a b. (a -> b) -> a -> b
$ Tx -> Message Tx
forall tx. tx -> Message tx
ReqTx Tx
tx
          StateT (StepState Tx) IO (NodeState Tx)
forall tx (m :: * -> *).
MonadState (StepState tx) m =>
m (NodeState tx)
getState
        Outcome Tx
outcome <- Environment
-> Ledger Tx
-> NodeState Tx
-> StateT (StepState Tx) IO (Outcome Tx)
-> IO (Outcome Tx)
forall (m :: * -> *) tx a.
Monad m =>
Environment
-> Ledger tx -> NodeState tx -> StateT (StepState tx) m a -> m a
runHeadLogic Environment
aliceEnv Ledger Tx
ledger NodeState Tx
s1 (StateT (StepState Tx) IO (Outcome Tx) -> IO (Outcome Tx))
-> StateT (StepState Tx) IO (Outcome Tx) -> IO (Outcome Tx)
forall a b. (a -> b) -> a -> b
$ Input Tx -> StateT (StepState Tx) IO (Outcome Tx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step (Input Tx -> StateT (StepState Tx) IO (Outcome Tx))
-> Input Tx -> StateT (StepState Tx) IO (Outcome Tx)
forall a b. (a -> b) -> a -> b
$ Message Tx -> Input Tx
forall tx. Message tx -> Input tx
receiveMessage (Message Tx -> Input Tx) -> Message Tx -> Input 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
0 SnapshotNumber
1 [Tx -> TxIdType Tx
forall tx. IsTx tx => tx -> TxIdType tx
txId Tx
tx] Maybe Tx
forall a. Maybe a
Nothing Maybe (TxIdType Tx)
Maybe TxId
forall a. Maybe a
Nothing
        case Outcome Tx
outcome of
          Continue{[StateChanged Tx]
$sel:stateChanges:Continue :: forall tx. Outcome tx -> [StateChanged tx]
stateChanges :: [StateChanged Tx]
stateChanges} ->
            case [UTxO] -> Maybe UTxO
forall a. [a] -> Maybe a
listToMaybe [UTxOType Tx
UTxO
u | SnapshotRequested{$sel:requestedSnapshot:NetworkConnected :: forall tx. StateChanged tx -> Snapshot tx
requestedSnapshot = Snapshot{$sel:utxo:Snapshot :: forall tx. Snapshot tx -> UTxOType tx
utxo = UTxOType Tx
u}} <- [StateChanged Tx]
stateChanges] of
              Maybe UTxO
Nothing -> HasCallStack => String -> IO ()
String -> IO ()
expectationFailure String
"expected a SnapshotRequested state change"
              Just UTxO
snapUtxo ->
                UTxO -> IO (Maybe ThunkInfo)
utxoNoThunks UTxO
snapUtxo IO (Maybe ThunkInfo) -> (Maybe ThunkInfo -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                  Maybe ThunkInfo
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                  Just ThunkInfo
ti -> HasCallStack => String -> IO ()
String -> IO ()
expectationFailure (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Thunk found in snapshot UTxO: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ThunkInfo -> String
forall b a. (Show a, IsString b) => a -> b
show ThunkInfo
ti
          Outcome Tx
_ -> HasCallStack => String -> IO ()
String -> IO ()
expectationFailure (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"expected Continue outcome, got: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Outcome Tx -> String
forall b a. (Show a, IsString b) => a -> b
show Outcome Tx
outcome

      String -> (UTCTime -> Property) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"on tick, picks the next active deposit in arrival when in Open state order for ReqSn" ((UTCTime -> Property) -> Spec) -> (UTCTime -> Property) -> Spec
forall a b. (a -> b) -> a -> b
$ \UTCTime
now -> PropertyM IO () -> Property
forall a. Testable a => PropertyM IO a -> Property
monadicIO (PropertyM IO () -> Property) -> PropertyM IO () -> Property
forall a b. (a -> b) -> a -> b
$ do
        let singleParty :: [Party]
singleParty = [Party
alice]
            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
            depositTime :: NominalDiffTime -> UTCTime
depositTime = UTCTime -> NominalDiffTime -> UTCTime
plusTime UTCTime
now
        let deadline :: UTCTime
deadline = NominalDiffTime -> UTCTime
depositTime NominalDiffTime
5 UTCTime -> NominalDiffTime -> UTCTime
`plusTime` DepositPeriod -> NominalDiffTime
toNominalDiffTime Environment
aliceEnv.depositPeriod UTCTime -> NominalDiffTime -> UTCTime
`plusTime` DepositPeriod -> NominalDiffTime
toNominalDiffTime Environment
aliceEnv.depositPeriod
        -- party payment keys
        (VerificationKey PaymentKey
vk, SigningKey PaymentKey
sk) <- Gen (VerificationKey PaymentKey, SigningKey PaymentKey)
-> PropertyM IO (VerificationKey PaymentKey, SigningKey PaymentKey)
forall (m :: * -> *) a. (Monad m, Show a) => Gen a -> PropertyM m a
pick Gen (VerificationKey PaymentKey, SigningKey PaymentKey)
genKeyPair
        -- helper to build deposit tx
        let mkDepositTx :: Gen (UTxO, Tx)
mkDepositTx = do
              TxOut CtxUTxO
txOut <- VerificationKey PaymentKey -> Gen (TxOut CtxUTxO)
forall ctx. VerificationKey PaymentKey -> Gen (TxOut ctx)
genOutputFor VerificationKey PaymentKey
vk
              (TxIn, TxOut CtxUTxO)
utxo <- (,TxOut CtxUTxO
txOut) (TxIn -> (TxIn, TxOut CtxUTxO))
-> Gen TxIn -> Gen (TxIn, TxOut CtxUTxO)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen TxIn
genTxIn
              (TxIn, TxOut CtxUTxO)
-> (AddressInEra, Value)
-> Secret (SigningKey PaymentKey)
-> Either TxBodyError Tx
mkSimpleTx
                (TxIn, TxOut CtxUTxO)
utxo
                (NetworkId -> VerificationKey PaymentKey -> AddressInEra
forall era.
IsShelleyBasedEra era =>
NetworkId -> VerificationKey PaymentKey -> AddressInEra era
mkVkAddress NetworkId
Fixture.testNetworkId VerificationKey PaymentKey
vk, TxOut CtxUTxO -> Value
forall ctx. TxOut ctx -> Value
txOutValue TxOut CtxUTxO
txOut)
                (SigningKey PaymentKey -> Secret (SigningKey PaymentKey)
forall a. a -> Secret a
mkSecret SigningKey PaymentKey
sk)
                Either TxBodyError Tx
-> (Either TxBodyError Tx -> Gen (UTxO, Tx)) -> Gen (UTxO, Tx)
forall a b. a -> (a -> b) -> b
& \case
                  Left TxBodyError
_ -> Text -> Gen (UTxO, Tx)
forall a t. (HasCallStack, IsText t) => t -> a
Prelude.error Text
"cannot generate deposit tx"
                  Right Tx
tx -> (UTxO, Tx) -> Gen (UTxO, Tx)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((TxIn -> TxOut CtxUTxO -> UTxO) -> (TxIn, TxOut CtxUTxO) -> UTxO
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry TxIn -> TxOut CtxUTxO -> UTxO
forall era. TxIn -> TxOut CtxUTxO era -> UTxO era
UTxO.singleton (TxIn, TxOut CtxUTxO)
utxo, Tx
tx)
        -- single party on empty Open state
        let st0 :: NodeState Tx
st0 =
              HeadState Tx -> NodeState Tx
forall tx. IsTx tx => HeadState tx -> NodeState tx
inSync (HeadState Tx -> NodeState Tx) -> HeadState Tx -> NodeState Tx
forall a b. (a -> b) -> a -> b
$
                OpenState Tx -> HeadState Tx
forall tx. OpenState tx -> HeadState tx
Open
                  OpenState
                    { $sel:parameters:OpenState :: HeadParameters
parameters = ContestationPeriod -> DepositPeriod -> [Party] -> HeadParameters
HeadParameters ContestationPeriod
defaultContestationPeriod DepositPeriod
defaultDepositPeriod [Party]
singleParty
                    , $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 = HeadId -> ConfirmedSnapshot Tx
forall tx. HeadId -> ConfirmedSnapshot tx
InitialSnapshot HeadId
testHeadId
                          , $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:chainState:OpenState :: ChainStateType Tx
chainState = ChainStateAt{$sel:spendableUTxO:ChainStateAt :: UTxO
spendableUTxO = UTxO
forall a. Monoid a => a
mempty, $sel:recordedAt:ChainStateAt :: Maybe ChainPoint
recordedAt = Maybe ChainPoint
forall a. Maybe a
Nothing}
                    , $sel:headId:OpenState :: HeadId
headId = HeadId
testHeadId
                    , $sel:headSeed:OpenState :: HeadSeed
headSeed = HeadSeed
testHeadSeed
                    }
        -- deposit txs
        (UTxO
deposited1, Tx
depositTx1) <- Gen (UTxO, Tx) -> PropertyM IO (UTxO, Tx)
forall (m :: * -> *) a. (Monad m, Show a) => Gen a -> PropertyM m a
pick Gen (UTxO, Tx)
mkDepositTx
        (UTxO
deposited2, Tx
depositTx2) <- Gen (UTxO, Tx) -> PropertyM IO (UTxO, Tx)
forall (m :: * -> *) a. (Monad m, Show a) => Gen a -> PropertyM m a
pick Gen (UTxO, Tx)
mkDepositTx
        (UTxO
deposited3, Tx
depositTx3) <- Gen (UTxO, Tx) -> PropertyM IO (UTxO, Tx)
forall (m :: * -> *) a. (Monad m, Show a) => Gen a -> PropertyM m a
pick Gen (UTxO, Tx)
mkDepositTx
        -- deposit observations
        let observeRealTxAtSlot :: SlotNo -> OnChainTx Tx -> GenT Identity (Input Tx)
observeRealTxAtSlot SlotNo
slot OnChainTx Tx
observedTx = do
              Hash BlockHeader
nextBlockHash <- Gen (Hash BlockHeader)
genBlockHeaderHash
              Input Tx -> GenT Identity (Input Tx)
forall a. a -> GenT Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                ChainInput
                  { $sel:chainEvent:ClientInput :: ChainEvent Tx
chainEvent =
                      Observation
                        { OnChainTx Tx
observedTx :: OnChainTx Tx
$sel:observedTx:Observation :: OnChainTx Tx
observedTx
                        , $sel:newChainState:Observation :: ChainStateType Tx
newChainState = ChainStateAt{$sel:spendableUTxO:ChainStateAt :: UTxO
spendableUTxO = UTxO
forall a. Monoid a => a
mempty, $sel:recordedAt:ChainStateAt :: Maybe ChainPoint
recordedAt = ChainPoint -> Maybe ChainPoint
forall a. a -> Maybe a
Just (ChainPoint -> Maybe ChainPoint) -> ChainPoint -> Maybe ChainPoint
forall a b. (a -> b) -> a -> b
$ SlotNo -> Hash BlockHeader -> ChainPoint
ChainPoint SlotNo
slot Hash BlockHeader
nextBlockHash}
                        }
                  }
            deposit1 :: OnChainTx Tx
deposit1 = OnDepositTx{$sel:headId:OnInitTx :: HeadId
headId = HeadId
testHeadId, $sel:depositTxId:OnInitTx :: TxIdType Tx
depositTxId = Tx -> TxIdType Tx
forall tx. IsTx tx => tx -> TxIdType tx
txId Tx
depositTx1, $sel:deposited:OnInitTx :: UTxOType Tx
deposited = UTxOType Tx
UTxO
deposited1, $sel:created:OnInitTx :: UTCTime
created = NominalDiffTime -> UTCTime
depositTime NominalDiffTime
1, UTCTime
$sel:deadline:OnInitTx :: UTCTime
deadline :: UTCTime
deadline}
            deposit2 :: OnChainTx Tx
deposit2 = OnDepositTx{$sel:headId:OnInitTx :: HeadId
headId = HeadId
testHeadId, $sel:depositTxId:OnInitTx :: TxIdType Tx
depositTxId = Tx -> TxIdType Tx
forall tx. IsTx tx => tx -> TxIdType tx
txId Tx
depositTx2, $sel:deposited:OnInitTx :: UTxOType Tx
deposited = UTxOType Tx
UTxO
deposited2, $sel:created:OnInitTx :: UTCTime
created = NominalDiffTime -> UTCTime
depositTime NominalDiffTime
2, UTCTime
$sel:deadline:OnInitTx :: UTCTime
deadline :: UTCTime
deadline}
            deposit3 :: OnChainTx Tx
deposit3 = OnDepositTx{$sel:headId:OnInitTx :: HeadId
headId = HeadId
testHeadId, $sel:depositTxId:OnInitTx :: TxIdType Tx
depositTxId = Tx -> TxIdType Tx
forall tx. IsTx tx => tx -> TxIdType tx
txId Tx
depositTx3, $sel:deposited:OnInitTx :: UTxOType Tx
deposited = UTxOType Tx
UTxO
deposited3, $sel:created:OnInitTx :: UTCTime
created = NominalDiffTime -> UTCTime
depositTime NominalDiffTime
3, UTCTime
$sel:deadline:OnInitTx :: UTCTime
deadline :: UTCTime
deadline}
        Input Tx
depositObservation1 <- Gen (Input Tx) -> PropertyM IO (Input Tx)
forall (m :: * -> *) a. (Monad m, Show a) => Gen a -> PropertyM m a
pick (GenT Identity (Input Tx) -> Gen (Input Tx)
forall a. Gen a -> Gen a
hedgehog (GenT Identity (Input Tx) -> Gen (Input Tx))
-> GenT Identity (Input Tx) -> Gen (Input Tx)
forall a b. (a -> b) -> a -> b
$ SlotNo -> OnChainTx Tx -> GenT Identity (Input Tx)
observeRealTxAtSlot SlotNo
1 OnChainTx Tx
deposit1)
        Input Tx
depositObservation2 <- Gen (Input Tx) -> PropertyM IO (Input Tx)
forall (m :: * -> *) a. (Monad m, Show a) => Gen a -> PropertyM m a
pick (GenT Identity (Input Tx) -> Gen (Input Tx)
forall a. Gen a -> Gen a
hedgehog (GenT Identity (Input Tx) -> Gen (Input Tx))
-> GenT Identity (Input Tx) -> Gen (Input Tx)
forall a b. (a -> b) -> a -> b
$ SlotNo -> OnChainTx Tx -> GenT Identity (Input Tx)
observeRealTxAtSlot SlotNo
2 OnChainTx Tx
deposit2)
        Input Tx
depositObservation3 <- Gen (Input Tx) -> PropertyM IO (Input Tx)
forall (m :: * -> *) a. (Monad m, Show a) => Gen a -> PropertyM m a
pick (GenT Identity (Input Tx) -> Gen (Input Tx)
forall a. Gen a -> Gen a
hedgehog (GenT Identity (Input Tx) -> Gen (Input Tx))
-> GenT Identity (Input Tx) -> Gen (Input Tx)
forall a b. (a -> b) -> a -> b
$ SlotNo -> OnChainTx Tx -> GenT Identity (Input Tx)
observeRealTxAtSlot SlotNo
3 OnChainTx Tx
deposit3)
        NodeState Tx
nodeState <-
          IO (NodeState Tx) -> PropertyM IO (NodeState Tx)
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (IO (NodeState Tx) -> PropertyM IO (NodeState Tx))
-> IO (NodeState Tx) -> PropertyM IO (NodeState Tx)
forall a b. (a -> b) -> a -> b
$
            Environment
-> Ledger Tx
-> NodeState Tx
-> StateT (StepState Tx) IO (NodeState Tx)
-> IO (NodeState Tx)
forall (m :: * -> *) tx a.
Monad m =>
Environment
-> Ledger tx -> NodeState tx -> StateT (StepState tx) m a -> m a
runHeadLogic Environment
bobEnv Ledger Tx
ledger NodeState Tx
st0 (StateT (StepState Tx) IO (NodeState Tx) -> IO (NodeState Tx))
-> StateT (StepState Tx) IO (NodeState Tx) -> IO (NodeState Tx)
forall a b. (a -> b) -> a -> b
$ do
              Input Tx -> StateT (StepState Tx) IO (Outcome Tx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step Input Tx
depositObservation1
              Input Tx -> StateT (StepState Tx) IO (Outcome Tx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step Input Tx
depositObservation2
              Input Tx -> StateT (StepState Tx) IO (Outcome Tx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step Input Tx
depositObservation3
              StateT (StepState Tx) IO (NodeState Tx)
forall tx (m :: * -> *).
MonadState (StepState tx) m =>
m (NodeState tx)
getState

        -- XXX: chainTime should be > created + depositPeriod && < deadline - depositPeriod
        -- so deposits are considered Active
        let chainTime :: UTCTime
chainTime = NominalDiffTime -> UTCTime
depositTime NominalDiffTime
4 UTCTime -> NominalDiffTime -> UTCTime
`plusTime` DepositPeriod -> NominalDiffTime
toNominalDiffTime Environment
aliceEnv.depositPeriod
        Hash BlockHeader
blockHash' <- Gen (Hash BlockHeader) -> PropertyM IO (Hash BlockHeader)
forall (m :: * -> *) a. (Monad m, Show a) => Gen a -> PropertyM m a
pick (Gen (Hash BlockHeader) -> Gen (Hash BlockHeader)
forall a. Gen a -> Gen a
hedgehog Gen (Hash BlockHeader)
genBlockHeaderHash)
        let input :: Input Tx
input = ChainEvent Tx -> Input Tx
forall tx. ChainEvent tx -> Input tx
ChainInput (ChainEvent Tx -> Input Tx) -> ChainEvent Tx -> Input Tx
forall a b. (a -> b) -> a -> b
$ Tick{UTCTime
$sel:chainTime:Observation :: UTCTime
chainTime :: UTCTime
chainTime, $sel:chainPoint:Observation :: ChainPointType Tx
chainPoint = SlotNo -> Hash BlockHeader -> ChainPoint
ChainPoint SlotNo
4 Hash BlockHeader
blockHash'}

        let outcome :: Outcome Tx
outcome = Environment
-> Ledger Tx -> UTCTime -> NodeState Tx -> Input Tx -> Outcome Tx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
aliceEnv Ledger Tx
ledger UTCTime
now NodeState Tx
nodeState Input Tx
input

        [TxId] -> (TxId -> PropertyM IO ()) -> PropertyM IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Tx -> TxIdType Tx
forall tx. IsTx tx => tx -> TxIdType tx
txId Tx
depositTx1, Tx -> TxIdType Tx
forall tx. IsTx tx => tx -> TxIdType tx
txId Tx
depositTx2, Tx -> TxIdType Tx
forall tx. IsTx tx => tx -> TxIdType tx
txId Tx
depositTx3] ((TxId -> PropertyM IO ()) -> PropertyM IO ())
-> (TxId -> PropertyM IO ()) -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ \TxId
depositId ->
          Bool -> PropertyM IO ()
forall (m :: * -> *). Monad m => Bool -> PropertyM m ()
assert (Bool -> PropertyM IO ()) -> Bool -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ case Outcome Tx
outcome of
            Wait{} -> Bool
False
            Error{} -> Bool
False
            Continue{[StateChanged Tx]
$sel:stateChanges:Continue :: forall tx. Outcome tx -> [StateChanged tx]
stateChanges :: [StateChanged Tx]
stateChanges} ->
              (StateChanged Tx -> Bool) -> [StateChanged Tx] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any
                ( \case
                    DepositActivated{TxIdType Tx
$sel:depositTxId:NetworkConnected :: forall tx. StateChanged tx -> TxIdType tx
depositTxId :: TxIdType Tx
depositTxId} -> TxIdType Tx
TxId
depositTxId TxId -> TxId -> Bool
forall a. Eq a => a -> a -> Bool
== TxId
depositId
                    StateChanged Tx
_ -> Bool
False
                )
                [StateChanged Tx]
stateChanges

        Bool -> PropertyM IO ()
forall (m :: * -> *). Monad m => Bool -> PropertyM m ()
assert (Bool -> PropertyM IO ()) -> Bool -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ case Outcome Tx
outcome of
          Wait{} -> Bool
False
          Error{} -> Bool
False
          Continue{[Effect Tx]
$sel:effects:Continue :: forall tx. Outcome tx -> [Effect tx]
effects :: [Effect Tx]
effects} ->
            (Effect Tx -> Bool) -> [Effect Tx] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any
              ( \case
                  NetworkEffect ReqSn{Maybe (TxIdType Tx)
$sel:depositTxId:ReqTx :: forall tx. Message tx -> Maybe (TxIdType tx)
depositTxId :: Maybe (TxIdType Tx)
depositTxId} -> Maybe (TxIdType Tx)
Maybe TxId
depositTxId Maybe TxId -> Maybe TxId -> Bool
forall a. Eq a => a -> a -> Bool
== TxId -> Maybe TxId
forall a. a -> Maybe a
Just (Tx -> TxIdType Tx
forall tx. IsTx tx => tx -> TxIdType tx
txId Tx
depositTx1)
                  Effect Tx
_ -> Bool
False
              )
              [Effect Tx]
effects

      String -> (SlotNo -> Property) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"any tx with expiring upper validity range gets pruned" ((SlotNo -> Property) -> Spec) -> (SlotNo -> Property) -> Spec
forall a b. (a -> b) -> a -> b
$ \SlotNo
slotNo -> PropertyM IO () -> Property
forall a. Testable a => PropertyM IO a -> Property
monadicIO (PropertyM IO () -> Property) -> PropertyM IO () -> Property
forall a b. (a -> b) -> a -> b
$ do
        ((TxIn, TxOut CtxUTxO)
utxo, Tx
expiringTransaction) <- Gen ((TxIn, TxOut CtxUTxO), Tx)
-> PropertyM IO ((TxIn, TxOut CtxUTxO), Tx)
forall (m :: * -> *) a. (Monad m, Show a) => Gen a -> PropertyM m a
pick (Gen ((TxIn, TxOut CtxUTxO), Tx)
 -> PropertyM IO ((TxIn, TxOut CtxUTxO), Tx))
-> Gen ((TxIn, TxOut CtxUTxO), Tx)
-> PropertyM IO ((TxIn, TxOut CtxUTxO), Tx)
forall a b. (a -> b) -> a -> b
$ do
          (VerificationKey PaymentKey
vk, SigningKey PaymentKey
sk) <- Gen (VerificationKey PaymentKey, SigningKey PaymentKey)
genKeyPair
          TxOut CtxUTxO
txOut <- VerificationKey PaymentKey -> Gen (TxOut CtxUTxO)
forall ctx. VerificationKey PaymentKey -> Gen (TxOut ctx)
genOutputFor VerificationKey PaymentKey
vk
          (TxIn, TxOut CtxUTxO)
utxo <- (,TxOut CtxUTxO
txOut) (TxIn -> (TxIn, TxOut CtxUTxO))
-> Gen TxIn -> Gen (TxIn, TxOut CtxUTxO)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen TxIn
genTxIn
          (TxIn, TxOut CtxUTxO)
-> (AddressInEra, Value)
-> Secret (SigningKey PaymentKey)
-> (Maybe TxValidityLowerBound, Maybe TxValidityUpperBound)
-> Either TxBodyError Tx
mkRangedTx
            (TxIn, TxOut CtxUTxO)
utxo
            (NetworkId -> VerificationKey PaymentKey -> AddressInEra
forall era.
IsShelleyBasedEra era =>
NetworkId -> VerificationKey PaymentKey -> AddressInEra era
mkVkAddress NetworkId
Fixture.testNetworkId VerificationKey PaymentKey
vk, TxOut CtxUTxO -> Value
forall ctx. TxOut ctx -> Value
txOutValue TxOut CtxUTxO
txOut)
            (SigningKey PaymentKey -> Secret (SigningKey PaymentKey)
forall a. a -> Secret a
mkSecret SigningKey PaymentKey
sk)
            (Maybe TxValidityLowerBound
forall a. Maybe a
Nothing, TxValidityUpperBound -> Maybe TxValidityUpperBound
forall a. a -> Maybe a
Just (TxValidityUpperBound -> Maybe TxValidityUpperBound)
-> TxValidityUpperBound -> Maybe TxValidityUpperBound
forall a b. (a -> b) -> a -> b
$ SlotNo -> TxValidityUpperBound
TxValidityUpperBound SlotNo
slotNo)
            Either TxBodyError Tx
-> (Either TxBodyError Tx -> Gen ((TxIn, TxOut CtxUTxO), Tx))
-> Gen ((TxIn, TxOut CtxUTxO), Tx)
forall a b. a -> (a -> b) -> b
& \case
              Left TxBodyError
_ -> Text -> Gen ((TxIn, TxOut CtxUTxO), Tx)
forall a t. (HasCallStack, IsText t) => t -> a
Prelude.error Text
"cannot generate expired tx"
              Right Tx
tx -> ((TxIn, TxOut CtxUTxO), Tx) -> Gen ((TxIn, TxOut CtxUTxO), Tx)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((TxIn, TxOut CtxUTxO)
utxo, Tx
tx)
        UTCTime
chainTime <- IO UTCTime -> PropertyM IO UTCTime
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run IO UTCTime
forall (m :: * -> *). MonadTime m => m UTCTime
getCurrentTime
        let st0 :: NodeState Tx
st0 =
              NodeInSync
                { $sel:headState:NodeInSync :: HeadState Tx
headState =
                    OpenState Tx -> HeadState Tx
forall tx. OpenState tx -> HeadState tx
Open
                      OpenState
                        { $sel:parameters:OpenState :: HeadParameters
parameters = ContestationPeriod -> DepositPeriod -> [Party] -> HeadParameters
HeadParameters ContestationPeriod
defaultContestationPeriod DepositPeriod
defaultDepositPeriod [Party]
threeParties
                        , $sel:coordinatedHeadState:OpenState :: CoordinatedHeadState Tx
coordinatedHeadState =
                            CoordinatedHeadState
                              { $sel:localUTxO:CoordinatedHeadState :: UTxOType Tx
localUTxO = (TxIn -> TxOut CtxUTxO -> UTxO) -> (TxIn, TxOut CtxUTxO) -> UTxO
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry TxIn -> TxOut CtxUTxO -> UTxO
forall era. TxIn -> TxOut CtxUTxO era -> UTxO era
UTxO.singleton (TxIn, TxOut CtxUTxO)
utxo
                              , $sel:allTxs:CoordinatedHeadState :: Map (TxIdType Tx) Tx
allTxs = Map (TxIdType Tx) Tx
Map TxId Tx
forall a. Monoid a => a
mempty
                              , $sel:localTxs:CoordinatedHeadState :: Seq Tx
localTxs = Tx -> Seq Tx
forall a. a -> Seq a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Tx
expiringTransaction
                              , $sel:confirmedSnapshot:CoordinatedHeadState :: ConfirmedSnapshot Tx
confirmedSnapshot = HeadId -> ConfirmedSnapshot Tx
forall tx. HeadId -> ConfirmedSnapshot tx
InitialSnapshot HeadId
testHeadId
                              , $sel:seenSnapshot:CoordinatedHeadState :: SeenSnapshot Tx
seenSnapshot = SeenSnapshot Tx
forall tx. SeenSnapshot tx
NoSeenSnapshot
                              , $sel:currentDepositTxId:CoordinatedHeadState :: Maybe (TxIdType Tx)
currentDepositTxId = Maybe (TxIdType Tx)
Maybe TxId
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:chainState:OpenState :: ChainStateType Tx
chainState = ChainStateAt{$sel:spendableUTxO:ChainStateAt :: UTxO
spendableUTxO = UTxO
forall a. Monoid a => a
mempty, $sel:recordedAt:ChainStateAt :: Maybe ChainPoint
recordedAt = Maybe ChainPoint
forall a. Maybe a
Nothing}
                        , $sel:headId:OpenState :: HeadId
headId = HeadId
testHeadId
                        , $sel:headSeed:OpenState :: HeadSeed
headSeed = HeadSeed
testHeadSeed
                        }
                , $sel:pendingDeposits:NodeInSync :: PendingDeposits Tx
pendingDeposits = PendingDeposits Tx
Map TxId (Deposit Tx)
forall a. Monoid a => a
mempty
                , $sel:chainPointTime:NodeInSync :: ChainPointTime
chainPointTime =
                    ChainPointTime
                      { $sel:currentSlot:ChainPointTime :: ChainSlot
currentSlot = Natural -> ChainSlot
ChainSlot (Natural -> ChainSlot)
-> (SlotNo -> Natural) -> SlotNo -> ChainSlot
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Natural) -> (SlotNo -> Word64) -> SlotNo -> Natural
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SlotNo -> Word64
unSlotNo (SlotNo -> ChainSlot) -> SlotNo -> ChainSlot
forall a b. (a -> b) -> a -> b
$ SlotNo
slotNo SlotNo -> SlotNo -> SlotNo
forall a. Num a => a -> a -> a
+ SlotNo
1
                      , $sel:currentChainTime:ChainPointTime :: UTCTime
currentChainTime = UTCTime
chainTime
                      , $sel:drift:ChainPointTime :: NominalDiffTime
drift = NominalDiffTime
0
                      }
                }

        NodeState Tx
st <-
          IO (NodeState Tx) -> PropertyM IO (NodeState Tx)
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (IO (NodeState Tx) -> PropertyM IO (NodeState Tx))
-> IO (NodeState Tx) -> PropertyM IO (NodeState Tx)
forall a b. (a -> b) -> a -> b
$
            Environment
-> Ledger Tx
-> NodeState Tx
-> StateT (StepState Tx) IO (NodeState Tx)
-> IO (NodeState Tx)
forall (m :: * -> *) tx a.
Monad m =>
Environment
-> Ledger tx -> NodeState tx -> StateT (StepState tx) m a -> m a
runHeadLogic Environment
bobEnv Ledger Tx
ledger NodeState Tx
st0 (StateT (StepState Tx) IO (NodeState Tx) -> IO (NodeState Tx))
-> StateT (StepState Tx) IO (NodeState Tx) -> IO (NodeState Tx)
forall a b. (a -> b) -> a -> b
$ do
              Input Tx -> StateT (StepState Tx) IO (Outcome Tx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step (Message Tx -> Input Tx
forall tx. Message tx -> Input tx
receiveMessage (Message Tx -> Input Tx) -> Message Tx -> Input 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
0 SnapshotNumber
1 [] Maybe Tx
forall a. Maybe a
Nothing Maybe (TxIdType Tx)
forall a. Maybe a
Nothing)
              StateT (StepState Tx) IO (NodeState Tx)
forall tx (m :: * -> *).
MonadState (StepState tx) m =>
m (NodeState tx)
getState

        Bool -> PropertyM IO ()
forall (m :: * -> *). Monad m => Bool -> PropertyM m ()
assert (Bool -> PropertyM IO ()) -> Bool -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ case NodeState Tx -> HeadState Tx
forall tx. NodeState tx -> HeadState tx
headState NodeState Tx
st of
          Open
            OpenState
              { $sel:coordinatedHeadState:OpenState :: forall tx. OpenState tx -> CoordinatedHeadState tx
coordinatedHeadState =
                CoordinatedHeadState{Seq Tx
$sel:localTxs:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> Seq tx
localTxs :: Seq Tx
localTxs}
              } -> Seq Tx -> Bool
forall a. Seq a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Seq Tx
localTxs
          HeadState Tx
_ -> Bool
False

    String -> (Tx -> IO ()) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"empty inputs in decommit tx are prevented" ((Tx -> IO ()) -> Spec) -> (Tx -> IO ()) -> Spec
forall a b. (a -> b) -> a -> b
$ \Tx
tx -> do
      UTCTime
chainTime <- IO UTCTime
forall (m :: * -> *). MonadTime m => m UTCTime
getCurrentTime
      let ledger :: Ledger Tx
ledger = Globals -> LedgerEnv LedgerEra -> Ledger Tx
cardanoLedger Globals
Fixture.defaultGlobals LedgerEnv LedgerEra
Fixture.defaultLedgerEnv
      let st :: NodeState Tx
st =
            NodeInSync
              { $sel:headState:NodeInSync :: HeadState Tx
headState =
                  OpenState Tx -> HeadState Tx
forall tx. OpenState tx -> HeadState tx
Open
                    OpenState
                      { $sel:parameters:OpenState :: HeadParameters
parameters = ContestationPeriod -> DepositPeriod -> [Party] -> HeadParameters
HeadParameters ContestationPeriod
defaultContestationPeriod DepositPeriod
defaultDepositPeriod [Party]
threeParties
                      , $sel:coordinatedHeadState:OpenState :: CoordinatedHeadState Tx
coordinatedHeadState =
                          CoordinatedHeadState
                            { $sel:localUTxO:CoordinatedHeadState :: UTxOType Tx
localUTxO = UTxOType Tx
UTxO
forall a. Monoid a => a
mempty
                            , $sel:allTxs:CoordinatedHeadState :: Map (TxIdType Tx) Tx
allTxs = Map (TxIdType Tx) Tx
Map TxId 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 = HeadId -> ConfirmedSnapshot Tx
forall tx. HeadId -> ConfirmedSnapshot tx
InitialSnapshot HeadId
testHeadId
                            , $sel:seenSnapshot:CoordinatedHeadState :: SeenSnapshot Tx
seenSnapshot = SeenSnapshot Tx
forall tx. SeenSnapshot tx
NoSeenSnapshot
                            , $sel:currentDepositTxId:CoordinatedHeadState :: Maybe (TxIdType Tx)
currentDepositTxId = Maybe (TxIdType Tx)
Maybe TxId
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:chainState:OpenState :: ChainStateType Tx
chainState = ChainStateAt{$sel:spendableUTxO:ChainStateAt :: UTxO
spendableUTxO = UTxO
forall a. Monoid a => a
mempty, $sel:recordedAt:ChainStateAt :: Maybe ChainPoint
recordedAt = Maybe ChainPoint
forall a. Maybe a
Nothing}
                      , $sel:headId:OpenState :: HeadId
headId = HeadId
testHeadId
                      , $sel:headSeed:OpenState :: HeadSeed
headSeed = HeadSeed
testHeadSeed
                      }
              , $sel:pendingDeposits:NodeInSync :: PendingDeposits Tx
pendingDeposits = PendingDeposits Tx
Map TxId (Deposit Tx)
forall a. Monoid a => a
mempty
              , $sel:chainPointTime:NodeInSync :: ChainPointTime
chainPointTime =
                  ChainPointTime
                    { $sel:currentSlot:ChainPointTime :: ChainSlot
currentSlot = Natural -> ChainSlot
ChainSlot Natural
1
                    , $sel:currentChainTime:ChainPointTime :: UTCTime
currentChainTime = UTCTime
chainTime
                    , $sel:drift:ChainPointTime :: NominalDiffTime
drift = NominalDiffTime
0
                    }
              }

      let tx' :: Tx
tx' = Tx TopTx LedgerEra -> Tx
forall era.
IsShelleyBasedEra era =>
Tx TopTx (ShelleyLedgerEra era) -> Tx era
fromLedgerTx (Tx -> Tx TopTx LedgerEra
forall era. Tx era -> Tx TopTx (ShelleyLedgerEra era)
toLedgerTx Tx
tx Tx TopTx ConwayEra
-> (Tx TopTx ConwayEra -> Tx TopTx ConwayEra) -> Tx TopTx ConwayEra
forall a b. a -> (a -> b) -> b
& (TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
-> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l ConwayEra) (TxBody l ConwayEra)
bodyTxL ((TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
 -> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra))
-> ((Set TxIn -> Identity (Set TxIn))
    -> TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
-> (Set TxIn -> Identity (Set TxIn))
-> Tx TopTx ConwayEra
-> Identity (Tx TopTx ConwayEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set TxIn -> Identity (Set TxIn))
-> TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (Set TxIn)
forall (l :: TxLevel). Lens' (TxBody l ConwayEra) (Set TxIn)
inputsTxBodyL ((Set TxIn -> Identity (Set TxIn))
 -> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra))
-> Set TxIn -> Tx TopTx ConwayEra -> Tx TopTx ConwayEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Set TxIn
forall a. Monoid a => a
mempty)
      let input :: Input Tx
input = Message Tx -> Input Tx
forall tx. Message tx -> Input tx
receiveMessage (Message Tx -> Input Tx) -> Message Tx -> Input Tx
forall a b. (a -> b) -> a -> b
$ ReqDec{$sel:transaction:ReqTx :: Tx
transaction = Tx
tx'}
      UTCTime
now <- ChainSlot -> IO UTCTime
forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot NodeState Tx
st.chainPointTime.currentSlot
      Environment
-> Ledger Tx -> UTCTime -> NodeState Tx -> Input Tx -> Outcome Tx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger Tx
ledger UTCTime
now NodeState Tx
st Input Tx
input Outcome Tx -> (Outcome Tx -> Bool) -> IO ()
forall a. (HasCallStack, Show a) => a -> (a -> Bool) -> IO ()
`shouldSatisfy` \case
        Wait WaitOnNotApplicableDecommitTx{$sel:notApplicableReason:WaitOnNotApplicableTx :: forall tx. WaitReason tx -> DecommitInvalidReason tx
notApplicableReason = DecommitTxInvalid{}} [StateChanged Tx]
_ -> Bool
True
        Outcome Tx
_ -> Bool
False

-- * Properties

prop_ignoresUnrelatedOnInitTx :: Property
prop_ignoresUnrelatedOnInitTx :: Property
prop_ignoresUnrelatedOnInitTx =
  Gen Environment -> (Environment -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen Environment
forall a. Arbitrary a => Gen a
arbitrary ((Environment -> Property) -> Property)
-> (Environment -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \Environment
env ->
    Gen (OnChainTx SimpleTx)
-> (OnChainTx SimpleTx -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll (Environment -> Gen (OnChainTx SimpleTx)
forall tx. Environment -> Gen (OnChainTx tx)
genUnrelatedInit Environment
env) ((OnChainTx SimpleTx -> Property) -> Property)
-> (OnChainTx SimpleTx -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \OnChainTx SimpleTx
unrelatedInit -> PropertyM IO () -> Property
forall a. Testable a => PropertyM IO a -> Property
monadicIO (PropertyM IO () -> Property) -> PropertyM IO () -> Property
forall a b. (a -> b) -> a -> b
$ do
      let idleSt :: NodeState SimpleTx
idleSt = NodeState SimpleTx
inIdleState
      UTCTime
now <- IO UTCTime -> PropertyM IO UTCTime
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run IO UTCTime
forall (m :: * -> *). MonadTime m => m UTCTime
getCurrentTime
      let outcome :: Outcome SimpleTx
outcome = Environment
-> Ledger SimpleTx
-> UTCTime
-> NodeState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
update Environment
env Ledger SimpleTx
simpleLedger UTCTime
now NodeState SimpleTx
idleSt (OnChainTx SimpleTx -> Input SimpleTx
observeTx OnChainTx SimpleTx
unrelatedInit)
      (Property -> Property) -> PropertyM IO ()
forall (m :: * -> *).
Monad m =>
(Property -> Property) -> PropertyM m ()
monitor ((Property -> Property) -> PropertyM IO ())
-> (Property -> Property) -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Outcome: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Outcome SimpleTx -> String
forall b a. (Show a, IsString b) => a -> b
show Outcome SimpleTx
outcome)
      IO () -> PropertyM IO ()
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (IO () -> PropertyM IO ()) -> IO () -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$
        Outcome SimpleTx
outcome Outcome SimpleTx -> (StateChanged SimpleTx -> Bool) -> IO ()
forall tx.
(HasCallStack, IsChainState tx) =>
Outcome tx -> (StateChanged tx -> Bool) -> IO ()
`hasStateChangedSatisfying` \case
          IgnoredHeadInitializing{} -> Bool
True
          StateChanged SimpleTx
_ -> Bool
False
 where
  genUnrelatedInit :: Environment -> Gen (OnChainTx tx)
  genUnrelatedInit :: forall tx. Environment -> Gen (OnChainTx tx)
genUnrelatedInit Environment
env =
    [Gen (OnChainTx tx)] -> Gen (OnChainTx tx)
forall a. HasCallStack => [Gen a] -> Gen a
oneof
      [ Environment -> Gen (OnChainTx tx)
forall tx. Environment -> Gen (OnChainTx tx)
genOnInitWithDifferentContestationPeriod Environment
env
      , Environment -> Gen (OnChainTx tx)
forall tx. Environment -> Gen (OnChainTx tx)
genOnInitWithDifferentDepositPeriod Environment
env
      , Environment -> Gen (OnChainTx tx)
forall tx. Environment -> Gen (OnChainTx tx)
genOnInitWithoutParty Environment
env
      , Environment -> Gen (OnChainTx tx)
forall tx. Environment -> Gen (OnChainTx tx)
genOnInitWithoutOnChainId Environment
env
      ]

  genOnInitWithDifferentContestationPeriod :: Environment -> Gen (OnChainTx tx)
  genOnInitWithDifferentContestationPeriod :: forall tx. Environment -> Gen (OnChainTx tx)
genOnInitWithDifferentContestationPeriod Environment{Party
$sel:party:Environment :: Environment -> Party
party :: Party
party, ContestationPeriod
$sel:contestationPeriod:Environment :: Environment -> ContestationPeriod
contestationPeriod :: ContestationPeriod
contestationPeriod, DepositPeriod
$sel:depositPeriod:Environment :: Environment -> DepositPeriod
depositPeriod :: DepositPeriod
depositPeriod, [OnChainId]
$sel:participants:Environment :: Environment -> [OnChainId]
participants :: [OnChainId]
participants} = do
    HeadId
headId <- Gen HeadId
forall a. Arbitrary a => Gen a
arbitrary
    HeadSeed
headSeed <- Gen HeadSeed
forall a. Arbitrary a => Gen a
arbitrary
    ContestationPeriod
cp <- Gen ContestationPeriod
forall a. Arbitrary a => Gen a
arbitrary Gen ContestationPeriod
-> (ContestationPeriod -> Bool) -> Gen ContestationPeriod
forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` (ContestationPeriod -> ContestationPeriod -> Bool
forall a. Eq a => a -> a -> Bool
/= ContestationPeriod
contestationPeriod)
    [Party]
parties <- [Party] -> Gen [Party]
forall a. [a] -> Gen [a]
shuffle ([Party] -> Gen [Party]) -> Gen [Party] -> Gen [Party]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Gen [Party]
forall a. Arbitrary a => Gen a
arbitrary Gen [Party] -> ([Party] -> [Party]) -> Gen [Party]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Party
party :))
    OnChainTx tx -> Gen (OnChainTx tx)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      OnInitTx
        { HeadId
$sel:headId:OnInitTx :: HeadId
headId :: HeadId
headId
        , HeadSeed
headSeed :: HeadSeed
$sel:headSeed:OnInitTx :: HeadSeed
headSeed
        , $sel:headParameters:OnInitTx :: HeadParameters
headParameters = HeadParameters{$sel:contestationPeriod:HeadParameters :: ContestationPeriod
contestationPeriod = ContestationPeriod
cp, DepositPeriod
depositPeriod :: DepositPeriod
$sel:depositPeriod:HeadParameters :: DepositPeriod
depositPeriod, [Party]
parties :: [Party]
$sel:parties:HeadParameters :: [Party]
parties}
        , [OnChainId]
participants :: [OnChainId]
$sel:participants:OnInitTx :: [OnChainId]
participants
        }

  genOnInitWithDifferentDepositPeriod :: Environment -> Gen (OnChainTx tx)
  genOnInitWithDifferentDepositPeriod :: forall tx. Environment -> Gen (OnChainTx tx)
genOnInitWithDifferentDepositPeriod Environment{Party
$sel:party:Environment :: Environment -> Party
party :: Party
party, ContestationPeriod
$sel:contestationPeriod:Environment :: Environment -> ContestationPeriod
contestationPeriod :: ContestationPeriod
contestationPeriod, DepositPeriod
$sel:depositPeriod:Environment :: Environment -> DepositPeriod
depositPeriod :: DepositPeriod
depositPeriod, [OnChainId]
$sel:participants:Environment :: Environment -> [OnChainId]
participants :: [OnChainId]
participants} = do
    HeadId
headId <- Gen HeadId
forall a. Arbitrary a => Gen a
arbitrary
    HeadSeed
headSeed <- Gen HeadSeed
forall a. Arbitrary a => Gen a
arbitrary
    DepositPeriod
dp <- Gen DepositPeriod
forall a. Arbitrary a => Gen a
arbitrary Gen DepositPeriod -> (DepositPeriod -> Bool) -> Gen DepositPeriod
forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` (DepositPeriod -> DepositPeriod -> Bool
forall a. Eq a => a -> a -> Bool
/= DepositPeriod
depositPeriod)
    [Party]
parties <- [Party] -> Gen [Party]
forall a. [a] -> Gen [a]
shuffle ([Party] -> Gen [Party]) -> Gen [Party] -> Gen [Party]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Gen [Party]
forall a. Arbitrary a => Gen a
arbitrary Gen [Party] -> ([Party] -> [Party]) -> Gen [Party]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Party
party :))
    OnChainTx tx -> Gen (OnChainTx tx)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      OnInitTx
        { HeadId
$sel:headId:OnInitTx :: HeadId
headId :: HeadId
headId
        , HeadSeed
$sel:headSeed:OnInitTx :: HeadSeed
headSeed :: HeadSeed
headSeed
        , $sel:headParameters:OnInitTx :: HeadParameters
headParameters = HeadParameters{ContestationPeriod
$sel:contestationPeriod:HeadParameters :: ContestationPeriod
contestationPeriod :: ContestationPeriod
contestationPeriod, $sel:depositPeriod:HeadParameters :: DepositPeriod
depositPeriod = DepositPeriod
dp, [Party]
$sel:parties:HeadParameters :: [Party]
parties :: [Party]
parties}
        , [OnChainId]
$sel:participants:OnInitTx :: [OnChainId]
participants :: [OnChainId]
participants
        }

  genOnInitWithoutParty :: Environment -> Gen (OnChainTx tx)
  genOnInitWithoutParty :: forall tx. Environment -> Gen (OnChainTx tx)
genOnInitWithoutParty Environment{Party
$sel:party:Environment :: Environment -> Party
party :: Party
party, [Party]
$sel:otherParties:Environment :: Environment -> [Party]
otherParties :: [Party]
otherParties, ContestationPeriod
$sel:contestationPeriod:Environment :: Environment -> ContestationPeriod
contestationPeriod :: ContestationPeriod
contestationPeriod, DepositPeriod
$sel:depositPeriod:Environment :: Environment -> DepositPeriod
depositPeriod :: DepositPeriod
depositPeriod, [OnChainId]
$sel:participants:Environment :: Environment -> [OnChainId]
participants :: [OnChainId]
participants} = do
    HeadId
headId <- Gen HeadId
forall a. Arbitrary a => Gen a
arbitrary
    HeadSeed
headSeed <- Gen HeadSeed
forall a. Arbitrary a => Gen a
arbitrary
    [Party]
allParties <- [Party] -> Gen [Party]
forall a. [a] -> Gen [a]
shuffle (Party
party Party -> [Party] -> [Party]
forall a. a -> [a] -> [a]
: [Party]
otherParties)
    Party
toRemove <- [Party] -> Gen Party
forall a. HasCallStack => [a] -> Gen a
elements [Party]
allParties
    let differentParties :: [Party]
differentParties = Party -> [Party] -> [Party]
forall a. Eq a => a -> [a] -> [a]
List.delete Party
toRemove [Party]
allParties
    OnChainTx tx -> Gen (OnChainTx tx)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      OnInitTx
        { HeadId
$sel:headId:OnInitTx :: HeadId
headId :: HeadId
headId
        , HeadSeed
$sel:headSeed:OnInitTx :: HeadSeed
headSeed :: HeadSeed
headSeed
        , $sel:headParameters:OnInitTx :: HeadParameters
headParameters = HeadParameters{ContestationPeriod
$sel:contestationPeriod:HeadParameters :: ContestationPeriod
contestationPeriod :: ContestationPeriod
contestationPeriod, DepositPeriod
$sel:depositPeriod:HeadParameters :: DepositPeriod
depositPeriod :: DepositPeriod
depositPeriod, $sel:parties:HeadParameters :: [Party]
parties = [Party]
differentParties}
        , [OnChainId]
$sel:participants:OnInitTx :: [OnChainId]
participants :: [OnChainId]
participants
        }

  genOnInitWithoutOnChainId :: Environment -> Gen (OnChainTx tx)
  genOnInitWithoutOnChainId :: forall tx. Environment -> Gen (OnChainTx tx)
genOnInitWithoutOnChainId Environment{Party
$sel:party:Environment :: Environment -> Party
party :: Party
party, [Party]
$sel:otherParties:Environment :: Environment -> [Party]
otherParties :: [Party]
otherParties, ContestationPeriod
$sel:contestationPeriod:Environment :: Environment -> ContestationPeriod
contestationPeriod :: ContestationPeriod
contestationPeriod, DepositPeriod
$sel:depositPeriod:Environment :: Environment -> DepositPeriod
depositPeriod :: DepositPeriod
depositPeriod, [OnChainId]
$sel:participants:Environment :: Environment -> [OnChainId]
participants :: [OnChainId]
participants} = do
    HeadId
headId <- Gen HeadId
forall a. Arbitrary a => Gen a
arbitrary
    HeadSeed
headSeed <- Gen HeadSeed
forall a. Arbitrary a => Gen a
arbitrary
    [OnChainId]
differentParticipants <- case [OnChainId]
participants of
      [] -> (OnChainId -> [OnChainId] -> [OnChainId]
forall a. a -> [a] -> [a]
: []) (OnChainId -> [OnChainId]) -> Gen OnChainId -> Gen [OnChainId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen OnChainId
forall a. Arbitrary a => Gen a
arbitrary
      [OnChainId]
ps -> do
        OnChainId
toRemove <- [OnChainId] -> Gen OnChainId
forall a. HasCallStack => [a] -> Gen a
elements [OnChainId]
participants
        [OnChainId] -> Gen [OnChainId]
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([OnChainId] -> Gen [OnChainId]) -> [OnChainId] -> Gen [OnChainId]
forall a b. (a -> b) -> a -> b
$ OnChainId -> [OnChainId] -> [OnChainId]
forall a. Eq a => a -> [a] -> [a]
List.delete OnChainId
toRemove [OnChainId]
ps
    OnChainTx tx -> Gen (OnChainTx tx)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      OnInitTx
        { HeadId
$sel:headId:OnInitTx :: HeadId
headId :: HeadId
headId
        , HeadSeed
$sel:headSeed:OnInitTx :: HeadSeed
headSeed :: HeadSeed
headSeed
        , $sel:headParameters:OnInitTx :: HeadParameters
headParameters = HeadParameters{ContestationPeriod
$sel:contestationPeriod:HeadParameters :: ContestationPeriod
contestationPeriod :: ContestationPeriod
contestationPeriod, DepositPeriod
$sel:depositPeriod:HeadParameters :: DepositPeriod
depositPeriod :: DepositPeriod
depositPeriod, $sel:parties:HeadParameters :: [Party]
parties = Party
party Party -> [Party] -> [Party]
forall a. a -> [a] -> [a]
: [Party]
otherParties}
        , $sel:participants:OnInitTx :: [OnChainId]
participants = [OnChainId]
differentParticipants
        }

genClosedState :: Gen (NodeState SimpleTx)
genClosedState :: Gen (NodeState SimpleTx)
genClosedState = do
  ClosedState SimpleTx
closedState <- Gen (ClosedState SimpleTx)
forall a. Arbitrary a => Gen a
arbitrary
  NodeState SimpleTx -> Gen (NodeState SimpleTx)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NodeState SimpleTx -> Gen (NodeState SimpleTx))
-> NodeState SimpleTx -> Gen (NodeState SimpleTx)
forall a b. (a -> b) -> a -> b
$ HeadState SimpleTx -> NodeState SimpleTx
forall tx. IsTx tx => HeadState tx -> NodeState tx
inSync (ClosedState SimpleTx -> HeadState SimpleTx
forall tx. ClosedState tx -> HeadState tx
Closed (ClosedState SimpleTx -> HeadState SimpleTx)
-> ClosedState SimpleTx -> HeadState SimpleTx
forall a b. (a -> b) -> a -> b
$ ClosedState SimpleTx
closedState{headId = testHeadId})

-- * Utilities

-- | Create a network input about a received protocol message with default ttl
-- and 'alice' as the sender.
receiveMessage :: Message tx -> Input tx
receiveMessage :: forall tx. Message tx -> Input tx
receiveMessage = Party -> Message tx -> Input tx
forall tx. Party -> Message tx -> Input tx
receiveMessageFrom Party
alice

-- | Create a network input about a received protocol message with default ttl
-- from given sender.
receiveMessageFrom :: Party -> Message tx -> Input tx
receiveMessageFrom :: forall tx. Party -> Message tx -> Input tx
receiveMessageFrom = Party -> Message tx -> Input tx
forall tx. Party -> Message tx -> Input tx
mkNetworkInput

-- | Create a chain effect with fixed chain state and slot.
chainEffect :: PostChainTx SimpleTx -> Effect SimpleTx
chainEffect :: PostChainTx SimpleTx -> Effect SimpleTx
chainEffect PostChainTx SimpleTx
postChainTx =
  OnChainEffect
    { PostChainTx SimpleTx
$sel:postChainTx:ClientEffect :: PostChainTx SimpleTx
postChainTx :: PostChainTx SimpleTx
postChainTx
    }

-- | Create an observation chain input with chain state at given slot.
observeTxAtSlot :: ChainSlot -> OnChainTx SimpleTx -> Input SimpleTx
observeTxAtSlot :: ChainSlot -> OnChainTx SimpleTx -> Input SimpleTx
observeTxAtSlot ChainSlot
slot OnChainTx SimpleTx
observedTx =
  ChainInput
    { $sel:chainEvent:ClientInput :: ChainEvent SimpleTx
chainEvent =
        Observation
          { OnChainTx SimpleTx
$sel:observedTx:Observation :: OnChainTx SimpleTx
observedTx :: OnChainTx SimpleTx
observedTx
          , $sel:newChainState:Observation :: ChainStateType SimpleTx
newChainState = SimpleChainState{ChainSlot
$sel:slot:SimpleChainState :: ChainSlot
slot :: ChainSlot
slot}
          }
    }

-- | Create an observation chain input with fixed chain state and slot.
observeTx :: OnChainTx SimpleTx -> Input SimpleTx
observeTx :: OnChainTx SimpleTx -> Input SimpleTx
observeTx = ChainSlot -> OnChainTx SimpleTx -> Input SimpleTx
observeTxAtSlot ChainSlot
0

connectivityChanged :: TTL -> Connectivity -> Input SimpleTx
connectivityChanged :: Natural -> Connectivity -> Input SimpleTx
connectivityChanged Natural
ttl Connectivity
connectivityMessage =
  NetworkInput
    { Natural
ttl :: Natural
$sel:ttl:ClientInput :: Natural
ttl
    , $sel:networkEvent:ClientInput :: NetworkEvent (Message SimpleTx)
networkEvent = Connectivity -> NetworkEvent (Message SimpleTx)
forall msg. Connectivity -> NetworkEvent msg
ConnectivityEvent Connectivity
connectivityMessage
    }

inIdleState :: NodeState SimpleTx
inIdleState :: NodeState SimpleTx
inIdleState = ChainStateType SimpleTx -> NodeState SimpleTx
forall tx. IsChainState tx => ChainStateType tx -> NodeState tx
initNodeState ChainStateType SimpleTx
SimpleChainState
0

inUnsyncedIdleState :: NodeState SimpleTx
inUnsyncedIdleState :: NodeState SimpleTx
inUnsyncedIdleState = HeadState SimpleTx -> NodeState SimpleTx
forall tx. IsTx tx => HeadState tx -> NodeState tx
catchingUp (IdleState SimpleTx -> HeadState SimpleTx
forall tx. IdleState tx -> HeadState tx
Idle IdleState{$sel:chainState:IdleState :: ChainStateType SimpleTx
chainState = ChainStateType SimpleTx
SimpleChainState
0})

-- XXX: This is always called with threeParties and simpleLedger
inOpenState ::
  [Party] ->
  NodeState SimpleTx
inOpenState :: [Party] -> NodeState SimpleTx
inOpenState [Party]
parties =
  [Party] -> CoordinatedHeadState SimpleTx -> NodeState SimpleTx
inOpenState' [Party]
parties (CoordinatedHeadState SimpleTx -> NodeState SimpleTx)
-> CoordinatedHeadState SimpleTx -> NodeState SimpleTx
forall a b. (a -> b) -> a -> b
$
    CoordinatedHeadState
      { $sel:localUTxO:CoordinatedHeadState :: UTxOType SimpleTx
localUTxO = Set SimpleTxOut
UTxOType SimpleTx
u0
      , $sel:allTxs:CoordinatedHeadState :: Map (TxIdType SimpleTx) SimpleTx
allTxs = Map SimpleId SimpleTx
Map (TxIdType SimpleTx) SimpleTx
forall a. Monoid a => a
mempty
      , $sel:localTxs:CoordinatedHeadState :: Seq SimpleTx
localTxs = Seq SimpleTx
forall a. Monoid a => a
mempty
      , ConfirmedSnapshot SimpleTx
$sel:confirmedSnapshot:CoordinatedHeadState :: ConfirmedSnapshot SimpleTx
confirmedSnapshot :: ConfirmedSnapshot SimpleTx
confirmedSnapshot
      , $sel:seenSnapshot:CoordinatedHeadState :: SeenSnapshot SimpleTx
seenSnapshot = SeenSnapshot SimpleTx
forall tx. SeenSnapshot tx
NoSeenSnapshot
      , $sel:currentDepositTxId:CoordinatedHeadState :: Maybe (TxIdType SimpleTx)
currentDepositTxId = Maybe SimpleId
Maybe (TxIdType SimpleTx)
forall a. Maybe a
Nothing
      , $sel:decommitTx:CoordinatedHeadState :: Maybe SimpleTx
decommitTx = Maybe SimpleTx
forall a. Maybe a
Nothing
      , $sel:version:CoordinatedHeadState :: SnapshotVersion
version = SnapshotVersion
0
      }
 where
  u0 :: Set SimpleTxOut
u0 = Set SimpleTxOut
forall a. Monoid a => a
mempty
  confirmedSnapshot :: ConfirmedSnapshot SimpleTx
confirmedSnapshot = forall tx. HeadId -> ConfirmedSnapshot tx
InitialSnapshot @SimpleTx HeadId
testHeadId

-- | The decommit the reqDec pending-commit tests request. No inputs, so it applies to any
-- 'localUTxO' and the outcome turns purely on the pending-commit guard.
reqDecDecommitTx :: SimpleTx
reqDecDecommitTx :: SimpleTx
reqDecDecommitTx = SimpleId -> UTxOType SimpleTx -> UTxOType SimpleTx -> SimpleTx
SimpleTx SimpleId
1 Set SimpleTxOut
UTxOType SimpleTx
forall a. Monoid a => a
mempty (SimpleId -> UTxOType SimpleTx
utxoRef SimpleId
1)

reqDecDepositTxId :: TxIdType SimpleTx
reqDecDepositTxId :: TxIdType SimpleTx
reqDecDepositTxId = SimpleId
TxIdType SimpleTx
7

-- | The UTxO the registered deposit records, so the tests can assert the reported 'commitUTxO'
-- instead of the @mempty@ that a failed lookup would yield whether or not the guard is right.
reqDecDepositedUTxO :: UTxOType SimpleTx
reqDecDepositedUTxO :: UTxOType SimpleTx
reqDecDepositedUTxO = SimpleId -> UTxOType SimpleTx
utxoRef SimpleId
42

-- | An open state whose 'currentDepositTxId' is set, with the deposit registered at the given
-- status. 'Nothing' registers no deposit at all, modelling one that has already been recovered:
-- 'DepositRecovered' deletes the map entry but leaves 'currentDepositTxId' pointing at it.
reqDecStateWith :: [Party] -> Maybe DepositStatus -> NodeState SimpleTx
reqDecStateWith :: [Party] -> Maybe DepositStatus -> NodeState SimpleTx
reqDecStateWith [Party]
parties Maybe DepositStatus
mStatus =
  ([Party] -> CoordinatedHeadState SimpleTx -> NodeState SimpleTx
inOpenState' [Party]
parties CoordinatedHeadState SimpleTx
headState)
    { pendingDeposits = maybe mempty (Map.singleton reqDecDepositTxId . mkDeposit) mStatus
    }
 where
  headState :: CoordinatedHeadState SimpleTx
headState =
    CoordinatedHeadState
      { $sel:localUTxO:CoordinatedHeadState :: UTxOType SimpleTx
localUTxO = UTxOType SimpleTx
forall a. Monoid a => a
mempty
      , $sel:allTxs:CoordinatedHeadState :: Map (TxIdType SimpleTx) SimpleTx
allTxs = Map (TxIdType SimpleTx) SimpleTx
forall a. Monoid a => a
mempty
      , $sel:localTxs:CoordinatedHeadState :: Seq SimpleTx
localTxs = Seq SimpleTx
forall a. Monoid a => a
mempty
      , $sel:confirmedSnapshot:CoordinatedHeadState :: ConfirmedSnapshot SimpleTx
confirmedSnapshot = HeadId -> ConfirmedSnapshot SimpleTx
forall tx. HeadId -> ConfirmedSnapshot tx
InitialSnapshot HeadId
testHeadId
      , $sel:seenSnapshot:CoordinatedHeadState :: SeenSnapshot SimpleTx
seenSnapshot = SeenSnapshot SimpleTx
forall tx. SeenSnapshot tx
NoSeenSnapshot
      , $sel:currentDepositTxId:CoordinatedHeadState :: Maybe (TxIdType SimpleTx)
currentDepositTxId = TxIdType SimpleTx -> Maybe (TxIdType SimpleTx)
forall a. a -> Maybe a
Just TxIdType SimpleTx
reqDecDepositTxId
      , $sel:decommitTx:CoordinatedHeadState :: Maybe SimpleTx
decommitTx = Maybe SimpleTx
forall a. Maybe a
Nothing
      , $sel:version:CoordinatedHeadState :: SnapshotVersion
version = SnapshotVersion
0
      }
  mkDeposit :: DepositStatus -> Deposit SimpleTx
mkDeposit DepositStatus
status =
    Deposit
      { $sel:headId:Deposit :: HeadId
headId = HeadId
testHeadId
      , $sel:deposited:Deposit :: UTxOType SimpleTx
deposited = UTxOType SimpleTx
reqDecDepositedUTxO
      , $sel:created:Deposit :: UTCTime
created = UTCTime
initialChainTime
      , $sel:deadline:Deposit :: UTCTime
deadline = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
3600 UTCTime
initialChainTime
      , DepositStatus
$sel:status:Deposit :: DepositStatus
status :: DepositStatus
status
      }

inOpenState' ::
  [Party] ->
  CoordinatedHeadState SimpleTx ->
  NodeState SimpleTx
inOpenState' :: [Party] -> CoordinatedHeadState SimpleTx -> NodeState SimpleTx
inOpenState' [Party]
parties CoordinatedHeadState SimpleTx
coordinatedHeadState =
  HeadState SimpleTx -> NodeState SimpleTx
forall tx. IsTx tx => HeadState tx -> NodeState tx
inSync (HeadState SimpleTx -> NodeState SimpleTx)
-> HeadState SimpleTx -> NodeState SimpleTx
forall a b. (a -> b) -> a -> b
$
    OpenState SimpleTx -> HeadState SimpleTx
forall tx. OpenState tx -> HeadState tx
Open
      OpenState
        { HeadParameters
$sel:parameters:OpenState :: HeadParameters
parameters :: HeadParameters
parameters
        , CoordinatedHeadState SimpleTx
$sel:coordinatedHeadState:OpenState :: CoordinatedHeadState SimpleTx
coordinatedHeadState :: CoordinatedHeadState SimpleTx
coordinatedHeadState
        , $sel:chainState:OpenState :: ChainStateType SimpleTx
chainState = ChainStateType SimpleTx
SimpleChainState
0
        , $sel:headId:OpenState :: HeadId
headId = HeadId
testHeadId
        , $sel:headSeed:OpenState :: HeadSeed
headSeed = HeadSeed
testHeadSeed
        }
 where
  parameters :: HeadParameters
parameters = ContestationPeriod -> DepositPeriod -> [Party] -> HeadParameters
HeadParameters ContestationPeriod
defaultContestationPeriod DepositPeriod
defaultDepositPeriod [Party]
parties

-- XXX: This is always called with 'threeParties'
inClosedState :: [Party] -> NodeState SimpleTx
inClosedState :: [Party] -> NodeState SimpleTx
inClosedState [Party]
parties = [Party] -> ConfirmedSnapshot SimpleTx -> NodeState SimpleTx
inClosedState' [Party]
parties ConfirmedSnapshot SimpleTx
snapshot0
 where
  snapshot0 :: ConfirmedSnapshot SimpleTx
snapshot0 = forall tx. HeadId -> ConfirmedSnapshot tx
InitialSnapshot @SimpleTx HeadId
testHeadId

inClosedState' :: [Party] -> ConfirmedSnapshot SimpleTx -> NodeState SimpleTx
inClosedState' :: [Party] -> ConfirmedSnapshot SimpleTx -> NodeState SimpleTx
inClosedState' [Party]
parties ConfirmedSnapshot SimpleTx
confirmedSnapshot =
  HeadState SimpleTx -> NodeState SimpleTx
forall tx. IsTx tx => HeadState tx -> NodeState tx
inSync (HeadState SimpleTx -> NodeState SimpleTx)
-> HeadState SimpleTx -> NodeState SimpleTx
forall a b. (a -> b) -> a -> b
$
    ClosedState SimpleTx -> HeadState SimpleTx
forall tx. ClosedState tx -> HeadState tx
Closed
      ClosedState
        { HeadParameters
$sel:parameters:ClosedState :: HeadParameters
parameters :: HeadParameters
parameters
        , ConfirmedSnapshot SimpleTx
$sel:confirmedSnapshot:ClosedState :: ConfirmedSnapshot SimpleTx
confirmedSnapshot :: ConfirmedSnapshot SimpleTx
confirmedSnapshot
        , UTCTime
$sel:contestationDeadline:ClosedState :: UTCTime
contestationDeadline :: UTCTime
contestationDeadline
        , $sel:readyToFanoutSent:ClosedState :: Bool
readyToFanoutSent = Bool
False
        , $sel:chainState:ClosedState :: ChainStateType SimpleTx
chainState = ChainStateType SimpleTx
SimpleChainState
0
        , $sel:headId:ClosedState :: HeadId
headId = HeadId
testHeadId
        , $sel:headSeed:ClosedState :: HeadSeed
headSeed = HeadSeed
testHeadSeed
        , $sel:version:ClosedState :: SnapshotVersion
version = SnapshotVersion
0
        }
 where
  parameters :: HeadParameters
parameters = ContestationPeriod -> DepositPeriod -> [Party] -> HeadParameters
HeadParameters ContestationPeriod
defaultContestationPeriod DepositPeriod
defaultDepositPeriod [Party]
parties

  contestationDeadline :: UTCTime
contestationDeadline = Gen UTCTime
forall a. Arbitrary a => Gen a
arbitrary Gen UTCTime -> Int -> UTCTime
forall a. Gen a -> Int -> a
`generateWith` Int
42

-- | A head mid partial-fanout (on-chain 'FanoutProgress') with the given
-- still-to-distribute set and 'FanoutMode'. 'distributedOutputs' is a non-empty
-- placeholder so the head datum is treated as @FanoutProgress@ (some outputs
-- already distributed).
inFanoutProgressWith :: [Party] -> Set SimpleTxOut -> FanoutMode SimpleTx -> NodeState SimpleTx
inFanoutProgressWith :: [Party]
-> Set SimpleTxOut -> FanoutMode SimpleTx -> NodeState SimpleTx
inFanoutProgressWith [Party]
parties Set SimpleTxOut
remaining FanoutMode SimpleTx
mode =
  HeadState SimpleTx -> NodeState SimpleTx
forall tx. IsTx tx => HeadState tx -> NodeState tx
inSync (HeadState SimpleTx -> NodeState SimpleTx)
-> HeadState SimpleTx -> NodeState SimpleTx
forall a b. (a -> b) -> a -> b
$
    PartialFanoutState SimpleTx -> HeadState SimpleTx
forall tx. PartialFanoutState tx -> HeadState tx
FanoutProgress
      PartialFanoutState
        { HeadParameters
$sel:parameters:PartialFanoutState :: HeadParameters
parameters :: HeadParameters
parameters
        , -- Use a snapshot whose utxo matches the remaining set so the
          -- accumulator/proof computations line up.
          $sel:confirmedSnapshot:PartialFanoutState :: ConfirmedSnapshot SimpleTx
confirmedSnapshot =
            Snapshot SimpleTx
-> MultiSignature (Snapshot SimpleTx) -> ConfirmedSnapshot SimpleTx
forall tx.
Snapshot tx -> MultiSignature (Snapshot tx) -> ConfirmedSnapshot tx
ConfirmedSnapshot
              (SnapshotNumber
-> SnapshotVersion
-> [SimpleTx]
-> UTxOType SimpleTx
-> Snapshot SimpleTx
forall tx.
IsTx tx =>
SnapshotNumber
-> SnapshotVersion -> [tx] -> UTxOType tx -> Snapshot tx
testSnapshot SnapshotNumber
0 SnapshotVersion
0 [] Set SimpleTxOut
UTxOType SimpleTx
remaining)
              ([Signature (Snapshot SimpleTx)]
-> MultiSignature (Snapshot SimpleTx)
forall a. [Signature a] -> MultiSignature a
Crypto.aggregate [])
        , UTCTime
$sel:contestationDeadline:PartialFanoutState :: UTCTime
contestationDeadline :: UTCTime
contestationDeadline
        , $sel:chainState:PartialFanoutState :: ChainStateType SimpleTx
chainState = ChainStateType SimpleTx
SimpleChainState
0
        , $sel:headId:PartialFanoutState :: HeadId
headId = HeadId
testHeadId
        , $sel:headSeed:PartialFanoutState :: HeadSeed
headSeed = HeadSeed
testHeadSeed
        , $sel:version:PartialFanoutState :: SnapshotVersion
version = SnapshotVersion
0
        , $sel:remainingOutputs:PartialFanoutState :: UTxOType SimpleTx
remainingOutputs = Set SimpleTxOut
UTxOType SimpleTx
remaining
        , $sel:distributedOutputs:PartialFanoutState :: UTxOType SimpleTx
distributedOutputs = SimpleTxOut -> Set SimpleTxOut
forall a. a -> Set a
Set.singleton (SimpleId -> SimpleTxOut
SimpleTxOut SimpleId
0)
        , FanoutMode SimpleTx
$sel:mode:PartialFanoutState :: FanoutMode SimpleTx
mode :: FanoutMode SimpleTx
mode
        }
 where
  parameters :: HeadParameters
parameters = ContestationPeriod -> DepositPeriod -> [Party] -> HeadParameters
HeadParameters ContestationPeriod
defaultContestationPeriod DepositPeriod
defaultDepositPeriod [Party]
parties
  contestationDeadline :: UTCTime
contestationDeadline = Gen UTCTime
forall a. Arbitrary a => Gen a
arbitrary Gen UTCTime -> Int -> UTCTime
forall a. Gen a -> Int -> a
`generateWith` Int
42

-- | Like 'inFanoutProgressWith' but in 'AutoDrain' mode, as if a plain 'Fanout'
-- kicked off the (chunked) fanout.
inAutoDrainProgress :: [Party] -> Set SimpleTxOut -> NodeState SimpleTx
inAutoDrainProgress :: [Party] -> Set SimpleTxOut -> NodeState SimpleTx
inAutoDrainProgress [Party]
parties Set SimpleTxOut
remaining =
  [Party]
-> Set SimpleTxOut -> FanoutMode SimpleTx -> NodeState SimpleTx
inFanoutProgressWith [Party]
parties Set SimpleTxOut
remaining FanoutMode SimpleTx
forall tx. FanoutMode tx
AutoDrain

getConfirmedSnapshot :: IsTx tx => NodeState tx -> Maybe (Snapshot tx)
getConfirmedSnapshot :: forall tx. IsTx tx => NodeState tx -> Maybe (Snapshot tx)
getConfirmedSnapshot = \case
  NodeInSync{$sel:headState:NodeInSync :: forall tx. NodeState tx -> HeadState tx
headState = Open OpenState{$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}}} ->
    Snapshot tx -> Maybe (Snapshot tx)
forall a. a -> Maybe a
Just (ConfirmedSnapshot tx -> Snapshot tx
forall tx. IsTx tx => ConfirmedSnapshot tx -> Snapshot tx
getSnapshot ConfirmedSnapshot tx
confirmedSnapshot)
  NodeState tx
_ ->
    Maybe (Snapshot tx)
forall a. Maybe a
Nothing

data StepState tx = StepState
  { forall tx. StepState tx -> NodeState tx
nodeState :: NodeState tx
  , forall tx. StepState tx -> Environment
env :: Environment
  , forall tx. StepState tx -> Ledger tx
ledger :: Ledger tx
  }

runHeadLogic ::
  Monad m =>
  Environment ->
  Ledger tx ->
  NodeState tx ->
  StateT (StepState tx) m a ->
  m a
runHeadLogic :: forall (m :: * -> *) tx a.
Monad m =>
Environment
-> Ledger tx -> NodeState tx -> StateT (StepState tx) m a -> m a
runHeadLogic Environment
env Ledger tx
ledger NodeState tx
nodeState = (StateT (StepState tx) m a -> StepState tx -> m a
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
`evalStateT` StepState{Environment
$sel:env:StepState :: Environment
env :: Environment
env, Ledger tx
$sel:ledger:StepState :: Ledger tx
ledger :: Ledger tx
ledger, NodeState tx
$sel:nodeState:StepState :: NodeState tx
nodeState :: NodeState tx
nodeState})

-- | Retrieves the latest 'NodeState' from within 'runHeadLogic'.
getState :: MonadState (StepState tx) m => m (NodeState tx)
getState :: forall tx (m :: * -> *).
MonadState (StepState tx) m =>
m (NodeState tx)
getState = StepState tx -> NodeState tx
forall tx. StepState tx -> NodeState tx
nodeState (StepState tx -> NodeState tx)
-> m (StepState tx) -> m (NodeState tx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (StepState tx)
forall s (m :: * -> *). MonadState s m => m s
get

-- | Calls 'update' and 'aggregate' to drive the 'runHeadLogic' monad forward.
step ::
  (MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
  Input tx ->
  m (Outcome tx)
step :: forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx, MonadTime m) =>
Input tx -> m (Outcome tx)
step Input tx
input = do
  StepState{NodeState tx
$sel:nodeState:StepState :: forall tx. StepState tx -> NodeState tx
nodeState :: NodeState tx
nodeState, Environment
$sel:env:StepState :: forall tx. StepState tx -> Environment
env :: Environment
env, Ledger tx
$sel:ledger:StepState :: forall tx. StepState tx -> Ledger tx
ledger :: Ledger tx
ledger} <- m (StepState tx)
forall s (m :: * -> *). MonadState s m => m s
get
  UTCTime
now <- m UTCTime
forall (m :: * -> *). MonadTime m => m UTCTime
getCurrentTime
  let outcome :: Outcome tx
outcome = Environment
-> Ledger tx -> UTCTime -> NodeState tx -> Input tx -> Outcome tx
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
input
  let nodeState' :: NodeState tx
nodeState' = NodeState tx -> Outcome tx -> NodeState tx
forall tx.
IsChainState tx =>
NodeState tx -> Outcome tx -> NodeState tx
aggregateState NodeState tx
nodeState Outcome tx
outcome
  StepState tx -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put StepState{Environment
$sel:env:StepState :: Environment
env :: Environment
env, Ledger tx
$sel:ledger:StepState :: Ledger tx
ledger :: Ledger tx
ledger, $sel:nodeState:StepState :: NodeState tx
nodeState = NodeState tx
nodeState'}
  Outcome tx -> m (Outcome tx)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Outcome tx
outcome

hasEffect :: (HasCallStack, IsChainState tx) => Outcome tx -> Effect tx -> IO ()
hasEffect :: forall tx.
(HasCallStack, IsChainState tx) =>
Outcome tx -> Effect tx -> IO ()
hasEffect Outcome tx
outcome Effect tx
effect = Outcome tx -> (Effect tx -> Bool) -> IO ()
forall tx.
(HasCallStack, IsChainState tx) =>
Outcome tx -> (Effect tx -> Bool) -> IO ()
hasEffectSatisfying Outcome tx
outcome (Effect tx -> Effect tx -> Bool
forall a. Eq a => a -> a -> Bool
== Effect tx
effect)

assertWait :: (HasCallStack, IsChainState tx) => Outcome tx -> WaitReason tx -> IO ()
assertWait :: forall tx.
(HasCallStack, IsChainState tx) =>
Outcome tx -> WaitReason tx -> IO ()
assertWait Outcome tx
outcome WaitReason tx
waitReason =
  case Outcome tx
outcome of
    Wait{WaitReason tx
$sel:reason:Continue :: forall tx. Outcome tx -> WaitReason tx
reason :: WaitReason tx
reason} -> WaitReason tx
reason WaitReason tx -> WaitReason tx -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` WaitReason tx
waitReason
    Outcome tx
_ -> String -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Expected a wait, but got: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Outcome tx -> String
forall b a. (Show a, IsString b) => a -> b
show Outcome tx
outcome

-- | The effects produced by an outcome (empty for 'Wait'/'Error').
effectsOf :: Outcome tx -> [Effect tx]
effectsOf :: forall tx. Outcome tx -> [Effect tx]
effectsOf = \case
  Continue{[Effect tx]
$sel:effects:Continue :: forall tx. Outcome tx -> [Effect tx]
effects :: [Effect tx]
effects} -> [Effect tx]
effects
  Outcome tx
_ -> []

hasEffectSatisfying :: (HasCallStack, IsChainState tx) => Outcome tx -> (Effect tx -> Bool) -> IO ()
hasEffectSatisfying :: forall tx.
(HasCallStack, IsChainState tx) =>
Outcome tx -> (Effect tx -> Bool) -> IO ()
hasEffectSatisfying Outcome tx
outcome Effect tx -> Bool
predicate =
  case Outcome tx
outcome of
    Wait{} -> String -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure String
"Expected an effect, but got Wait outcome"
    Error{} -> String -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure String
"Expected an effect, but got Error outcome"
    Continue{[Effect tx]
$sel:effects:Continue :: forall tx. Outcome tx -> [Effect tx]
effects :: [Effect tx]
effects} ->
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ((Effect tx -> Bool) -> [Effect tx] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Effect tx -> Bool
predicate [Effect tx]
effects) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        String -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
          String
"Expected an effect satisfying the predicate, but got: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [Effect tx] -> String
forall b a. (Show a, IsString b) => a -> b
show [Effect tx]
effects

hasNoEffectSatisfying :: (HasCallStack, IsChainState tx) => Outcome tx -> (Effect tx -> Bool) -> IO ()
hasNoEffectSatisfying :: forall tx.
(HasCallStack, IsChainState tx) =>
Outcome tx -> (Effect tx -> Bool) -> IO ()
hasNoEffectSatisfying Outcome tx
outcome Effect tx -> Bool
predicate =
  case Outcome tx
outcome of
    Wait{} -> String -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure String
"Expected an effect, but got Wait outcome"
    Error{} -> String -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure String
"Expected an effect, but got Error outcome"
    Continue{[Effect tx]
$sel:effects:Continue :: forall tx. Outcome tx -> [Effect tx]
effects :: [Effect tx]
effects} ->
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Effect tx -> Bool) -> [Effect tx] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Effect tx -> Bool
predicate [Effect tx]
effects) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        String -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
          String
"Expected no effect satisfying the predicate, but got: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [Effect tx] -> String
forall b a. (Show a, IsString b) => a -> b
show [Effect tx]
effects

hasStateChangedSatisfying :: (HasCallStack, IsChainState tx) => Outcome tx -> (StateChanged tx -> Bool) -> IO ()
hasStateChangedSatisfying :: forall tx.
(HasCallStack, IsChainState tx) =>
Outcome tx -> (StateChanged tx -> Bool) -> IO ()
hasStateChangedSatisfying Outcome tx
outcome StateChanged tx -> Bool
predicate =
  case Outcome tx
outcome of
    Wait{} -> String -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure String
"Expected an effect, but got Wait outcome"
    Error{} -> String -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure String
"Expected an effect, but got Error outcome"
    Continue{[StateChanged tx]
$sel:stateChanges:Continue :: forall tx. Outcome tx -> [StateChanged tx]
stateChanges :: [StateChanged tx]
stateChanges} ->
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ((StateChanged tx -> Bool) -> [StateChanged tx] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any StateChanged tx -> Bool
predicate [StateChanged tx]
stateChanges) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        String -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
          String
"Expected an state change satisfying the predicate, but got: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [StateChanged tx] -> String
forall b a. (Show a, IsString b) => a -> b
show [StateChanged tx]
stateChanges

hasNoStateChangedSatisfying :: (HasCallStack, IsChainState tx) => Outcome tx -> (StateChanged tx -> Bool) -> IO ()
hasNoStateChangedSatisfying :: forall tx.
(HasCallStack, IsChainState tx) =>
Outcome tx -> (StateChanged tx -> Bool) -> IO ()
hasNoStateChangedSatisfying Outcome tx
outcome StateChanged tx -> Bool
predicate =
  case Outcome tx
outcome of
    Wait{} -> String -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure String
"Expected an effect, but got Wait outcome"
    Error{} -> String -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure String
"Expected an effect, but got Error outcome"
    Continue{[StateChanged tx]
$sel:stateChanges:Continue :: forall tx. Outcome tx -> [StateChanged tx]
stateChanges :: [StateChanged tx]
stateChanges} ->
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((StateChanged tx -> Bool) -> [StateChanged tx] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any StateChanged tx -> Bool
predicate [StateChanged tx]
stateChanges) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        String -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
          String
"Expected no state change satisfying the predicate, but got: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [StateChanged tx] -> String
forall b a. (Show a, IsString b) => a -> b
show [StateChanged tx]
stateChanges

nowFromSlot :: (MonadFail m, MonadTime m) => ChainSlot -> m UTCTime
nowFromSlot :: forall (m :: * -> *).
(MonadFail m, MonadTime m) =>
ChainSlot -> m UTCTime
nowFromSlot (ChainSlot Natural
slotNo) = do
  TimeHandle
timeHandle <- SlotNo -> UTCTime -> TimeHandle
mkTimeHandleAt (Natural -> SlotNo
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
slotNo) (UTCTime -> TimeHandle) -> m UTCTime -> m TimeHandle
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m UTCTime
forall (m :: * -> *). MonadTime m => m UTCTime
getCurrentTime
  case TimeHandle -> SlotNo -> Either Text UTCTime
slotToUTCTime TimeHandle
timeHandle (Natural -> SlotNo
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
slotNo) of
    Left Text
err -> String -> m UTCTime
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m UTCTime) -> String -> m UTCTime
forall a b. (a -> b) -> a -> b
$ String
"nowFromSlot: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall b a. (Show a, IsString b) => a -> b
show Text
err
    Right UTCTime
time -> UTCTime -> m UTCTime
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure UTCTime
time

-- | Create a 'TimeHandle' for a given slot and current wall-clock time.
-- * Assumes 1-second slots (as in the devnet).
-- * SystemStart is derived so that the given slot corresponds to the given time.
-- * EraHistory is constructed to have a horizon sufficiently far in the future to accommodate time conversions.
mkTimeHandleAt :: SlotNo -> UTCTime -> TimeHandle
mkTimeHandleAt :: SlotNo -> UTCTime -> TimeHandle
mkTimeHandleAt SlotNo
slotNo UTCTime
now =
  SlotNo -> SystemStart -> EraHistory -> TimeHandle
mkTimeHandle SlotNo
slotNo SystemStart
systemStart EraHistory
eraHistory
 where
  -- Assume 1 slot = 1 second (devnet)
  slotLength :: NominalDiffTime
  slotLength :: NominalDiffTime
slotLength = NominalDiffTime
1

  -- Compute system start time from the relation: `now = startTime + slotNo * slotLength`
  startTime :: UTCTime
startTime = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime (NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a
negate (NominalDiffTime -> NominalDiffTime)
-> NominalDiffTime -> NominalDiffTime
forall a b. (a -> b) -> a -> b
$ Word64 -> NominalDiffTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral (SlotNo -> Word64
unSlotNo SlotNo
slotNo) NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
slotLength) UTCTime
now
  systemStart :: SystemStart
systemStart = UTCTime -> SystemStart
SystemStart UTCTime
startTime

  -- Choose a "safe" horizon far enough beyond the current slot
  horizonSlot :: SlotNo
horizonSlot = Word64 -> SlotNo
SlotNo (Word64 -> SlotNo) -> Word64 -> SlotNo
forall a b. (a -> b) -> a -> b
$ SlotNo -> Word64
unSlotNo SlotNo
slotNo Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Pico -> Word64
forall b. Integral b => Pico -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor Pico
safeZone

  -- Construct an era history that's valid up to that horizon
  eraHistory :: EraHistory
eraHistory = SlotNo -> EraHistory
eraHistoryWithHorizonAt SlotNo
horizonSlot

catchingUp :: IsTx tx => HeadState tx -> NodeState tx
catchingUp :: forall tx. IsTx tx => HeadState tx -> NodeState tx
catchingUp HeadState tx
headState = NodeCatchingUp{HeadState tx
$sel:headState:NodeInSync :: HeadState tx
headState :: HeadState tx
headState, $sel:pendingDeposits:NodeInSync :: Map (TxIdType tx) (Deposit tx)
pendingDeposits = Map (TxIdType tx) (Deposit tx)
forall a. Monoid a => a
mempty, $sel:chainPointTime:NodeInSync :: ChainPointTime
chainPointTime = ChainPointTime
zeroChainPointTime}

inSync :: IsTx tx => HeadState tx -> NodeState tx
inSync :: forall tx. IsTx tx => HeadState tx -> NodeState tx
inSync HeadState tx
headState = NodeInSync{HeadState tx
$sel:headState:NodeInSync :: HeadState tx
headState :: HeadState tx
headState, $sel:pendingDeposits:NodeInSync :: Map (TxIdType tx) (Deposit tx)
pendingDeposits = Map (TxIdType tx) (Deposit tx)
forall a. Monoid a => a
mempty, $sel:chainPointTime:NodeInSync :: ChainPointTime
chainPointTime = ChainPointTime
zeroChainPointTime}

zeroChainPointTime :: ChainPointTime
zeroChainPointTime :: ChainPointTime
zeroChainPointTime =
  ChainPointTime
    { $sel:currentSlot:ChainPointTime :: ChainSlot
currentSlot = Natural -> ChainSlot
ChainSlot Natural
0
    , $sel:currentChainTime:ChainPointTime :: UTCTime
currentChainTime = UTCTime
initialChainTime
    , $sel:drift:ChainPointTime :: NominalDiffTime
drift = NominalDiffTime
0
    }

testSnapshot ::
  forall tx.
  IsTx tx =>
  SnapshotNumber ->
  SnapshotVersion ->
  [tx] ->
  UTxOType tx ->
  Snapshot tx
testSnapshot :: forall tx.
IsTx tx =>
SnapshotNumber
-> SnapshotVersion -> [tx] -> UTxOType tx -> Snapshot tx
testSnapshot SnapshotNumber
number SnapshotVersion
version [tx]
confirmed UTxOType tx
utxo =
  Snapshot
    { $sel:headId:Snapshot :: HeadId
headId = HeadId
testHeadId
    , SnapshotVersion
$sel:version:Snapshot :: SnapshotVersion
version :: SnapshotVersion
version
    , SnapshotNumber
$sel:number:Snapshot :: SnapshotNumber
number :: SnapshotNumber
number
    , [tx]
$sel:confirmed:Snapshot :: [tx]
confirmed :: [tx]
confirmed
    , UTxOType tx
$sel:utxo:Snapshot :: UTxOType tx
utxo :: UTxOType tx
utxo
    , $sel:utxoToCommit:Snapshot :: Maybe (UTxOType tx)
utxoToCommit = Maybe (UTxOType tx)
forall a. Monoid a => a
mempty
    , $sel:utxoToDecommit:Snapshot :: Maybe (UTxOType tx)
utxoToDecommit = Maybe (UTxOType tx)
forall a. Monoid a => a
mempty
    , $sel:depositTxId:Snapshot :: Maybe (TxIdType tx)
depositTxId = Maybe (TxIdType tx)
forall a. Maybe a
Nothing
    , $sel:accumulator:Snapshot :: HydraAccumulator
accumulator = UTxOType tx -> HydraAccumulator
forall tx. IsTx tx => UTxOType tx -> HydraAccumulator
Accumulator.buildFromUTxO UTxOType tx
utxo
    }