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

-- | Unit tests of the 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 Test.Hydra.Prelude

import Cardano.Api.UTxO qualified as UTxO
import Data.List qualified as List
import Data.Map (notMember)
import Data.Set qualified as Set
import Hydra.API.ServerOutput (ServerOutput (..))
import Hydra.Cardano.Api (genTxIn, mkVkAddress, txOutValue, unSlotNo, pattern TxValidityUpperBound)
import Hydra.Chain (
  ChainEvent (..),
  HeadParameters (..),
  IsChainState,
  OnChainTx (..),
  PostChainTx (CollectComTx, ContestTx),
 )
import Hydra.Chain.Direct.Fixture qualified as Fixture
import Hydra.Chain.Direct.State ()
import Hydra.Crypto (generateSigningKey, sign)
import Hydra.Crypto qualified as Crypto
import Hydra.Environment (Environment (..))
import Hydra.HeadLogic (
  ClosedState (..),
  CoordinatedHeadState (..),
  Effect (..),
  HeadState (..),
  IdleState (..),
  InitialState (..),
  Input (..),
  LogicError (..),
  OpenState (..),
  Outcome (..),
  RequirementFailure (..),
  SeenSnapshot (NoSeenSnapshot, SeenSnapshot),
  WaitReason (..),
  aggregateState,
  defaultTTL,
  update,
 )
import Hydra.HeadLogic.State (getHeadParameters)
import Hydra.Ledger (ChainSlot (..), IsTx (..), Ledger (..), ValidationError (..))
import Hydra.Ledger.Cardano (cardanoLedger, genKeyPair, genOutput, mkRangedTx)
import Hydra.Ledger.Simple (SimpleChainState (..), SimpleTx (..), aValidTx, simpleLedger, utxoRef, utxoRefs)
import Hydra.Network.Message (Message (AckSn, ReqSn, ReqTx))
import Hydra.Options (defaultContestationPeriod)
import Hydra.Party (Party (..))
import Hydra.Prelude qualified as Prelude
import Hydra.Snapshot (ConfirmedSnapshot (..), Snapshot (..), SnapshotNumber, getSnapshot)
import Test.Hydra.Fixture (alice, aliceSk, bob, bobSk, carol, carolSk, deriveOnChainId, testHeadId, testHeadSeed)
import Test.QuickCheck (Property, counterexample, elements, forAll, oneof, shuffle, suchThat)
import Test.QuickCheck.Monadic (assert, monadicIO, pick, run)

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 :: SigningKey HydraKey
signingKey = SigningKey HydraKey
bobSk
            , $sel:otherParties:Environment :: [Party]
otherParties = [Party
alice, Party
carol]
            , $sel:contestationPeriod:Environment :: ContestationPeriod
contestationPeriod = ContestationPeriod
defaultContestationPeriod
            , $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
            }

    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 :: [SimpleTx]
localTxs = [SimpleTx]
forall a. Monoid a => a
mempty
              , $sel:confirmedSnapshot:CoordinatedHeadState :: ConfirmedSnapshot SimpleTx
confirmedSnapshot = HeadId -> UTxOType SimpleTx -> ConfirmedSnapshot SimpleTx
forall tx. HeadId -> UTxOType tx -> ConfirmedSnapshot tx
InitialSnapshot HeadId
testHeadId UTxOType SimpleTx
forall a. Monoid a => a
mempty
              , $sel:seenSnapshot:CoordinatedHeadState :: SeenSnapshot SimpleTx
seenSnapshot = SeenSnapshot SimpleTx
forall tx. SeenSnapshot tx
NoSeenSnapshot
              }

      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 SimpleTxIn
UTxOType SimpleTx
inputs Set SimpleTxIn
UTxOType SimpleTx
forall a. Monoid a => a
mempty
            ttl :: Natural
ttl = Natural
0
            reqTx :: Input SimpleTx
reqTx = Natural -> Party -> Message SimpleTx -> Input SimpleTx
forall tx. Natural -> Party -> Message tx -> Input tx
NetworkInput Natural
ttl Party
alice (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
tx
            s0 :: HeadState SimpleTx
s0 = [Party] -> HeadState SimpleTx
inOpenState [Party]
threeParties

        Environment
-> Ledger SimpleTx
-> HeadState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment -> Ledger tx -> HeadState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger HeadState SimpleTx
s0 Input SimpleTx
reqTx Outcome SimpleTx -> (Effect SimpleTx -> Bool) -> IO ()
forall tx.
(HasCallStack, IsChainState tx) =>
Outcome tx -> (Effect tx -> Bool) -> IO ()
`hasEffectSatisfying` \case
          ClientEffect TxInvalid{SimpleTx
transaction :: SimpleTx
$sel:transaction:PeerConnected :: forall tx. ServerOutput tx -> tx
transaction} -> SimpleTx
transaction SimpleTx -> SimpleTx -> Bool
forall a. Eq a => a -> a -> Bool
== SimpleTx
tx
          Effect 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 = Natural -> Party -> Message SimpleTx -> Input SimpleTx
forall tx. Natural -> Party -> Message tx -> Input tx
NetworkInput Natural
defaultTTL Party
alice (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 SimpleTxIn
UTxOType SimpleTx
inputs Set SimpleTxIn
UTxOType SimpleTx
forall a. Monoid a => a
mempty
            inputs :: UTxOType SimpleTx
inputs = SimpleId -> UTxOType SimpleTx
utxoRef SimpleId
1
            s0 :: HeadState SimpleTx
s0 = [Party] -> HeadState SimpleTx
inOpenState [Party]
threeParties

        Environment
-> Ledger SimpleTx
-> HeadState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment -> Ledger tx -> HeadState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger HeadState 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
"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 = Natural -> Party -> Message tx -> Input tx
forall tx. Natural -> Party -> Message tx -> Input tx
NetworkInput Natural
defaultTTL Party
alice (Message tx -> Input tx) -> Message tx -> Input tx
forall a b. (a -> b) -> a -> b
$ SnapshotNumber -> [TxIdType tx] -> Message tx
forall tx. SnapshotNumber -> [TxIdType tx] -> Message tx
ReqSn SnapshotNumber
1 []
            snapshot1 :: Snapshot SimpleTx
snapshot1 = HeadId
-> SnapshotNumber
-> UTxOType SimpleTx
-> [TxIdType SimpleTx]
-> Snapshot SimpleTx
forall tx.
HeadId
-> SnapshotNumber -> UTxOType tx -> [TxIdType tx] -> Snapshot tx
Snapshot HeadId
testHeadId SnapshotNumber
1 UTxOType SimpleTx
forall a. Monoid a => a
mempty []
            ackFrom :: SigningKey HydraKey -> Party -> Input SimpleTx
ackFrom SigningKey HydraKey
sk Party
vk = Natural -> Party -> Message SimpleTx -> Input SimpleTx
forall tx. Natural -> Party -> Message tx -> Input tx
NetworkInput Natural
defaultTTL 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 (SigningKey HydraKey
-> Snapshot SimpleTx -> Signature (Snapshot SimpleTx)
forall a.
SignableRepresentation a =>
SigningKey HydraKey -> a -> Signature a
sign SigningKey HydraKey
sk Snapshot SimpleTx
snapshot1) SnapshotNumber
1
        HeadState SimpleTx
snapshotInProgress <- Environment
-> Ledger SimpleTx
-> HeadState SimpleTx
-> StateT (StepState SimpleTx) IO (HeadState SimpleTx)
-> IO (HeadState SimpleTx)
forall (m :: * -> *) tx a.
Monad m =>
Environment
-> Ledger tx -> HeadState tx -> StateT (StepState tx) m a -> m a
runHeadLogic Environment
bobEnv Ledger SimpleTx
ledger ([Party] -> HeadState SimpleTx
inOpenState [Party]
threeParties) (StateT (StepState SimpleTx) IO (HeadState SimpleTx)
 -> IO (HeadState SimpleTx))
-> StateT (StepState SimpleTx) IO (HeadState SimpleTx)
-> IO (HeadState 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) =>
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) =>
Input tx -> m (Outcome tx)
step (SigningKey HydraKey -> Party -> Input SimpleTx
ackFrom SigningKey HydraKey
carolSk Party
carol)
          Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx) =>
Input tx -> m (Outcome tx)
step (SigningKey HydraKey -> Party -> Input SimpleTx
ackFrom SigningKey HydraKey
aliceSk Party
alice)
          StateT (StepState SimpleTx) IO (HeadState SimpleTx)
forall tx (m :: * -> *).
MonadState (StepState tx) m =>
m (HeadState tx)
getState

        HeadState SimpleTx -> Maybe (Snapshot SimpleTx)
forall tx. HeadState tx -> Maybe (Snapshot tx)
getConfirmedSnapshot HeadState 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
-> UTxOType SimpleTx -> [TxIdType SimpleTx] -> Snapshot SimpleTx
forall tx.
SnapshotNumber -> UTxOType tx -> [TxIdType tx] -> Snapshot tx
testSnapshot SnapshotNumber
0 Set SimpleTxIn
UTxOType SimpleTx
forall a. Monoid a => a
mempty [])

        HeadState SimpleTx
snapshotConfirmed <-
          Environment
-> Ledger SimpleTx
-> HeadState SimpleTx
-> StateT (StepState SimpleTx) IO (HeadState SimpleTx)
-> IO (HeadState SimpleTx)
forall (m :: * -> *) tx a.
Monad m =>
Environment
-> Ledger tx -> HeadState tx -> StateT (StepState tx) m a -> m a
runHeadLogic Environment
bobEnv Ledger SimpleTx
ledger HeadState SimpleTx
snapshotInProgress (StateT (StepState SimpleTx) IO (HeadState SimpleTx)
 -> IO (HeadState SimpleTx))
-> StateT (StepState SimpleTx) IO (HeadState SimpleTx)
-> IO (HeadState 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) =>
Input tx -> m (Outcome tx)
step (SigningKey HydraKey -> Party -> Input SimpleTx
ackFrom SigningKey HydraKey
bobSk Party
bob)
            StateT (StepState SimpleTx) IO (HeadState SimpleTx)
forall tx (m :: * -> *).
MonadState (StepState tx) m =>
m (HeadState tx)
getState
        HeadState SimpleTx -> Maybe (Snapshot SimpleTx)
forall tx. HeadState tx -> Maybe (Snapshot tx)
getConfirmedSnapshot HeadState 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
"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 :: HeadState SimpleTx
s0 = [Party] -> HeadState SimpleTx
inOpenState [Party]
threeParties
              t1 :: SimpleTx
t1 = SimpleId -> UTxOType SimpleTx -> UTxOType SimpleTx -> SimpleTx
SimpleTx SimpleId
1 Set SimpleTxIn
UTxOType SimpleTx
forall a. Monoid a => a
mempty (SimpleId -> UTxOType SimpleTx
utxoRef SimpleId
1)

          HeadState SimpleTx
sa <- Environment
-> Ledger SimpleTx
-> HeadState SimpleTx
-> StateT (StepState SimpleTx) IO (HeadState SimpleTx)
-> IO (HeadState SimpleTx)
forall (m :: * -> *) tx a.
Monad m =>
Environment
-> Ledger tx -> HeadState tx -> StateT (StepState tx) m a -> m a
runHeadLogic Environment
bobEnv Ledger SimpleTx
ledger HeadState SimpleTx
s0 (StateT (StepState SimpleTx) IO (HeadState SimpleTx)
 -> IO (HeadState SimpleTx))
-> StateT (StepState SimpleTx) IO (HeadState SimpleTx)
-> IO (HeadState 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) =>
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
$ Natural -> Party -> Message SimpleTx -> Input SimpleTx
forall tx. Natural -> Party -> Message tx -> Input tx
NetworkInput Natural
defaultTTL Party
alice (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 (HeadState SimpleTx)
forall tx (m :: * -> *).
MonadState (StepState tx) m =>
m (HeadState tx)
getState

          HeadState 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 :: HeadState SimpleTx
s0 = [Party] -> HeadState SimpleTx
inOpenState [Party]
threeParties
              t1 :: SimpleTx
t1 = SimpleId -> UTxOType SimpleTx -> UTxOType SimpleTx -> SimpleTx
SimpleTx SimpleId
1 Set SimpleTxIn
UTxOType SimpleTx
forall a. Monoid a => a
mempty (SimpleId -> UTxOType SimpleTx
utxoRef SimpleId
1)
              reqSn :: Input SimpleTx
reqSn = Natural -> Party -> Message SimpleTx -> Input SimpleTx
forall tx. Natural -> Party -> Message tx -> Input tx
NetworkInput Natural
defaultTTL Party
alice (Message SimpleTx -> Input SimpleTx)
-> Message SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ SnapshotNumber -> [TxIdType SimpleTx] -> Message SimpleTx
forall tx. SnapshotNumber -> [TxIdType tx] -> Message tx
ReqSn SnapshotNumber
1 [TxIdType SimpleTx
1]

          HeadState SimpleTx
s1 <- Environment
-> Ledger SimpleTx
-> HeadState SimpleTx
-> StateT (StepState SimpleTx) IO (HeadState SimpleTx)
-> IO (HeadState SimpleTx)
forall (m :: * -> *) tx a.
Monad m =>
Environment
-> Ledger tx -> HeadState tx -> StateT (StepState tx) m a -> m a
runHeadLogic Environment
bobEnv Ledger SimpleTx
ledger HeadState SimpleTx
s0 (StateT (StepState SimpleTx) IO (HeadState SimpleTx)
 -> IO (HeadState SimpleTx))
-> StateT (StepState SimpleTx) IO (HeadState SimpleTx)
-> IO (HeadState 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) =>
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
$ Natural -> Party -> Message SimpleTx -> Input SimpleTx
forall tx. Natural -> Party -> Message tx -> Input tx
NetworkInput Natural
defaultTTL Party
alice (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) =>
Input tx -> m (Outcome tx)
step Input SimpleTx
reqSn
            StateT (StepState SimpleTx) IO (HeadState SimpleTx)
forall tx (m :: * -> *).
MonadState (StepState tx) m =>
m (HeadState tx)
getState

          HeadState 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 SimpleTxIn
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 SimpleTxIn
UTxOType SimpleTx
forall a. Monoid a => a
mempty (SimpleId -> UTxOType SimpleTx
utxoRef SimpleId
2)
              reqSn :: Input SimpleTx
reqSn = Natural -> Party -> Message SimpleTx -> Input SimpleTx
forall tx. Natural -> Party -> Message tx -> Input tx
NetworkInput Natural
defaultTTL Party
alice (Message SimpleTx -> Input SimpleTx)
-> Message SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ SnapshotNumber -> [TxIdType SimpleTx] -> Message SimpleTx
forall tx. SnapshotNumber -> [TxIdType tx] -> Message tx
ReqSn SnapshotNumber
1 [TxIdType SimpleTx
1]
              snapshot1 :: Snapshot SimpleTx
snapshot1 = SnapshotNumber
-> UTxOType SimpleTx -> [TxIdType SimpleTx] -> Snapshot SimpleTx
forall tx.
SnapshotNumber -> UTxOType tx -> [TxIdType tx] -> Snapshot tx
testSnapshot SnapshotNumber
1 ([SimpleId] -> UTxOType SimpleTx
utxoRefs [SimpleId
1]) [TxIdType SimpleTx
1]
              ackFrom :: SigningKey HydraKey -> Party -> Input SimpleTx
ackFrom SigningKey HydraKey
sk Party
vk = Natural -> Party -> Message SimpleTx -> Input SimpleTx
forall tx. Natural -> Party -> Message tx -> Input tx
NetworkInput Natural
defaultTTL 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 (SigningKey HydraKey
-> Snapshot SimpleTx -> Signature (Snapshot SimpleTx)
forall a.
SignableRepresentation a =>
SigningKey HydraKey -> a -> Signature a
sign SigningKey HydraKey
sk Snapshot SimpleTx
snapshot1) SnapshotNumber
1

          HeadState SimpleTx
sa <- Environment
-> Ledger SimpleTx
-> HeadState SimpleTx
-> StateT (StepState SimpleTx) IO (HeadState SimpleTx)
-> IO (HeadState SimpleTx)
forall (m :: * -> *) tx a.
Monad m =>
Environment
-> Ledger tx -> HeadState tx -> StateT (StepState tx) m a -> m a
runHeadLogic Environment
bobEnv Ledger SimpleTx
ledger ([Party] -> HeadState SimpleTx
inOpenState [Party]
threeParties) (StateT (StepState SimpleTx) IO (HeadState SimpleTx)
 -> IO (HeadState SimpleTx))
-> StateT (StepState SimpleTx) IO (HeadState SimpleTx)
-> IO (HeadState 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) =>
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
$ Natural -> Party -> Message SimpleTx -> Input SimpleTx
forall tx. Natural -> Party -> Message tx -> Input tx
NetworkInput Natural
defaultTTL Party
alice (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) =>
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) =>
Input tx -> m (Outcome tx)
step (SigningKey HydraKey -> Party -> Input SimpleTx
ackFrom SigningKey HydraKey
carolSk Party
carol)
            Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx) =>
Input tx -> m (Outcome tx)
step (SigningKey HydraKey -> Party -> Input SimpleTx
ackFrom SigningKey HydraKey
aliceSk Party
alice)

            Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx) =>
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
$ Natural -> Party -> Message SimpleTx -> Input SimpleTx
forall tx. Natural -> Party -> Message tx -> Input tx
NetworkInput Natural
defaultTTL Party
alice (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) =>
Input tx -> m (Outcome tx)
step (SigningKey HydraKey -> Party -> Input SimpleTx
ackFrom SigningKey HydraKey
bobSk Party
bob)
            StateT (StepState SimpleTx) IO (HeadState SimpleTx)
forall tx (m :: * -> *).
MonadState (StepState tx) m =>
m (HeadState tx)
getState

          HeadState 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 = Natural -> Party -> Message tx -> Input tx
forall tx. Natural -> Party -> Message tx -> Input tx
NetworkInput Natural
defaultTTL Party
alice (Message tx -> Input tx) -> Message tx -> Input tx
forall a b. (a -> b) -> a -> b
$ SnapshotNumber -> [TxIdType tx] -> Message tx
forall tx. SnapshotNumber -> [TxIdType tx] -> Message tx
ReqSn SnapshotNumber
1 []
            snapshot :: Snapshot SimpleTx
snapshot = SnapshotNumber
-> UTxOType SimpleTx -> [TxIdType SimpleTx] -> Snapshot SimpleTx
forall tx.
SnapshotNumber -> UTxOType tx -> [TxIdType tx] -> Snapshot tx
testSnapshot SnapshotNumber
1 UTxOType SimpleTx
forall a. Monoid a => a
mempty []
            snapshot' :: Snapshot SimpleTx
snapshot' = SnapshotNumber
-> UTxOType SimpleTx -> [TxIdType SimpleTx] -> Snapshot SimpleTx
forall tx.
SnapshotNumber -> UTxOType tx -> [TxIdType tx] -> Snapshot tx
testSnapshot SnapshotNumber
2 UTxOType SimpleTx
forall a. Monoid a => a
mempty []
            ackFrom :: SigningKey HydraKey -> Party -> Input SimpleTx
ackFrom SigningKey HydraKey
sk Party
vk = Natural -> Party -> Message SimpleTx -> Input SimpleTx
forall tx. Natural -> Party -> Message tx -> Input tx
NetworkInput Natural
defaultTTL 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 (SigningKey HydraKey
-> Snapshot SimpleTx -> Signature (Snapshot SimpleTx)
forall a.
SignableRepresentation a =>
SigningKey HydraKey -> a -> Signature a
sign SigningKey HydraKey
sk Snapshot SimpleTx
snapshot) SnapshotNumber
1
            invalidAckFrom :: SigningKey HydraKey -> Party -> Input SimpleTx
invalidAckFrom SigningKey HydraKey
sk Party
vk = Natural -> Party -> Message SimpleTx -> Input SimpleTx
forall tx. Natural -> Party -> Message tx -> Input tx
NetworkInput Natural
defaultTTL 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 (SigningKey HydraKey
-> Snapshot SimpleTx -> Signature (Snapshot SimpleTx)
forall a.
SignableRepresentation a =>
SigningKey HydraKey -> a -> Signature a
sign SigningKey HydraKey
sk Snapshot SimpleTx
snapshot') SnapshotNumber
1
        HeadState SimpleTx
waitingForLastAck <-
          Environment
-> Ledger SimpleTx
-> HeadState SimpleTx
-> StateT (StepState SimpleTx) IO (HeadState SimpleTx)
-> IO (HeadState SimpleTx)
forall (m :: * -> *) tx a.
Monad m =>
Environment
-> Ledger tx -> HeadState tx -> StateT (StepState tx) m a -> m a
runHeadLogic Environment
bobEnv Ledger SimpleTx
ledger ([Party] -> HeadState SimpleTx
inOpenState [Party]
threeParties) (StateT (StepState SimpleTx) IO (HeadState SimpleTx)
 -> IO (HeadState SimpleTx))
-> StateT (StepState SimpleTx) IO (HeadState SimpleTx)
-> IO (HeadState 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) =>
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) =>
Input tx -> m (Outcome tx)
step (SigningKey HydraKey -> Party -> Input SimpleTx
ackFrom SigningKey HydraKey
carolSk Party
carol)
            Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx) =>
Input tx -> m (Outcome tx)
step (SigningKey HydraKey -> Party -> Input SimpleTx
ackFrom SigningKey HydraKey
aliceSk Party
alice)
            StateT (StepState SimpleTx) IO (HeadState SimpleTx)
forall tx (m :: * -> *).
MonadState (StepState tx) m =>
m (HeadState tx)
getState
        Environment
-> Ledger SimpleTx
-> HeadState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment -> Ledger tx -> HeadState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger HeadState SimpleTx
waitingForLastAck (SigningKey HydraKey -> Party -> Input SimpleTx
invalidAckFrom 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 = Natural -> Party -> Message tx -> Input tx
forall tx. Natural -> Party -> Message tx -> Input tx
NetworkInput Natural
defaultTTL Party
alice (Message tx -> Input tx) -> Message tx -> Input tx
forall a b. (a -> b) -> a -> b
$ SnapshotNumber -> [TxIdType tx] -> Message tx
forall tx. SnapshotNumber -> [TxIdType tx] -> Message tx
ReqSn SnapshotNumber
1 []
            snapshot :: Snapshot SimpleTx
snapshot = SnapshotNumber
-> UTxOType SimpleTx -> [TxIdType SimpleTx] -> Snapshot SimpleTx
forall tx.
SnapshotNumber -> UTxOType tx -> [TxIdType tx] -> Snapshot tx
testSnapshot SnapshotNumber
1 UTxOType SimpleTx
forall a. Monoid a => a
mempty []
            ackFrom :: SigningKey HydraKey -> Party -> Input SimpleTx
ackFrom SigningKey HydraKey
sk Party
vk = Natural -> Party -> Message SimpleTx -> Input SimpleTx
forall tx. Natural -> Party -> Message tx -> Input tx
NetworkInput Natural
defaultTTL 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 (SigningKey HydraKey
-> Snapshot SimpleTx -> Signature (Snapshot SimpleTx)
forall a.
SignableRepresentation a =>
SigningKey HydraKey -> a -> Signature a
sign SigningKey HydraKey
sk Snapshot SimpleTx
snapshot) SnapshotNumber
1
        HeadState SimpleTx
waitingForLastAck <-
          Environment
-> Ledger SimpleTx
-> HeadState SimpleTx
-> StateT (StepState SimpleTx) IO (HeadState SimpleTx)
-> IO (HeadState SimpleTx)
forall (m :: * -> *) tx a.
Monad m =>
Environment
-> Ledger tx -> HeadState tx -> StateT (StepState tx) m a -> m a
runHeadLogic Environment
bobEnv Ledger SimpleTx
ledger ([Party] -> HeadState SimpleTx
inOpenState [Party]
threeParties) (StateT (StepState SimpleTx) IO (HeadState SimpleTx)
 -> IO (HeadState SimpleTx))
-> StateT (StepState SimpleTx) IO (HeadState SimpleTx)
-> IO (HeadState 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) =>
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) =>
Input tx -> m (Outcome tx)
step (SigningKey HydraKey -> Party -> Input SimpleTx
ackFrom SigningKey HydraKey
carolSk Party
carol)
            Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx) =>
Input tx -> m (Outcome tx)
step (SigningKey HydraKey -> Party -> Input SimpleTx
ackFrom SigningKey HydraKey
aliceSk Party
alice)
            StateT (StepState SimpleTx) IO (HeadState SimpleTx)
forall tx (m :: * -> *).
MonadState (StepState tx) m =>
m (HeadState tx)
getState

        Environment
-> Ledger SimpleTx
-> HeadState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment -> Ledger tx -> HeadState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger HeadState SimpleTx
waitingForLastAck (SigningKey HydraKey -> Party -> Input SimpleTx
ackFrom (ByteString -> 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 = Natural -> Party -> Message tx -> Input tx
forall tx. Natural -> Party -> Message tx -> Input tx
NetworkInput Natural
defaultTTL Party
alice (Message tx -> Input tx) -> Message tx -> Input tx
forall a b. (a -> b) -> a -> b
$ SnapshotNumber -> [TxIdType tx] -> Message tx
forall tx. SnapshotNumber -> [TxIdType tx] -> Message tx
ReqSn SnapshotNumber
1 []
            snapshot1 :: Snapshot SimpleTx
snapshot1 = SnapshotNumber
-> UTxOType SimpleTx -> [TxIdType SimpleTx] -> Snapshot SimpleTx
forall tx.
SnapshotNumber -> UTxOType tx -> [TxIdType tx] -> Snapshot tx
testSnapshot SnapshotNumber
1 UTxOType SimpleTx
forall a. Monoid a => a
mempty []
            ackFrom :: SigningKey HydraKey -> Party -> Input SimpleTx
ackFrom SigningKey HydraKey
sk Party
vk = Natural -> Party -> Message SimpleTx -> Input SimpleTx
forall tx. Natural -> Party -> Message tx -> Input tx
NetworkInput Natural
defaultTTL 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 (SigningKey HydraKey
-> Snapshot SimpleTx -> Signature (Snapshot SimpleTx)
forall a.
SignableRepresentation a =>
SigningKey HydraKey -> a -> Signature a
sign SigningKey HydraKey
sk Snapshot SimpleTx
snapshot1) SnapshotNumber
1
            invalidAckFrom :: SigningKey HydraKey -> Party -> Input tx
invalidAckFrom SigningKey HydraKey
sk Party
vk =
              Natural -> Party -> Message tx -> Input tx
forall tx. Natural -> Party -> Message tx -> Input tx
NetworkInput Natural
defaultTTL Party
vk (Message tx -> Input tx) -> Message tx -> Input tx
forall a b. (a -> b) -> a -> b
$
                Signature (Snapshot tx) -> SnapshotNumber -> Message tx
forall tx. Signature (Snapshot tx) -> SnapshotNumber -> Message tx
AckSn (Signature ByteString -> Signature (Snapshot tx)
forall a b. Coercible a b => a -> b
coerce (Signature ByteString -> Signature (Snapshot tx))
-> Signature ByteString -> Signature (Snapshot tx)
forall a b. (a -> b) -> a -> b
$ SigningKey HydraKey -> ByteString -> Signature ByteString
forall a.
SignableRepresentation a =>
SigningKey HydraKey -> a -> Signature a
sign SigningKey HydraKey
sk (ByteString
"foo" :: ByteString)) SnapshotNumber
1
        HeadState SimpleTx
waitingForLastAck <-
          Environment
-> Ledger SimpleTx
-> HeadState SimpleTx
-> StateT (StepState SimpleTx) IO (HeadState SimpleTx)
-> IO (HeadState SimpleTx)
forall (m :: * -> *) tx a.
Monad m =>
Environment
-> Ledger tx -> HeadState tx -> StateT (StepState tx) m a -> m a
runHeadLogic Environment
bobEnv Ledger SimpleTx
ledger ([Party] -> HeadState SimpleTx
inOpenState [Party]
threeParties) (StateT (StepState SimpleTx) IO (HeadState SimpleTx)
 -> IO (HeadState SimpleTx))
-> StateT (StepState SimpleTx) IO (HeadState SimpleTx)
-> IO (HeadState 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) =>
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) =>
Input tx -> m (Outcome tx)
step (SigningKey HydraKey -> Party -> Input SimpleTx
ackFrom SigningKey HydraKey
carolSk Party
carol)
            Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx) =>
Input tx -> m (Outcome tx)
step (SigningKey HydraKey -> Party -> Input SimpleTx
forall {tx}. SigningKey HydraKey -> Party -> Input tx
invalidAckFrom SigningKey HydraKey
bobSk Party
bob)
            StateT (StepState SimpleTx) IO (HeadState SimpleTx)
forall tx (m :: * -> *).
MonadState (StepState tx) m =>
m (HeadState tx)
getState

        Environment
-> Ledger SimpleTx
-> HeadState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment -> Ledger tx -> HeadState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger HeadState SimpleTx
waitingForLastAck (SigningKey HydraKey -> Party -> Input SimpleTx
ackFrom 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 = Natural -> Party -> Message tx -> Input tx
forall tx. Natural -> Party -> Message tx -> Input tx
NetworkInput Natural
defaultTTL Party
alice (Message tx -> Input tx) -> Message tx -> Input tx
forall a b. (a -> b) -> a -> b
$ SnapshotNumber -> [TxIdType tx] -> Message tx
forall tx. SnapshotNumber -> [TxIdType tx] -> Message tx
ReqSn SnapshotNumber
1 []
            snapshot1 :: Snapshot SimpleTx
snapshot1 = SnapshotNumber
-> UTxOType SimpleTx -> [TxIdType SimpleTx] -> Snapshot SimpleTx
forall tx.
SnapshotNumber -> UTxOType tx -> [TxIdType tx] -> Snapshot tx
testSnapshot SnapshotNumber
1 UTxOType SimpleTx
forall a. Monoid a => a
mempty []
            ackFrom :: SigningKey HydraKey -> Party -> Input SimpleTx
ackFrom SigningKey HydraKey
sk Party
vk = Natural -> Party -> Message SimpleTx -> Input SimpleTx
forall tx. Natural -> Party -> Message tx -> Input tx
NetworkInput Natural
defaultTTL 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 (SigningKey HydraKey
-> Snapshot SimpleTx -> Signature (Snapshot SimpleTx)
forall a.
SignableRepresentation a =>
SigningKey HydraKey -> a -> Signature a
sign SigningKey HydraKey
sk Snapshot SimpleTx
snapshot1) SnapshotNumber
1
        HeadState SimpleTx
waitingForAck <-
          Environment
-> Ledger SimpleTx
-> HeadState SimpleTx
-> StateT (StepState SimpleTx) IO (HeadState SimpleTx)
-> IO (HeadState SimpleTx)
forall (m :: * -> *) tx a.
Monad m =>
Environment
-> Ledger tx -> HeadState tx -> StateT (StepState tx) m a -> m a
runHeadLogic Environment
bobEnv Ledger SimpleTx
ledger ([Party] -> HeadState SimpleTx
inOpenState [Party]
threeParties) (StateT (StepState SimpleTx) IO (HeadState SimpleTx)
 -> IO (HeadState SimpleTx))
-> StateT (StepState SimpleTx) IO (HeadState SimpleTx)
-> IO (HeadState 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) =>
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) =>
Input tx -> m (Outcome tx)
step (SigningKey HydraKey -> Party -> Input SimpleTx
ackFrom SigningKey HydraKey
carolSk Party
carol)
            StateT (StepState SimpleTx) IO (HeadState SimpleTx)
forall tx (m :: * -> *).
MonadState (StepState tx) m =>
m (HeadState tx)
getState

        Environment
-> Ledger SimpleTx
-> HeadState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment -> Ledger tx -> HeadState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger HeadState SimpleTx
waitingForAck (SigningKey HydraKey -> Party -> Input SimpleTx
ackFrom 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
"waits if we receive a snapshot with transaction not applicable on previous snapshot" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        let reqTx42 :: Input SimpleTx
reqTx42 = Natural -> Party -> Message SimpleTx -> Input SimpleTx
forall tx. Natural -> Party -> Message tx -> Input tx
NetworkInput Natural
defaultTTL Party
alice (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 SimpleTxIn
UTxOType SimpleTx
forall a. Monoid a => a
mempty (SimpleId -> UTxOType SimpleTx
utxoRef SimpleId
1))
            reqTx1 :: Input SimpleTx
reqTx1 = Natural -> Party -> Message SimpleTx -> Input SimpleTx
forall tx. Natural -> Party -> Message tx -> Input tx
NetworkInput Natural
defaultTTL Party
alice (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 = Natural -> Party -> Message SimpleTx -> Input SimpleTx
forall tx. Natural -> Party -> Message tx -> Input tx
NetworkInput Natural
defaultTTL Party
alice (Message SimpleTx -> Input SimpleTx)
-> Message SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ SnapshotNumber -> [TxIdType SimpleTx] -> Message SimpleTx
forall tx. SnapshotNumber -> [TxIdType tx] -> Message tx
ReqSn SnapshotNumber
1 [TxIdType SimpleTx
1]
            s0 :: HeadState SimpleTx
s0 = [Party] -> HeadState SimpleTx
inOpenState [Party]
threeParties

        HeadState SimpleTx
s2 <- Environment
-> Ledger SimpleTx
-> HeadState SimpleTx
-> StateT (StepState SimpleTx) IO (HeadState SimpleTx)
-> IO (HeadState SimpleTx)
forall (m :: * -> *) tx a.
Monad m =>
Environment
-> Ledger tx -> HeadState tx -> StateT (StepState tx) m a -> m a
runHeadLogic Environment
bobEnv Ledger SimpleTx
ledger HeadState SimpleTx
s0 (StateT (StepState SimpleTx) IO (HeadState SimpleTx)
 -> IO (HeadState SimpleTx))
-> StateT (StepState SimpleTx) IO (HeadState SimpleTx)
-> IO (HeadState 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) =>
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) =>
Input tx -> m (Outcome tx)
step Input SimpleTx
reqTx1
          StateT (StepState SimpleTx) IO (HeadState SimpleTx)
forall tx (m :: * -> *).
MonadState (StepState tx) m =>
m (HeadState tx)
getState

        Environment
-> Ledger SimpleTx
-> HeadState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment -> Ledger tx -> HeadState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger HeadState 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
"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 :: HeadState SimpleTx
s0 = [Party] -> HeadState SimpleTx
inOpenState [Party]
threeParties
            reqSn :: Input SimpleTx
reqSn = Natural -> Party -> Message SimpleTx -> Input SimpleTx
forall tx. Natural -> Party -> Message tx -> Input tx
NetworkInput Natural
defaultTTL Party
alice (Message SimpleTx -> Input SimpleTx)
-> Message SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ SnapshotNumber -> [TxIdType SimpleTx] -> Message SimpleTx
forall tx. SnapshotNumber -> [TxIdType tx] -> Message tx
ReqSn SnapshotNumber
1 [TxIdType SimpleTx
1]
        Environment
-> Ledger SimpleTx
-> HeadState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment -> Ledger tx -> HeadState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger HeadState 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
-> UTxOType SimpleTx -> [TxIdType SimpleTx] -> Snapshot SimpleTx
forall tx.
SnapshotNumber -> UTxOType tx -> [TxIdType tx] -> Snapshot tx
testSnapshot SnapshotNumber
1 UTxOType SimpleTx
forall a. Monoid a => a
mempty []
            input :: Input SimpleTx
input = Natural -> Party -> Message SimpleTx -> Input SimpleTx
forall tx. Natural -> Party -> Message tx -> Input tx
NetworkInput Natural
defaultTTL 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 (SigningKey HydraKey
-> Snapshot SimpleTx -> Signature (Snapshot SimpleTx)
forall a.
SignableRepresentation a =>
SigningKey HydraKey -> a -> Signature a
sign SigningKey HydraKey
aliceSk Snapshot SimpleTx
snapshot) SnapshotNumber
1
        Environment
-> Ledger SimpleTx
-> HeadState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment -> Ledger tx -> HeadState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger ([Party] -> HeadState SimpleTx
inOpenState [Party]
threeParties) 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 = Natural -> Party -> Message tx -> Input tx
forall tx. Natural -> Party -> Message tx -> Input tx
NetworkInput Natural
defaultTTL Party
bob (Message tx -> Input tx) -> Message tx -> Input tx
forall a b. (a -> b) -> a -> b
$ SnapshotNumber -> [TxIdType tx] -> Message tx
forall tx. SnapshotNumber -> [TxIdType tx] -> Message tx
ReqSn SnapshotNumber
2 []
            st :: HeadState SimpleTx
st = [Party] -> HeadState SimpleTx
inOpenState [Party]
threeParties
        Environment
-> Ledger SimpleTx
-> HeadState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment -> Ledger tx -> HeadState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger HeadState 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 = Natural -> Party -> Message tx -> Input tx
forall tx. Natural -> Party -> Message tx -> Input tx
NetworkInput Natural
defaultTTL Party
alice (Message tx -> Input tx) -> Message tx -> Input tx
forall a b. (a -> b) -> a -> b
$ SnapshotNumber -> [TxIdType tx] -> Message tx
forall tx. SnapshotNumber -> [TxIdType tx] -> Message tx
ReqSn SnapshotNumber
1 []
            reqSn2 :: Input tx
reqSn2 = Natural -> Party -> Message tx -> Input tx
forall tx. Natural -> Party -> Message tx -> Input tx
NetworkInput Natural
defaultTTL Party
bob (Message tx -> Input tx) -> Message tx -> Input tx
forall a b. (a -> b) -> a -> b
$ SnapshotNumber -> [TxIdType tx] -> Message tx
forall tx. SnapshotNumber -> [TxIdType tx] -> Message tx
ReqSn SnapshotNumber
2 []
        HeadState SimpleTx
st <-
          Environment
-> Ledger SimpleTx
-> HeadState SimpleTx
-> StateT (StepState SimpleTx) IO (HeadState SimpleTx)
-> IO (HeadState SimpleTx)
forall (m :: * -> *) tx a.
Monad m =>
Environment
-> Ledger tx -> HeadState tx -> StateT (StepState tx) m a -> m a
runHeadLogic Environment
bobEnv Ledger SimpleTx
ledger ([Party] -> HeadState SimpleTx
inOpenState [Party]
threeParties) (StateT (StepState SimpleTx) IO (HeadState SimpleTx)
 -> IO (HeadState SimpleTx))
-> StateT (StepState SimpleTx) IO (HeadState SimpleTx)
-> IO (HeadState 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) =>
Input tx -> m (Outcome tx)
step Input SimpleTx
forall {tx}. Input tx
reqSn1
            StateT (StepState SimpleTx) IO (HeadState SimpleTx)
forall tx (m :: * -> *).
MonadState (StepState tx) m =>
m (HeadState tx)
getState

        Environment
-> Ledger SimpleTx
-> HeadState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment -> Ledger tx -> HeadState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger HeadState 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
-> UTxOType SimpleTx -> [TxIdType SimpleTx] -> Snapshot SimpleTx
forall tx.
SnapshotNumber -> UTxOType tx -> [TxIdType tx] -> Snapshot tx
testSnapshot SnapshotNumber
1 UTxOType SimpleTx
forall a. Monoid a => a
mempty []
            input :: Input SimpleTx
input = Natural -> Party -> Message SimpleTx -> Input SimpleTx
forall tx. Natural -> Party -> Message tx -> Input tx
NetworkInput Natural
defaultTTL Party
leader (Message SimpleTx -> Input SimpleTx)
-> Message SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ SnapshotNumber -> [TxIdType SimpleTx] -> Message SimpleTx
forall tx. SnapshotNumber -> [TxIdType tx] -> Message tx
ReqSn (Snapshot SimpleTx -> SnapshotNumber
forall tx. Snapshot tx -> SnapshotNumber
number Snapshot SimpleTx
snapshot) []
            sig :: Signature (Snapshot SimpleTx)
sig = SigningKey HydraKey
-> Snapshot SimpleTx -> Signature (Snapshot SimpleTx)
forall a.
SignableRepresentation a =>
SigningKey HydraKey -> a -> Signature a
sign SigningKey HydraKey
bobSk Snapshot SimpleTx
snapshot
            st :: HeadState SimpleTx
st = [Party] -> HeadState 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)
        Environment
-> Ledger SimpleTx
-> HeadState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment -> Ledger tx -> HeadState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger HeadState 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 = Natural -> Party -> Message tx -> Input tx
forall tx. Natural -> Party -> Message tx -> Input tx
NetworkInput Natural
defaultTTL Party
notTheLeader (Message tx -> Input tx) -> Message tx -> Input tx
forall a b. (a -> b) -> a -> b
$ SnapshotNumber -> [TxIdType tx] -> Message tx
forall tx. SnapshotNumber -> [TxIdType tx] -> Message tx
ReqSn SnapshotNumber
1 []
            notTheLeader :: Party
notTheLeader = Party
bob
            st :: HeadState SimpleTx
st = [Party] -> HeadState SimpleTx
inOpenState [Party]
threeParties
        Environment
-> Ledger SimpleTx
-> HeadState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment -> Ledger tx -> HeadState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger HeadState 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 = Natural -> Party -> Message tx -> Input tx
forall tx. Natural -> Party -> Message tx -> Input tx
NetworkInput Natural
defaultTTL Party
theLeader (Message tx -> Input tx) -> Message tx -> Input tx
forall a b. (a -> b) -> a -> b
$ SnapshotNumber -> [TxIdType tx] -> Message tx
forall tx. SnapshotNumber -> [TxIdType tx] -> Message tx
ReqSn SnapshotNumber
2 []
            theLeader :: Party
theLeader = Party
alice
            snapshot :: Snapshot SimpleTx
snapshot = SnapshotNumber
-> UTxOType SimpleTx -> [TxIdType SimpleTx] -> Snapshot SimpleTx
forall tx.
SnapshotNumber -> UTxOType tx -> [TxIdType tx] -> Snapshot tx
testSnapshot SnapshotNumber
2 UTxOType SimpleTx
forall a. Monoid a => a
mempty []
            st :: HeadState SimpleTx
st =
              [Party] -> CoordinatedHeadState SimpleTx -> HeadState SimpleTx
inOpenState' [Party]
threeParties (CoordinatedHeadState SimpleTx -> HeadState SimpleTx)
-> CoordinatedHeadState SimpleTx -> HeadState SimpleTx
forall a b. (a -> b) -> a -> b
$
                CoordinatedHeadState SimpleTx
coordinatedHeadState{confirmedSnapshot = ConfirmedSnapshot snapshot (Crypto.aggregate [])}
        Environment
-> Ledger SimpleTx
-> HeadState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment -> Ledger tx -> HeadState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger HeadState 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 = Natural -> Party -> Message tx -> Input tx
forall tx. Natural -> Party -> Message tx -> Input tx
NetworkInput Natural
defaultTTL Party
theLeader (Message tx -> Input tx) -> Message tx -> Input tx
forall a b. (a -> b) -> a -> b
$ SnapshotNumber -> [TxIdType tx] -> Message tx
forall tx. SnapshotNumber -> [TxIdType tx] -> Message tx
ReqSn SnapshotNumber
2 []
            theLeader :: Party
theLeader = Party
alice
            snapshot :: Snapshot SimpleTx
snapshot = SnapshotNumber
-> UTxOType SimpleTx -> [TxIdType SimpleTx] -> Snapshot SimpleTx
forall tx.
SnapshotNumber -> UTxOType tx -> [TxIdType tx] -> Snapshot tx
testSnapshot SnapshotNumber
2 UTxOType SimpleTx
forall a. Monoid a => a
mempty []
            st :: HeadState SimpleTx
st =
              [Party] -> CoordinatedHeadState SimpleTx -> HeadState SimpleTx
inOpenState' [Party]
threeParties (CoordinatedHeadState SimpleTx -> HeadState SimpleTx)
-> CoordinatedHeadState SimpleTx -> HeadState SimpleTx
forall a b. (a -> b) -> a -> b
$
                CoordinatedHeadState SimpleTx
coordinatedHeadState
                  { confirmedSnapshot = ConfirmedSnapshot snapshot (Crypto.aggregate [])
                  , seenSnapshot = SeenSnapshot (testSnapshot 3 mempty []) mempty
                  }
        Environment
-> Ledger SimpleTx
-> HeadState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment -> Ledger tx -> HeadState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger HeadState 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 = Natural -> Party -> Message tx -> Input tx
forall tx. Natural -> Party -> Message tx -> Input tx
NetworkInput Natural
defaultTTL Party
theLeader (Message tx -> Input tx) -> Message tx -> Input tx
forall a b. (a -> b) -> a -> b
$ SnapshotNumber -> [TxIdType tx] -> Message tx
forall tx. SnapshotNumber -> [TxIdType tx] -> Message tx
ReqSn SnapshotNumber
3 []
            theLeader :: Party
theLeader = Party
carol
            st :: HeadState SimpleTx
st = [Party] -> HeadState SimpleTx
inOpenState [Party]
threeParties
        Environment
-> Ledger SimpleTx
-> HeadState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment -> Ledger tx -> HeadState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger HeadState 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
"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 = Natural -> Party -> Message SimpleTx -> Input SimpleTx
forall tx. Natural -> Party -> Message tx -> Input tx
NetworkInput Natural
defaultTTL Party
alice (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 = Natural -> Party -> Message SimpleTx -> Input SimpleTx
forall tx. Natural -> Party -> Message tx -> Input tx
NetworkInput Natural
defaultTTL Party
theLeader (Message SimpleTx -> Input SimpleTx)
-> Message SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ SnapshotNumber -> [TxIdType SimpleTx] -> Message SimpleTx
forall tx. SnapshotNumber -> [TxIdType tx] -> Message tx
ReqSn SnapshotNumber
nextSN [TxIdType SimpleTx
42]
            secondReqTx :: Input SimpleTx
secondReqTx = Natural -> Party -> Message SimpleTx -> Input SimpleTx
forall tx. Natural -> Party -> Message tx -> Input tx
NetworkInput Natural
defaultTTL Party
alice (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 = Natural -> Party -> Message SimpleTx -> Input SimpleTx
forall tx. Natural -> Party -> Message tx -> Input tx
NetworkInput Natural
defaultTTL Party
theLeader (Message SimpleTx -> Input SimpleTx)
-> Message SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ SnapshotNumber -> [TxIdType SimpleTx] -> Message SimpleTx
forall tx. SnapshotNumber -> [TxIdType tx] -> Message tx
ReqSn SnapshotNumber
nextSN [SimpleId
TxIdType SimpleTx
51]

        HeadState SimpleTx
s3 <- Environment
-> Ledger SimpleTx
-> HeadState SimpleTx
-> StateT (StepState SimpleTx) IO (HeadState SimpleTx)
-> IO (HeadState SimpleTx)
forall (m :: * -> *) tx a.
Monad m =>
Environment
-> Ledger tx -> HeadState tx -> StateT (StepState tx) m a -> m a
runHeadLogic Environment
bobEnv Ledger SimpleTx
ledger ([Party] -> HeadState SimpleTx
inOpenState [Party]
threeParties) (StateT (StepState SimpleTx) IO (HeadState SimpleTx)
 -> IO (HeadState SimpleTx))
-> StateT (StepState SimpleTx) IO (HeadState SimpleTx)
-> IO (HeadState 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) =>
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) =>
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) =>
Input tx -> m (Outcome tx)
step Input SimpleTx
secondReqTx
          StateT (StepState SimpleTx) IO (HeadState SimpleTx)
forall tx (m :: * -> *).
MonadState (StepState tx) m =>
m (HeadState tx)
getState

        Environment
-> Ledger SimpleTx
-> HeadState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment -> Ledger tx -> HeadState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger HeadState 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
"ignores in-flight ReqTx when closed" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        let s0 :: HeadState SimpleTx
s0 = [Party] -> HeadState SimpleTx
inClosedState [Party]
threeParties
            input :: Input SimpleTx
input = Natural -> Party -> Message SimpleTx -> Input SimpleTx
forall tx. Natural -> Party -> Message tx -> Input tx
NetworkInput Natural
defaultTTL Party
alice (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)
        Environment
-> Ledger SimpleTx
-> HeadState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment -> Ledger tx -> HeadState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger HeadState 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 HeadState SimpleTx
s0)

      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"everyone does collect on last commit after collect com" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        let aliceCommit :: OnChainTx SimpleTx
aliceCommit = HeadId -> Party -> UTxOType SimpleTx -> OnChainTx SimpleTx
forall tx. HeadId -> Party -> UTxOType tx -> OnChainTx tx
OnCommitTx HeadId
testHeadId Party
alice (SimpleId -> UTxOType SimpleTx
utxoRef SimpleId
1)
            bobCommit :: OnChainTx SimpleTx
bobCommit = HeadId -> Party -> UTxOType SimpleTx -> OnChainTx SimpleTx
forall tx. HeadId -> Party -> UTxOType tx -> OnChainTx tx
OnCommitTx HeadId
testHeadId Party
bob (SimpleId -> UTxOType SimpleTx
utxoRef SimpleId
2)
            carolCommit :: OnChainTx SimpleTx
carolCommit = HeadId -> Party -> UTxOType SimpleTx -> OnChainTx SimpleTx
forall tx. HeadId -> Party -> UTxOType tx -> OnChainTx tx
OnCommitTx HeadId
testHeadId Party
carol (SimpleId -> UTxOType SimpleTx
utxoRef SimpleId
3)
        HeadState SimpleTx
waitingForLastCommit <-
          Environment
-> Ledger SimpleTx
-> HeadState SimpleTx
-> StateT (StepState SimpleTx) IO (HeadState SimpleTx)
-> IO (HeadState SimpleTx)
forall (m :: * -> *) tx a.
Monad m =>
Environment
-> Ledger tx -> HeadState tx -> StateT (StepState tx) m a -> m a
runHeadLogic Environment
bobEnv Ledger SimpleTx
ledger ([Party] -> HeadState SimpleTx
inInitialState [Party]
threeParties) (StateT (StepState SimpleTx) IO (HeadState SimpleTx)
 -> IO (HeadState SimpleTx))
-> StateT (StepState SimpleTx) IO (HeadState SimpleTx)
-> IO (HeadState 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) =>
Input tx -> m (Outcome tx)
step (Natural -> OnChainTx SimpleTx -> Input SimpleTx
observeTxAtSlot Natural
1 OnChainTx SimpleTx
aliceCommit)
            Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx) =>
Input tx -> m (Outcome tx)
step (Natural -> OnChainTx SimpleTx -> Input SimpleTx
observeTxAtSlot Natural
2 OnChainTx SimpleTx
bobCommit)
            StateT (StepState SimpleTx) IO (HeadState SimpleTx)
forall tx (m :: * -> *).
MonadState (StepState tx) m =>
m (HeadState tx)
getState

        -- Bob is not the last party, but still does post a collect
        Environment
-> Ledger SimpleTx
-> HeadState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment -> Ledger tx -> HeadState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger HeadState SimpleTx
waitingForLastCommit (Natural -> OnChainTx SimpleTx -> Input SimpleTx
observeTxAtSlot Natural
3 OnChainTx SimpleTx
carolCommit)
          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 = CollectComTx{}} -> Bool
True
            Effect SimpleTx
_ -> Bool
False

      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"cannot observe abort after collect com" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        HeadState SimpleTx
afterCollectCom <-
          Environment
-> Ledger SimpleTx
-> HeadState SimpleTx
-> StateT (StepState SimpleTx) IO (HeadState SimpleTx)
-> IO (HeadState SimpleTx)
forall (m :: * -> *) tx a.
Monad m =>
Environment
-> Ledger tx -> HeadState tx -> StateT (StepState tx) m a -> m a
runHeadLogic Environment
bobEnv Ledger SimpleTx
ledger ([Party] -> HeadState SimpleTx
inInitialState [Party]
threeParties) (StateT (StepState SimpleTx) IO (HeadState SimpleTx)
 -> IO (HeadState SimpleTx))
-> StateT (StepState SimpleTx) IO (HeadState SimpleTx)
-> IO (HeadState 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) =>
Input tx -> m (Outcome tx)
step (OnChainTx SimpleTx -> Input SimpleTx
observeTx (OnChainTx SimpleTx -> Input SimpleTx)
-> OnChainTx SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ HeadId -> OnChainTx SimpleTx
forall tx. HeadId -> OnChainTx tx
OnCollectComTx HeadId
testHeadId)
            StateT (StepState SimpleTx) IO (HeadState SimpleTx)
forall tx (m :: * -> *).
MonadState (StepState tx) m =>
m (HeadState tx)
getState

        let unhandledInput :: Input SimpleTx
unhandledInput = OnChainTx SimpleTx -> Input SimpleTx
observeTx OnAbortTx{$sel:headId:OnInitTx :: HeadId
headId = HeadId
testHeadId}
        Environment
-> Ledger SimpleTx
-> HeadState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment -> Ledger tx -> HeadState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger HeadState SimpleTx
afterCollectCom Input SimpleTx
unhandledInput
          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
unhandledInput HeadState SimpleTx
afterCollectCom)

      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"cannot observe collect com after abort" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        HeadState SimpleTx
afterAbort <-
          Environment
-> Ledger SimpleTx
-> HeadState SimpleTx
-> StateT (StepState SimpleTx) IO (HeadState SimpleTx)
-> IO (HeadState SimpleTx)
forall (m :: * -> *) tx a.
Monad m =>
Environment
-> Ledger tx -> HeadState tx -> StateT (StepState tx) m a -> m a
runHeadLogic Environment
bobEnv Ledger SimpleTx
ledger ([Party] -> HeadState SimpleTx
inInitialState [Party]
threeParties) (StateT (StepState SimpleTx) IO (HeadState SimpleTx)
 -> IO (HeadState SimpleTx))
-> StateT (StepState SimpleTx) IO (HeadState SimpleTx)
-> IO (HeadState 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) =>
Input tx -> m (Outcome tx)
step (OnChainTx SimpleTx -> Input SimpleTx
observeTx OnAbortTx{$sel:headId:OnInitTx :: HeadId
headId = HeadId
testHeadId})
            StateT (StepState SimpleTx) IO (HeadState SimpleTx)
forall tx (m :: * -> *).
MonadState (StepState tx) m =>
m (HeadState tx)
getState

        let unhandledInput :: Input SimpleTx
unhandledInput = OnChainTx SimpleTx -> Input SimpleTx
observeTx (HeadId -> OnChainTx SimpleTx
forall tx. HeadId -> OnChainTx tx
OnCollectComTx HeadId
testHeadId)
        Environment
-> Ledger SimpleTx
-> HeadState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment -> Ledger tx -> HeadState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger HeadState SimpleTx
afterAbort Input SimpleTx
unhandledInput
          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
unhandledInput HeadState SimpleTx
afterAbort)

      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 :: HeadState SimpleTx
s0 = [Party] -> HeadState 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
                  }
            clientEffect :: Effect SimpleTx
clientEffect = ServerOutput SimpleTx -> Effect SimpleTx
forall tx. ServerOutput tx -> Effect tx
ClientEffect HeadIsClosed{$sel:headId:PeerConnected :: HeadId
headId = HeadId
testHeadId, SnapshotNumber
snapshotNumber :: SnapshotNumber
$sel:snapshotNumber:PeerConnected :: SnapshotNumber
snapshotNumber, UTCTime
contestationDeadline :: UTCTime
$sel:contestationDeadline:PeerConnected :: UTCTime
contestationDeadline}
        Environment
-> Ledger SimpleTx
-> HeadState SimpleTx
-> StateT (StepState SimpleTx) IO ()
-> IO ()
forall (m :: * -> *) tx a.
Monad m =>
Environment
-> Ledger tx -> HeadState tx -> StateT (StepState tx) m a -> m a
runHeadLogic Environment
bobEnv Ledger SimpleTx
ledger HeadState 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) =>
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 -> Effect SimpleTx -> IO ()
forall tx.
(HasCallStack, IsChainState tx) =>
Outcome tx -> Effect tx -> IO ()
`hasEffect` Effect SimpleTx
clientEffect
            Outcome SimpleTx
outcome1
              Outcome SimpleTx -> (Effect SimpleTx -> Bool) -> IO ()
forall tx.
(HasCallStack, IsChainState tx) =>
Outcome tx -> (Effect tx -> Bool) -> IO ()
`hasNoEffectSatisfying` \case
                ClientEffect (ReadyToFanout HeadId
_) -> Bool
True
                Effect SimpleTx
_ -> Bool
False

          let oneSecondsPastDeadline :: UTCTime
oneSecondsPastDeadline = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
1 UTCTime
contestationDeadline
              someChainSlot :: ChainSlot
someChainSlot = Gen ChainSlot
forall a. Arbitrary a => Gen a
arbitrary Gen ChainSlot -> Int -> ChainSlot
forall a. Gen a -> Int -> a
`generateWith` Int
42
              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 -> ChainSlot -> ChainEvent SimpleTx
forall tx. UTCTime -> ChainSlot -> ChainEvent tx
Tick UTCTime
oneSecondsPastDeadline ChainSlot
someChainSlot
          Outcome SimpleTx
outcome2 <- Input SimpleTx -> StateT (StepState SimpleTx) IO (Outcome SimpleTx)
forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx) =>
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 -> Effect SimpleTx -> IO ()
forall tx.
(HasCallStack, IsChainState tx) =>
Outcome tx -> Effect tx -> IO ()
`hasEffect` ServerOutput SimpleTx -> Effect SimpleTx
forall tx. ServerOutput tx -> Effect tx
ClientEffect (HeadId -> ServerOutput SimpleTx
forall tx. HeadId -> ServerOutput tx
ReadyToFanout HeadId
testHeadId)

      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 snapshot :: Snapshot SimpleTx
snapshot = SnapshotNumber
-> UTxOType SimpleTx -> [TxIdType SimpleTx] -> Snapshot SimpleTx
forall tx.
SnapshotNumber -> UTxOType tx -> [TxIdType tx] -> Snapshot tx
testSnapshot SnapshotNumber
2 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 {k} (a :: k). [Signature a] -> MultiSignature a
Crypto.aggregate [])
            s0 :: HeadState SimpleTx
s0 =
              [Party] -> CoordinatedHeadState SimpleTx -> HeadState SimpleTx
inOpenState' [Party]
threeParties (CoordinatedHeadState SimpleTx -> HeadState SimpleTx)
-> CoordinatedHeadState SimpleTx -> HeadState 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 -> [Party] -> HeadParameters
HeadParameters ContestationPeriod
defaultContestationPeriod [Party]
threeParties) (HeadState SimpleTx -> Maybe HeadParameters
forall tx. HeadState tx -> Maybe HeadParameters
getHeadParameters HeadState SimpleTx
s0)
        Environment
-> Ledger SimpleTx
-> HeadState SimpleTx
-> StateT (StepState SimpleTx) IO ()
-> IO ()
forall (m :: * -> *) tx a.
Monad m =>
Environment
-> Ledger tx -> HeadState tx -> StateT (StepState tx) m a -> m a
runHeadLogic Environment
bobEnv Ledger SimpleTx
ledger HeadState 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) =>
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
-> ConfirmedSnapshot SimpleTx
-> PostChainTx SimpleTx
forall tx.
HeadId -> HeadParameters -> ConfirmedSnapshot tx -> PostChainTx tx
ContestTx HeadId
testHeadId HeadParameters
params ConfirmedSnapshot SimpleTx
latestConfirmedSnapshot)
          HeadState SimpleTx
s1 <- StateT (StepState SimpleTx) IO (HeadState SimpleTx)
forall tx (m :: * -> *).
MonadState (StepState tx) m =>
m (HeadState 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
$
            HeadState 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 snapshot2 :: Snapshot SimpleTx
snapshot2 = SnapshotNumber
-> UTxOType SimpleTx -> [TxIdType SimpleTx] -> Snapshot SimpleTx
forall tx.
SnapshotNumber -> UTxOType tx -> [TxIdType tx] -> Snapshot tx
testSnapshot SnapshotNumber
2 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 {k} (a :: k). [Signature a] -> MultiSignature a
Crypto.aggregate [])
            s0 :: HeadState SimpleTx
s0 = [Party] -> ConfirmedSnapshot SimpleTx -> HeadState 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 -> [Party] -> HeadParameters
HeadParameters ContestationPeriod
defaultContestationPeriod [Party]
threeParties) (HeadState SimpleTx -> Maybe HeadParameters
forall tx. HeadState tx -> Maybe HeadParameters
getHeadParameters HeadState SimpleTx
s0)
        Environment
-> Ledger SimpleTx
-> HeadState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment -> Ledger tx -> HeadState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger HeadState 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
-> ConfirmedSnapshot SimpleTx
-> PostChainTx SimpleTx
forall tx.
HeadId -> HeadParameters -> ConfirmedSnapshot tx -> PostChainTx tx
ContestTx HeadId
testHeadId HeadParameters
params 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 -> (HeadId -> IO ()) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"ignores abortTx of another head" ((HeadId -> IO ()) -> Spec) -> (HeadId -> IO ()) -> Spec
forall a b. (a -> b) -> a -> b
$ \HeadId
otherHeadId -> do
        let abortOtherHead :: Input SimpleTx
abortOtherHead = OnChainTx SimpleTx -> Input SimpleTx
observeTx (OnChainTx SimpleTx -> Input SimpleTx)
-> OnChainTx SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ OnAbortTx{$sel:headId:OnInitTx :: HeadId
headId = HeadId
otherHeadId}
        Environment
-> Ledger SimpleTx
-> HeadState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment -> Ledger tx -> HeadState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger ([Party] -> HeadState SimpleTx
inInitialState [Party]
threeParties) Input SimpleTx
abortOtherHead
          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 -> IO ()) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"ignores collectComTx of another head" ((HeadId -> IO ()) -> Spec) -> (HeadId -> IO ()) -> Spec
forall a b. (a -> b) -> a -> b
$ \HeadId
otherHeadId -> 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
$ OnCollectComTx{$sel:headId:OnInitTx :: HeadId
headId = HeadId
otherHeadId}
        Environment
-> Ledger SimpleTx
-> HeadState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment -> Ledger tx -> HeadState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger ([Party] -> HeadState SimpleTx
inInitialState [Party]
threeParties) 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 -> (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 openState :: HeadState SimpleTx
openState = [Party] -> HeadState SimpleTx
inOpenState [Party]
threeParties
        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}
        Environment
-> Ledger SimpleTx
-> HeadState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment -> Ledger tx -> HeadState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger HeadState SimpleTx
openState 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}
        Environment
-> Ledger SimpleTx
-> HeadState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment -> Ledger tx -> HeadState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger ([Party] -> HeadState SimpleTx
inClosedState [Party]
threeParties) 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 -> IO ()) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"ignores fanoutTx of another head" ((HeadId -> IO ()) -> Spec) -> (HeadId -> IO ()) -> Spec
forall a b. (a -> b) -> a -> b
$ \HeadId
otherHeadId -> 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}
        Environment
-> Ledger SimpleTx
-> HeadState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment -> Ledger tx -> HeadState tx -> Input tx -> Outcome tx
update Environment
bobEnv Ledger SimpleTx
ledger ([Party] -> HeadState SimpleTx
inClosedState [Party]
threeParties) 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 -> 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
$
      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)
genOutput 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)
-> 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
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)
        let ledger :: Ledger Tx
ledger = Globals -> LedgerEnv LedgerEra -> Ledger Tx
cardanoLedger Globals
Fixture.defaultGlobals LedgerEnv LedgerEra
Fixture.defaultLedgerEnv
            st0 :: HeadState Tx
st0 =
              OpenState Tx -> HeadState Tx
forall tx. OpenState tx -> HeadState tx
Open
                OpenState
                  { $sel:parameters:OpenState :: HeadParameters
parameters = ContestationPeriod -> [Party] -> HeadParameters
HeadParameters ContestationPeriod
defaultContestationPeriod [Party]
threeParties
                  , $sel:coordinatedHeadState:OpenState :: CoordinatedHeadState Tx
coordinatedHeadState =
                      CoordinatedHeadState
                        { $sel:localUTxO:CoordinatedHeadState :: UTxOType Tx
localUTxO = (TxIn, TxOut CtxUTxO) -> UTxO' (TxOut CtxUTxO)
forall out. (TxIn, out) -> UTxO' out
UTxO.singleton (TxIn, TxOut CtxUTxO)
utxo
                        , $sel:allTxs:CoordinatedHeadState :: Map (TxIdType Tx) Tx
allTxs = Map TxId Tx
Map (TxIdType Tx) Tx
forall a. Monoid a => a
mempty
                        , $sel:localTxs:CoordinatedHeadState :: [Tx]
localTxs = [Tx
expiringTransaction]
                        , $sel:confirmedSnapshot:CoordinatedHeadState :: ConfirmedSnapshot Tx
confirmedSnapshot = HeadId -> UTxOType Tx -> ConfirmedSnapshot Tx
forall tx. HeadId -> UTxOType tx -> ConfirmedSnapshot tx
InitialSnapshot HeadId
testHeadId (UTxOType Tx -> ConfirmedSnapshot Tx)
-> UTxOType Tx -> ConfirmedSnapshot Tx
forall a b. (a -> b) -> a -> b
$ (TxIn, TxOut CtxUTxO) -> UTxO' (TxOut CtxUTxO)
forall out. (TxIn, out) -> UTxO' out
UTxO.singleton (TxIn, TxOut CtxUTxO)
utxo
                        , $sel:seenSnapshot:CoordinatedHeadState :: SeenSnapshot Tx
seenSnapshot = SeenSnapshot Tx
forall tx. SeenSnapshot tx
NoSeenSnapshot
                        }
                  , $sel:chainState:OpenState :: ChainStateType Tx
chainState = Text -> ChainStateAt
forall a t. (HasCallStack, IsText t) => t -> a
Prelude.error Text
"should not be used"
                  , $sel:headId:OpenState :: HeadId
headId = HeadId
testHeadId
                  , $sel:headSeed:OpenState :: HeadSeed
headSeed = HeadSeed
testHeadSeed
                  , $sel:currentSlot:OpenState :: 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
                  }

        HeadState Tx
st <- IO (HeadState Tx) -> PropertyM IO (HeadState Tx)
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (IO (HeadState Tx) -> PropertyM IO (HeadState Tx))
-> IO (HeadState Tx) -> PropertyM IO (HeadState Tx)
forall a b. (a -> b) -> a -> b
$ Environment
-> Ledger Tx
-> HeadState Tx
-> StateT (StepState Tx) IO (HeadState Tx)
-> IO (HeadState Tx)
forall (m :: * -> *) tx a.
Monad m =>
Environment
-> Ledger tx -> HeadState tx -> StateT (StepState tx) m a -> m a
runHeadLogic Environment
bobEnv Ledger Tx
ledger HeadState Tx
st0 (StateT (StepState Tx) IO (HeadState Tx) -> IO (HeadState Tx))
-> StateT (StepState Tx) IO (HeadState Tx) -> IO (HeadState 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) =>
Input tx -> m (Outcome tx)
step (Natural -> Party -> Message Tx -> Input Tx
forall tx. Natural -> Party -> Message tx -> Input tx
NetworkInput Natural
defaultTTL Party
alice (Message Tx -> Input Tx) -> Message Tx -> Input Tx
forall a b. (a -> b) -> a -> b
$ SnapshotNumber -> [TxIdType Tx] -> Message Tx
forall tx. SnapshotNumber -> [TxIdType tx] -> Message tx
ReqSn SnapshotNumber
1 [])
          StateT (StepState Tx) IO (HeadState Tx)
forall tx (m :: * -> *).
MonadState (StepState tx) m =>
m (HeadState 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 HeadState Tx
st of
          Open
            OpenState
              { $sel:coordinatedHeadState:OpenState :: forall tx. OpenState tx -> CoordinatedHeadState tx
coordinatedHeadState =
                CoordinatedHeadState{[Tx]
$sel:localTxs:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> [tx]
localTxs :: [Tx]
localTxs}
              } -> [Tx] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Tx]
localTxs
          HeadState 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 -> do
      let outcome :: Outcome SimpleTx
outcome = Environment
-> Ledger SimpleTx
-> HeadState SimpleTx
-> Input SimpleTx
-> Outcome SimpleTx
forall tx.
IsChainState tx =>
Environment -> Ledger tx -> HeadState tx -> Input tx -> Outcome tx
update Environment
env Ledger SimpleTx
simpleLedger HeadState SimpleTx
inIdleState (OnChainTx SimpleTx -> Input SimpleTx
observeTx OnChainTx SimpleTx
unrelatedInit)
      String -> IO () -> 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 () -> Property) -> IO () -> Property
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
            ClientEffect IgnoredHeadInitializing{} -> Bool
True
            Effect SimpleTx
_ -> Bool
False
 where
  genUnrelatedInit :: Environment -> Gen (OnChainTx tx)
genUnrelatedInit Environment
env =
    [Gen (OnChainTx tx)] -> Gen (OnChainTx tx)
forall a. [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)
genOnInitWithoutParty Environment
env
      , Environment -> Gen (OnChainTx tx)
forall {tx}. Environment -> Gen (OnChainTx tx)
genOnInitWithoutOnChainId Environment
env
      ]

  genOnInitWithDifferentContestationPeriod :: Environment -> Gen (OnChainTx tx)
genOnInitWithDifferentContestationPeriod Environment{Party
$sel:party:Environment :: Environment -> Party
party :: Party
party, ContestationPeriod
$sel:contestationPeriod:Environment :: Environment -> ContestationPeriod
contestationPeriod :: ContestationPeriod
contestationPeriod, [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, [Party]
parties :: [Party]
$sel:parties:HeadParameters :: [Party]
parties}
        , [OnChainId]
participants :: [OnChainId]
$sel:participants:OnInitTx :: [OnChainId]
participants
        }

  genOnInitWithoutParty :: 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, [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. [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, $sel:parties:HeadParameters :: [Party]
parties = [Party]
differentParties}
        , [OnChainId]
$sel:participants:OnInitTx :: [OnChainId]
participants :: [OnChainId]
participants
        }

  genOnInitWithoutOnChainId :: 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, [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. [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, $sel:parties:HeadParameters :: [Party]
parties = Party
party Party -> [Party] -> [Party]
forall a. a -> [a] -> [a]
: [Party]
otherParties}
        , $sel:participants:OnInitTx :: [OnChainId]
participants = [OnChainId]
differentParticipants
        }

-- * Utilities

-- | 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 :: Natural -> OnChainTx SimpleTx -> Input SimpleTx
observeTxAtSlot :: Natural -> OnChainTx SimpleTx -> Input SimpleTx
observeTxAtSlot Natural
slot OnChainTx SimpleTx
observedTx =
  ChainInput
    { $sel:chainEvent:ClientInput :: ChainEvent SimpleTx
chainEvent =
        Observation
          { OnChainTx SimpleTx
observedTx :: OnChainTx SimpleTx
$sel:observedTx:Observation :: OnChainTx SimpleTx
observedTx
          , $sel:newChainState:Observation :: ChainStateType SimpleTx
newChainState = SimpleChainState{$sel:slot:SimpleChainState :: ChainSlot
slot = Natural -> ChainSlot
ChainSlot Natural
slot}
          }
    }

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

inIdleState :: HeadState SimpleTx
inIdleState :: HeadState SimpleTx
inIdleState =
  IdleState SimpleTx -> HeadState SimpleTx
forall tx. IdleState tx -> HeadState tx
Idle IdleState{$sel:chainState:IdleState :: ChainStateType SimpleTx
chainState = SimpleChainState{$sel:slot:SimpleChainState :: ChainSlot
slot = Natural -> ChainSlot
ChainSlot Natural
0}}

-- XXX: This is always called with threeParties and simpleLedger
inInitialState :: [Party] -> HeadState SimpleTx
inInitialState :: [Party] -> HeadState SimpleTx
inInitialState [Party]
parties =
  InitialState SimpleTx -> HeadState SimpleTx
forall tx. InitialState tx -> HeadState tx
Initial
    InitialState
      { HeadParameters
parameters :: HeadParameters
$sel:parameters:InitialState :: HeadParameters
parameters
      , $sel:pendingCommits:InitialState :: PendingCommits
pendingCommits = [Party] -> PendingCommits
forall a. Ord a => [a] -> Set a
Set.fromList [Party]
parties
      , $sel:committed:InitialState :: Committed SimpleTx
committed = Map Party (Set SimpleTxIn)
Committed SimpleTx
forall a. Monoid a => a
mempty
      , $sel:chainState:InitialState :: ChainStateType SimpleTx
chainState = SimpleChainState{$sel:slot:SimpleChainState :: ChainSlot
slot = Natural -> ChainSlot
ChainSlot Natural
0}
      , $sel:headId:InitialState :: HeadId
headId = HeadId
testHeadId
      , $sel:headSeed:InitialState :: HeadSeed
headSeed = HeadSeed
testHeadSeed
      }
 where
  parameters :: HeadParameters
parameters = ContestationPeriod -> [Party] -> HeadParameters
HeadParameters ContestationPeriod
defaultContestationPeriod [Party]
parties

-- XXX: This is always called with threeParties and simpleLedger
inOpenState ::
  [Party] ->
  HeadState SimpleTx
inOpenState :: [Party] -> HeadState SimpleTx
inOpenState [Party]
parties =
  [Party] -> CoordinatedHeadState SimpleTx -> HeadState SimpleTx
inOpenState' [Party]
parties (CoordinatedHeadState SimpleTx -> HeadState SimpleTx)
-> CoordinatedHeadState SimpleTx -> HeadState SimpleTx
forall a b. (a -> b) -> a -> b
$
    CoordinatedHeadState
      { $sel:localUTxO:CoordinatedHeadState :: UTxOType SimpleTx
localUTxO = Set SimpleTxIn
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 :: [SimpleTx]
localTxs = [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
      }
 where
  u0 :: Set SimpleTxIn
u0 = Set SimpleTxIn
forall a. Monoid a => a
mempty
  confirmedSnapshot :: ConfirmedSnapshot SimpleTx
confirmedSnapshot = HeadId -> UTxOType SimpleTx -> ConfirmedSnapshot SimpleTx
forall tx. HeadId -> UTxOType tx -> ConfirmedSnapshot tx
InitialSnapshot HeadId
testHeadId Set SimpleTxIn
UTxOType SimpleTx
u0

inOpenState' ::
  [Party] ->
  CoordinatedHeadState SimpleTx ->
  HeadState SimpleTx
inOpenState' :: [Party] -> CoordinatedHeadState SimpleTx -> HeadState SimpleTx
inOpenState' [Party]
parties CoordinatedHeadState SimpleTx
coordinatedHeadState =
  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 = SimpleChainState{$sel:slot:SimpleChainState :: ChainSlot
slot = ChainSlot
chainSlot}
      , $sel:headId:OpenState :: HeadId
headId = HeadId
testHeadId
      , $sel:headSeed:OpenState :: HeadSeed
headSeed = HeadSeed
testHeadSeed
      , $sel:currentSlot:OpenState :: ChainSlot
currentSlot = ChainSlot
chainSlot
      }
 where
  parameters :: HeadParameters
parameters = ContestationPeriod -> [Party] -> HeadParameters
HeadParameters ContestationPeriod
defaultContestationPeriod [Party]
parties

  chainSlot :: ChainSlot
chainSlot = Natural -> ChainSlot
ChainSlot Natural
0

-- XXX: This is always called with 'threeParties'
inClosedState :: [Party] -> HeadState SimpleTx
inClosedState :: [Party] -> HeadState SimpleTx
inClosedState [Party]
parties = [Party] -> ConfirmedSnapshot SimpleTx -> HeadState SimpleTx
inClosedState' [Party]
parties ConfirmedSnapshot SimpleTx
snapshot0
 where
  snapshot0 :: ConfirmedSnapshot SimpleTx
snapshot0 = HeadId -> UTxOType SimpleTx -> ConfirmedSnapshot SimpleTx
forall tx. HeadId -> UTxOType tx -> ConfirmedSnapshot tx
InitialSnapshot HeadId
testHeadId Set SimpleTxIn
UTxOType SimpleTx
u0
  u0 :: Set SimpleTxIn
u0 = Set SimpleTxIn
forall a. Monoid a => a
mempty

inClosedState' :: [Party] -> ConfirmedSnapshot SimpleTx -> HeadState SimpleTx
inClosedState' :: [Party] -> ConfirmedSnapshot SimpleTx -> HeadState SimpleTx
inClosedState' [Party]
parties ConfirmedSnapshot SimpleTx
confirmedSnapshot =
  ClosedState SimpleTx -> HeadState SimpleTx
forall tx. ClosedState tx -> HeadState tx
Closed
    ClosedState
      { HeadParameters
parameters :: HeadParameters
$sel:parameters:ClosedState :: HeadParameters
parameters
      , ConfirmedSnapshot SimpleTx
confirmedSnapshot :: ConfirmedSnapshot SimpleTx
$sel:confirmedSnapshot:ClosedState :: ConfirmedSnapshot SimpleTx
confirmedSnapshot
      , UTCTime
contestationDeadline :: UTCTime
$sel:contestationDeadline:ClosedState :: UTCTime
contestationDeadline
      , $sel:readyToFanoutSent:ClosedState :: Bool
readyToFanoutSent = Bool
False
      , $sel:chainState:ClosedState :: ChainStateType SimpleTx
chainState = SimpleChainState{$sel:slot:SimpleChainState :: ChainSlot
slot = Natural -> ChainSlot
ChainSlot Natural
0}
      , $sel:headId:ClosedState :: HeadId
headId = HeadId
testHeadId
      , $sel:headSeed:ClosedState :: HeadSeed
headSeed = HeadSeed
testHeadSeed
      }
 where
  parameters :: HeadParameters
parameters = ContestationPeriod -> [Party] -> HeadParameters
HeadParameters ContestationPeriod
defaultContestationPeriod [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

getConfirmedSnapshot :: HeadState tx -> Maybe (Snapshot tx)
getConfirmedSnapshot :: forall tx. HeadState tx -> Maybe (Snapshot tx)
getConfirmedSnapshot = \case
  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. ConfirmedSnapshot tx -> Snapshot tx
getSnapshot ConfirmedSnapshot tx
confirmedSnapshot)
  HeadState tx
_ ->
    Maybe (Snapshot tx)
forall a. Maybe a
Nothing

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

runHeadLogic ::
  Monad m =>
  Environment ->
  Ledger tx ->
  HeadState tx ->
  StateT (StepState tx) m a ->
  m a
runHeadLogic :: forall (m :: * -> *) tx a.
Monad m =>
Environment
-> Ledger tx -> HeadState tx -> StateT (StepState tx) m a -> m a
runHeadLogic Environment
env Ledger tx
ledger HeadState tx
headState = (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, HeadState tx
$sel:headState:StepState :: HeadState tx
headState :: HeadState tx
headState})

-- | Retrieves the latest 'HeadState' from within 'runHeadLogic'.
getState :: MonadState (StepState tx) m => m (HeadState tx)
getState :: forall tx (m :: * -> *).
MonadState (StepState tx) m =>
m (HeadState tx)
getState = StepState tx -> HeadState tx
forall tx. StepState tx -> HeadState tx
headState (StepState tx -> HeadState tx)
-> m (StepState tx) -> m (HeadState 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) =>
  Input tx ->
  m (Outcome tx)
step :: forall tx (m :: * -> *).
(MonadState (StepState tx) m, IsChainState tx) =>
Input tx -> m (Outcome tx)
step Input tx
input = do
  StepState{HeadState tx
$sel:headState:StepState :: forall tx. StepState tx -> HeadState tx
headState :: HeadState tx
headState, 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
  let outcome :: Outcome tx
outcome = Environment -> Ledger tx -> HeadState tx -> Input tx -> Outcome tx
forall tx.
IsChainState tx =>
Environment -> Ledger tx -> HeadState tx -> Input tx -> Outcome tx
update Environment
env Ledger tx
ledger HeadState tx
headState Input tx
input
  let headState' :: HeadState tx
headState' = HeadState tx -> Outcome tx -> HeadState tx
forall tx.
IsChainState tx =>
HeadState tx -> Outcome tx -> HeadState tx
aggregateState HeadState tx
headState 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:headState:StepState :: HeadState tx
headState = HeadState tx
headState'}
  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
reason :: WaitReason tx
$sel:reason:Continue :: forall tx. Outcome tx -> 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

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]
effects :: [Effect tx]
$sel:effects:Continue :: forall tx. Outcome tx -> [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

testSnapshot ::
  SnapshotNumber ->
  UTxOType tx ->
  [TxIdType tx] ->
  Snapshot tx
testSnapshot :: forall tx.
SnapshotNumber -> UTxOType tx -> [TxIdType tx] -> Snapshot tx
testSnapshot = HeadId
-> SnapshotNumber -> UTxOType tx -> [TxIdType tx] -> Snapshot tx
forall tx.
HeadId
-> SnapshotNumber -> UTxOType tx -> [TxIdType tx] -> Snapshot tx
Snapshot HeadId
testHeadId