{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE UndecidableInstances #-}

-- | A /Model/ of the Hydra head Protocol.
--
-- This model integrates in a single state-machine like abstraction the whole behaviour of
-- a Hydra Head, taking into account both on-chain state and contracts, and off-chain
-- interactions. It is written from the point of view of a pre-defined set of Hydra node
-- /operators/ that want to create a channel between them.
-- It's a "happy path" model that does not implement any kind of adversarial behaviour and
-- whose transactions are very simple: Each tx is a payment of one Ada-only UTxO transferred
-- to another party in full, without any change.
--
-- More intricate and specialised models shall be developed once we get a firmer grasp of
-- the whole framework, injecting faults, taking into account more parts of the stack,
-- modelling more complex transactions schemes...
module Hydra.Model where

import Hydra.Cardano.Api hiding (CardanoSigningKey (..), getVerificationKey, utxoFromTx)
import Hydra.Prelude hiding (Any, label, lookup, toList)
import Test.Hydra.Prelude

import Cardano.Api.UTxO qualified as UTxO
import Cardano.Binary (serialize', unsafeDeserialize')
import Control.Concurrent.Class.MonadSTM (
  modifyTVar,
  readTVarIO,
  retry,
 )
import Control.Monad.Class.MonadAsync (cancel, link)
import Control.Tracer.JSON (Tracer)
import Data.EventSource.Rotation (EventStore)
import Data.List (nub, (\\))
import Data.List qualified as List
import Data.Map.Strict ((!))
import Data.Map.Strict qualified as Map
import Data.Secret (Secret, mkSecret)
import Data.Set qualified as Set
import GHC.IsList (IsList (..))
import GHC.Natural (wordToNatural)
import Hydra.API.ClientInput (ClientInput)
import Hydra.API.ClientInput qualified as Input
import Hydra.API.ServerOutput (DecommitInvalidReason (..), ServerOutput (..))
import Hydra.BehaviorSpec (
  RequeueMode (..),
  SimulatedChainNetwork (..),
  TestHydraClient (..),
  createHydraNodeWithEventStore,
  createTestHydraClient,
  getHeadUTxO,
  shortLabel,
  waitUntilMatch,
 )
import Hydra.Chain (maximumNumberOfParties)
import Hydra.Chain.Direct.State (initialChainState)
import Hydra.HeadLogic.State qualified as HeadLogic
import Hydra.HeadLogic.StateEvent (StateEvent)
import Hydra.Ledger.Cardano (cardanoLedger, mkSimpleTx)
import Hydra.Logging.Messages (HydraLog (DirectChain, Node))
import Hydra.Model.MockChain (mockChainAndNetwork)
import Hydra.Model.Payment (CardanoSigningKey (..), Payment (..), applyTx, genAdaValue)
import Hydra.Node (HydraNode (..), NodeStateHandler (..), runHydraNode)
import Hydra.Node.State (NodeState (..))
import Hydra.NodeSpec (createMockEventStoreWithReader)
import Hydra.Options (defaultContestationPeriod, defaultDepositPeriod)
import Hydra.Tx (HeadId)
import Hydra.Tx.ContestationPeriod (ContestationPeriod (..))
import Hydra.Tx.Crypto (HydraKey, getVerificationKey)
import Hydra.Tx.DepositPeriod (DepositPeriod (..))
import Hydra.Tx.HeadParameters (HeadParameters (..))
import Hydra.Tx.IsTx (IsTx (..))
import Hydra.Tx.Party (Party (..), deriveParty)
import Hydra.Tx.Snapshot qualified as Snapshot
import Test.Hydra.Node.Fixture (defaultGlobals, defaultLedgerEnv, testNetworkId)
import Test.Hydra.Tx.Gen (genSigningKey)
import Test.QuickCheck (choose, chooseEnum, discard, elements, frequency, listOf, resize, sized, suchThat, tabulate, vectorOf)
import Test.QuickCheck.DynamicLogic (DynLogicModel)
import Test.QuickCheck.StateModel (Any (..), HasVariables, PostconditionM, Realized, RunModel (..), StateModel (..), Var, VarContext, counterexamplePost)
import Test.QuickCheck.StateModel.Variables (HasVariables (..))
import Prelude qualified

-- * The Model

-- | State maintained by the model.
data WorldState = WorldState
  { WorldState -> [(Secret (SigningKey HydraKey), CardanoSigningKey)]
hydraParties :: [(Secret (SigningKey HydraKey), CardanoSigningKey)]
  -- ^ List of parties identified by both signing keys required to run protocol.
  -- This list must not contain any duplicated key.
  , WorldState -> GlobalState
hydraState :: GlobalState
  -- ^ Expected consensus state
  -- All nodes should be in the same state.
  , WorldState -> UTxOType Payment
availableToDeposit :: UTxOType Payment
  -- ^ UTxO available to be committed incrementally, seeded from
  -- 'additionalUTxO' at 'Seed'. NOTE: We must not add UTxO we decommitted to
  -- this as the 'Payment' transaction model results in non-unique transaction
  -- ids when running the model. For the same reason a random 'Deposit' always
  -- commits /all/ of one signer's available UTxO at once ('toRealUTxO'
  -- assigns mocked TxIns per signer starting from index 0, so two separate
  -- deposits by the same signer would collide).
  , WorldState -> [(Var TxId, UTxOType Payment)]
pendingCommits :: [(Var TxId, UTxOType Payment)]
  -- ^ Deposits submitted via 'SubmitDeposit' and recorded on chain, but not
  -- yet observed as finalized ('ObserveCommitFinalized'). Several can be in
  -- flight at once, which is what lets a fork erase one settlement while
  -- another is pending.
  , WorldState -> [(Var (UTxO Era), Payment)]
pendingDecommits :: [(Var UTxO, Payment)]
  -- ^ Decommits submitted via 'SubmitDecommit' whose snapshot is confirmed
  -- but whose decrement is not yet observed as finalized
  -- ('ObserveDecommitFinalized').
  , WorldState -> [Var TxId]
settledCommits :: [Var TxId]
  -- ^ Commits already observed as finalized, once per observation. They may
  -- be observed again: a fork that erases the increment makes it re-land
  -- (re-posted by the nodes or re-included from the mempool), which the nodes
  -- report as a second 'CommitFinalized'; the n-th observation waits for the
  -- n-th report.
  , WorldState -> [Var (UTxO Era)]
settledDecommits :: [Var UTxO]
  -- ^ Decommits already observed as finalized, once per observation; see
  -- 'settledCommits'.
  , WorldState -> Bool
concurrentSettlements :: Bool
  -- ^ Generator mode, set by 'Seed'.
  }
  deriving stock (WorldState -> WorldState -> Bool
(WorldState -> WorldState -> Bool)
-> (WorldState -> WorldState -> Bool) -> Eq WorldState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: WorldState -> WorldState -> Bool
== :: WorldState -> WorldState -> Bool
$c/= :: WorldState -> WorldState -> Bool
/= :: WorldState -> WorldState -> Bool
Eq, Int -> WorldState -> ShowS
[WorldState] -> ShowS
WorldState -> String
(Int -> WorldState -> ShowS)
-> (WorldState -> String)
-> ([WorldState] -> ShowS)
-> Show WorldState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> WorldState -> ShowS
showsPrec :: Int -> WorldState -> ShowS
$cshow :: WorldState -> String
show :: WorldState -> String
$cshowList :: [WorldState] -> ShowS
showList :: [WorldState] -> ShowS
Show)

-- | Global state of the Head protocol.
-- While each participant in the Hydra Head protocol has its own private
-- view of the state, we model the expected global state whose properties
-- stem from the consensus built into the Head protocol. In other words, this
-- state is what each node's local state should be /eventually/.
data GlobalState
  = -- | Start of the "world".
    --  This state is left implicit in the node's logic as it
    --  represents that state where the node does not even
    --  exist.
    Start
  | Idle
      { GlobalState -> [Party]
idleParties :: [Party]
      , GlobalState -> [VerificationKey PaymentKey]
cardanoKeys :: [VerificationKey PaymentKey]
      , GlobalState -> ContestationPeriod
contestationPeriod :: ContestationPeriod
      }
  | Open
      { GlobalState -> Var HeadId
headIdVar :: Var HeadId
      , GlobalState -> HeadParameters
headParameters :: HeadParameters
      , GlobalState -> OffChainState
offChainState :: OffChainState
      , -- TODO: keep a single UTxOType Payment instead?
        GlobalState -> Map Party (UTxOType Payment)
committed :: Map Party (UTxOType Payment)
      , GlobalState -> Natural
onChainVersion :: Natural
      -- ^ Expected open state version on chain: bumped by every settled
      -- increment ('Deposit') and decrement ('Decommit').
      }
  | Closed
      { headParameters :: HeadParameters
      , GlobalState -> UTxOType Payment
closedUTxO :: UTxOType Payment
      , GlobalState -> UTxOType Payment
unsettledAtClose :: UTxOType Payment
      -- ^ Outputs of settlements still pending when the head was closed: a
      -- pending commit's deposit, or a pending decommit's payout. Whether the
      -- settlement landed before the close is a race the model does not
      -- track, so each of these may or may not be part of the fanout.
      , GlobalState -> FanoutDriving
fanoutDriving :: FanoutDriving
      -- ^ How the fanout is being driven, if it has started.
      , GlobalState -> UTxOType Payment
fannedOut :: UTxOType Payment
      -- ^ Outputs already handed to 'PartialFanoutStep' in manual mode.
      }
  | Final
      { GlobalState -> UTxOType Payment
finalUTxO :: UTxOType Payment
      , GlobalState -> UTxOType Payment
unsettledAtFinal :: UTxOType Payment
      -- ^ See 'unsettledAtClose'.
      }
  deriving stock (GlobalState -> GlobalState -> Bool
(GlobalState -> GlobalState -> Bool)
-> (GlobalState -> GlobalState -> Bool) -> Eq GlobalState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: GlobalState -> GlobalState -> Bool
== :: GlobalState -> GlobalState -> Bool
$c/= :: GlobalState -> GlobalState -> Bool
/= :: GlobalState -> GlobalState -> Bool
Eq, Int -> GlobalState -> ShowS
[GlobalState] -> ShowS
GlobalState -> String
(Int -> GlobalState -> ShowS)
-> (GlobalState -> String)
-> ([GlobalState] -> ShowS)
-> Show GlobalState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> GlobalState -> ShowS
showsPrec :: Int -> GlobalState -> ShowS
$cshow :: GlobalState -> String
show :: GlobalState -> String
$cshowList :: [GlobalState] -> ShowS
showList :: [GlobalState] -> ShowS
Show)

newtype OffChainState = OffChainState {OffChainState -> UTxOType Payment
confirmedUTxO :: UTxOType Payment}
  deriving stock (OffChainState -> OffChainState -> Bool
(OffChainState -> OffChainState -> Bool)
-> (OffChainState -> OffChainState -> Bool) -> Eq OffChainState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: OffChainState -> OffChainState -> Bool
== :: OffChainState -> OffChainState -> Bool
$c/= :: OffChainState -> OffChainState -> Bool
/= :: OffChainState -> OffChainState -> Bool
Eq, Int -> OffChainState -> ShowS
[OffChainState] -> ShowS
OffChainState -> String
(Int -> OffChainState -> ShowS)
-> (OffChainState -> String)
-> ([OffChainState] -> ShowS)
-> Show OffChainState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> OffChainState -> ShowS
showsPrec :: Int -> OffChainState -> ShowS
$cshow :: OffChainState -> String
show :: OffChainState -> String
$cshowList :: [OffChainState] -> ShowS
showList :: [OffChainState] -> ShowS
Show)

-- | How a closed head's fanout is driven. A plain 'Fanout' drains the head
-- automatically, possibly in several steps; 'PartialFanoutStep' hands the node
-- one selection at a time and the node only drains what it was given. The two
-- cannot be mixed: once a partial fanout started, 'Fanout' is rejected.
data FanoutDriving
  = FanoutNotStarted
  | FanoutAutoDraining
  | FanoutManual
  deriving stock (FanoutDriving -> FanoutDriving -> Bool
(FanoutDriving -> FanoutDriving -> Bool)
-> (FanoutDriving -> FanoutDriving -> Bool) -> Eq FanoutDriving
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FanoutDriving -> FanoutDriving -> Bool
== :: FanoutDriving -> FanoutDriving -> Bool
$c/= :: FanoutDriving -> FanoutDriving -> Bool
/= :: FanoutDriving -> FanoutDriving -> Bool
Eq, Int -> FanoutDriving -> ShowS
[FanoutDriving] -> ShowS
FanoutDriving -> String
(Int -> FanoutDriving -> ShowS)
-> (FanoutDriving -> String)
-> ([FanoutDriving] -> ShowS)
-> Show FanoutDriving
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FanoutDriving -> ShowS
showsPrec :: Int -> FanoutDriving -> ShowS
$cshow :: FanoutDriving -> String
show :: FanoutDriving -> String
$cshowList :: [FanoutDriving] -> ShowS
showList :: [FanoutDriving] -> ShowS
Show)

-- This is needed to be able to use `WorldState` inside DL formulae
instance DynLogicModel WorldState

-- | Basic instantiation of `StateModel` for our `WorldState` state.
instance StateModel WorldState where
  -- The list of possible "Actions" within our `Model`
  -- Not all of them need to actually represent an actual user `Action`, but they
  -- can represent _observations_ which are useful when defining properties in
  -- DL. Those observations would usually not be generated.
  data Action WorldState a where
    Seed ::
      { Action WorldState ()
-> [(Secret (SigningKey HydraKey), CardanoSigningKey)]
seedKeys :: [(Secret (SigningKey HydraKey), CardanoSigningKey)]
      , Action WorldState () -> ContestationPeriod
contestationPeriod :: ContestationPeriod
      , Action WorldState () -> UTxOType Payment
additionalUTxO :: UTxOType Payment
      , Action WorldState () -> Bool
concurrentSettlements :: Bool
      } ->
      -- \^ Whether the random walk may have several deposits/decommits in
      -- flight at once ('SubmitDeposit' & co., forks in every 'RequeueMode')
      -- or settles each one before the next ('Deposit'/'Decommit', forks
      -- re-landing everything). See 'genOpenActions'.
      --
      -- TODO: Remove this switch and always settle concurrently. The
      -- sequential walk only exists because the concurrent one still finds
      -- open bugs (see the pending properties in 'Hydra.ModelSpec'); once
      -- those are fixed, every property should hold under concurrent
      -- settlements.

      Action WorldState ()
    Init :: Party -> Action WorldState HeadId
    Deposit :: {Action WorldState () -> Var HeadId
headIdVar :: Var HeadId, Action WorldState () -> UTxOType Payment
utxoToDeposit :: UTxOType Payment} -> Action WorldState ()
    Decommit :: {Action WorldState () -> Party
party :: Party, Action WorldState () -> Payment
decommitTx :: Payment} -> Action WorldState ()
    -- Non-blocking variants of 'Deposit' and 'Decommit': submit and wait only
    -- until the deposit is recorded on chain (resp. the decommit's snapshot is
    -- confirmed), then observe settlement separately. This is what allows
    -- several settlements to be in flight when a fork hits.
    -- NOTE: No records possible here, see 'Fanout'.
    SubmitDeposit :: Var HeadId -> UTxOType Payment -> Action WorldState TxId
    -- Wait until the snapshot claiming the deposit is confirmed, i.e. its
    -- increment is in flight. Observation only, used by scripted scenarios.
    ObserveCommitApproved :: Var TxId -> Action WorldState ()
    ObserveCommitFinalized :: Var TxId -> Action WorldState ()
    -- Returns the decommitted UTxO as built on L2, to match the decrement's
    -- distributed outputs exactly in 'ObserveDecommitFinalized'.
    SubmitDecommit :: Party -> Payment -> Action WorldState UTxO
    ObserveDecommitFinalized :: Var UTxO -> Action WorldState ()
    Close :: {party :: Party} -> Action WorldState ()
    -- NOTE: No records possible here as we would duplicate 'Party' fields with
    -- different return values.
    Fanout :: Party -> Action WorldState UTxO
    -- Non-blocking fanout, in steps: start draining automatically, or hand
    -- the node one selection to distribute (manual mode), observe partial
    -- steps landing, and finally observe the head being finalized. Lets a
    -- fork hit while the fanout is in progress. Used by scripted scenarios.
    StartFanout :: Party -> Action WorldState ()
    PartialFanoutStep :: Party -> UTxOType Payment -> Action WorldState ()
    ObservePartialFanoutSteps :: Int -> Action WorldState ()
    ObserveFanoutFinalized :: Party -> Action WorldState UTxO
    NewTx :: Party -> Payment -> Action WorldState Payment
    Wait :: DiffTime -> Action WorldState ()
    ObserveConfirmedTx :: Var Payment -> Action WorldState ()
    -- Check that all parties have observed the head as open
    ObserveHeadIsOpen :: Action WorldState ()
    RollbackAndForward :: Natural -> Action WorldState ()
    -- Rollback onto a divergent fork: the rolled back blocks are dropped (not
    -- re-served); 'requeueErased' says which of their transactions are
    -- re-submitted (mempool re-inclusion), the rest only land if the nodes
    -- re-post them.
    RollbackAndFork :: {Action WorldState () -> Natural
numberOfBlocks :: Natural, Action WorldState () -> RequeueMode
requeueErased :: RequeueMode} -> Action WorldState ()
    -- Crash a node (in-flight inputs are lost) and restart it from its event
    -- store, re-syncing the chain from genesis.
    RestartNode :: Party -> Action WorldState ()
    CloseWithInitialSnapshot :: Party -> Action WorldState ()
    StopTheWorld :: Action WorldState ()

  initialState :: WorldState
initialState =
    WorldState
      { $sel:hydraParties:WorldState :: [(Secret (SigningKey HydraKey), CardanoSigningKey)]
hydraParties = [(Secret (SigningKey HydraKey), CardanoSigningKey)]
forall a. Monoid a => a
mempty
      , $sel:hydraState:WorldState :: GlobalState
hydraState = GlobalState
Start
      , $sel:availableToDeposit:WorldState :: UTxOType Payment
availableToDeposit = [(CardanoSigningKey, Value)]
UTxOType Payment
forall a. Monoid a => a
mempty
      , $sel:pendingCommits:WorldState :: [(Var TxId, UTxOType Payment)]
pendingCommits = [(Var TxId, [(CardanoSigningKey, Value)])]
[(Var TxId, UTxOType Payment)]
forall a. Monoid a => a
mempty
      , $sel:pendingDecommits:WorldState :: [(Var (UTxO Era), Payment)]
pendingDecommits = [(Var (UTxO Era), Payment)]
forall a. Monoid a => a
mempty
      , $sel:settledCommits:WorldState :: [Var TxId]
settledCommits = [Var TxId]
forall a. Monoid a => a
mempty
      , $sel:settledDecommits:WorldState :: [Var (UTxO Era)]
settledDecommits = [Var (UTxO Era)]
forall a. Monoid a => a
mempty
      , $sel:concurrentSettlements:WorldState :: Bool
concurrentSettlements = Bool
False
      }

  arbitraryAction :: VarContext -> WorldState -> Gen (Any (Action WorldState))
  arbitraryAction :: VarContext -> WorldState -> Gen (Any (Action WorldState))
arbitraryAction VarContext
_ st :: WorldState
st@WorldState{[(Secret (SigningKey HydraKey), CardanoSigningKey)]
$sel:hydraParties:WorldState :: WorldState -> [(Secret (SigningKey HydraKey), CardanoSigningKey)]
hydraParties :: [(Secret (SigningKey HydraKey), CardanoSigningKey)]
hydraParties, GlobalState
$sel:hydraState:WorldState :: WorldState -> GlobalState
hydraState :: GlobalState
hydraState, UTxOType Payment
$sel:availableToDeposit:WorldState :: WorldState -> UTxOType Payment
availableToDeposit :: UTxOType Payment
availableToDeposit, [(Var TxId, UTxOType Payment)]
$sel:pendingCommits:WorldState :: WorldState -> [(Var TxId, UTxOType Payment)]
pendingCommits :: [(Var TxId, UTxOType Payment)]
pendingCommits, [(Var (UTxO Era), Payment)]
$sel:pendingDecommits:WorldState :: WorldState -> [(Var (UTxO Era), Payment)]
pendingDecommits :: [(Var (UTxO Era), Payment)]
pendingDecommits, Bool
$sel:concurrentSettlements:WorldState :: WorldState -> Bool
concurrentSettlements :: Bool
concurrentSettlements} =
    case GlobalState
hydraState of
      GlobalState
Start -> Action WorldState () -> Any (Action WorldState)
forall a (f :: * -> *). (Typeable a, Eq (f a)) => f a -> Any f
Some (Action WorldState () -> Any (Action WorldState))
-> Gen (Action WorldState ()) -> Gen (Any (Action WorldState))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (Action WorldState ())
genSeed
      Idle{} -> Action WorldState HeadId -> Any (Action WorldState)
forall a (f :: * -> *). (Typeable a, Eq (f a)) => f a -> Any f
Some (Action WorldState HeadId -> Any (Action WorldState))
-> Gen (Action WorldState HeadId) -> Gen (Any (Action WorldState))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Secret (SigningKey HydraKey), CardanoSigningKey)]
-> Gen (Action WorldState HeadId)
forall b.
[(Secret (SigningKey HydraKey), b)]
-> Gen (Action WorldState HeadId)
genInit [(Secret (SigningKey HydraKey), CardanoSigningKey)]
hydraParties
      Open{Var HeadId
$sel:headIdVar:Start :: GlobalState -> Var HeadId
headIdVar :: Var HeadId
headIdVar, $sel:offChainState:Start :: GlobalState -> OffChainState
offChainState = OffChainState{UTxOType Payment
$sel:confirmedUTxO:OffChainState :: OffChainState -> UTxOType Payment
confirmedUTxO :: UTxOType Payment
confirmedUTxO}} ->
        Var HeadId
-> [(CardanoSigningKey, Value)] -> Gen (Any (Action WorldState))
genOpenActions Var HeadId
headIdVar [(CardanoSigningKey, Value)]
UTxOType Payment
confirmedUTxO
      Closed{} ->
        [(Int, Gen (Any (Action WorldState)))]
-> Gen (Any (Action WorldState))
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency
          [ (Int
5, Gen (Any (Action WorldState))
genFanout)
          , (Int
1, Gen (Any (Action WorldState))
genRollbackAndForward)
          ]
      Final{} -> Action WorldState () -> Any (Action WorldState)
forall a (f :: * -> *). (Typeable a, Eq (f a)) => f a -> Any f
Some (Action WorldState () -> Any (Action WorldState))
-> Gen (Action WorldState ()) -> Gen (Any (Action WorldState))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (Action WorldState ())
genSeed
   where
    -- NOTE: Some actions depend on confirmed 'UTxO' in the head so
    -- we need to make sure there are funds to spend when generating a
    -- `NewTx` action for example but also want to make sure that after
    -- a 'Decommit' we are not left without any funds so further actions
    -- can be generated.
    genOpenActions :: Var HeadId
-> [(CardanoSigningKey, Value)] -> Gen (Any (Action WorldState))
genOpenActions Var HeadId
headIdVar [(CardanoSigningKey, Value)]
confirmedUTxO =
      [(Int, Gen (Any (Action WorldState)))]
-> Gen (Any (Action WorldState))
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency ([(Int, Gen (Any (Action WorldState)))]
 -> Gen (Any (Action WorldState)))
-> [(Int, Gen (Any (Action WorldState)))]
-> Gen (Any (Action WorldState))
forall a b. (a -> b) -> a -> b
$
        [ (Int
1, Gen (Any (Action WorldState))
genClose)
        , (Int
1, Gen (Any (Action WorldState))
genRollbackAndForward)
        , (Int
1, Gen (Any (Action WorldState))
genRollbackAndFork)
        ]
          -- 'RestartNode' models fail-recovery under load, see 'restartNodeEnabled'.
          [(Int, Gen (Any (Action WorldState)))]
-> [(Int, Gen (Any (Action WorldState)))]
-> [(Int, Gen (Any (Action WorldState)))]
forall a. Semigroup a => a -> a -> a
<> [(Int
1, Gen (Any (Action WorldState))
genRestartNode) | Bool
restartNodeEnabled]
          -- XXX: if using > 0 we could run into a new tx not having utxo available situation?
          [(Int, Gen (Any (Action WorldState)))]
-> [(Int, Gen (Any (Action WorldState)))]
-> [(Int, Gen (Any (Action WorldState)))]
forall a. Semigroup a => a -> a -> a
<> [(Int
10, Gen (Any (Action WorldState))
genNewTx) | [(CardanoSigningKey, Value)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(CardanoSigningKey, Value)]
confirmedUTxO Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1]
          [(Int, Gen (Any (Action WorldState)))]
-> [(Int, Gen (Any (Action WorldState)))]
-> [(Int, Gen (Any (Action WorldState)))]
forall a. Semigroup a => a -> a -> a
<> Var HeadId
-> [(CardanoSigningKey, Value)]
-> [(Int, Gen (Any (Action WorldState)))]
settlementActions Var HeadId
headIdVar [(CardanoSigningKey, Value)]
confirmedUTxO

    -- With 'concurrentSettlements', settlements are submitted and observed as
    -- separate actions so that several can be in flight when a fork hits; see
    -- 'SubmitDeposit'. Observation is weighted higher so most pending
    -- settlements do get observed within a sequence. Without, every
    -- settlement completes before the next action.
    settlementActions :: Var HeadId
-> [(CardanoSigningKey, Value)]
-> [(Int, Gen (Any (Action WorldState)))]
settlementActions Var HeadId
headIdVar [(CardanoSigningKey, Value)]
confirmedUTxO
      | Bool
concurrentSettlements =
          [(Int
2, Gen (Any (Action WorldState))
genSubmitDecommit) | [(CardanoSigningKey, Value)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(CardanoSigningKey, Value)]
confirmedUTxO Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1]
            [(Int, Gen (Any (Action WorldState)))]
-> [(Int, Gen (Any (Action WorldState)))]
-> [(Int, Gen (Any (Action WorldState)))]
forall a. Semigroup a => a -> a -> a
<> [(Int
3, Gen (Any (Action WorldState))
genObserveDecommitFinalized) | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [(Var (UTxO Era), Payment)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Var (UTxO Era), Payment)]
pendingDecommits]
            [(Int, Gen (Any (Action WorldState)))]
-> [(Int, Gen (Any (Action WorldState)))]
-> [(Int, Gen (Any (Action WorldState)))]
forall a. Semigroup a => a -> a -> a
<> [(Int
2, Var HeadId -> Gen (Any (Action WorldState))
genSubmitDeposit Var HeadId
headIdVar) | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [(CardanoSigningKey, Value)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(CardanoSigningKey, Value)]
UTxOType Payment
availableToDeposit]
            [(Int, Gen (Any (Action WorldState)))]
-> [(Int, Gen (Any (Action WorldState)))]
-> [(Int, Gen (Any (Action WorldState)))]
forall a. Semigroup a => a -> a -> a
<> [(Int
3, Gen (Any (Action WorldState))
genObserveCommitFinalized) | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [(Var TxId, [(CardanoSigningKey, Value)])] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Var TxId, [(CardanoSigningKey, Value)])]
[(Var TxId, UTxOType Payment)]
pendingCommits]
      | Bool
otherwise =
          [(Int
2, Gen (Any (Action WorldState))
genDecommit) | [(CardanoSigningKey, Value)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(CardanoSigningKey, Value)]
confirmedUTxO Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1]
            [(Int, Gen (Any (Action WorldState)))]
-> [(Int, Gen (Any (Action WorldState)))]
-> [(Int, Gen (Any (Action WorldState)))]
forall a. Semigroup a => a -> a -> a
<> [(Int
2, Var HeadId -> Gen (Any (Action WorldState))
genDeposit Var HeadId
headIdVar) | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [(CardanoSigningKey, Value)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(CardanoSigningKey, Value)]
UTxOType Payment
availableToDeposit]

    -- NOTE: Deposits all of one signer's available UTxO at once, see
    -- 'availableToDeposit'. Only signers with available UTxO qualify: an
    -- empty deposit is rejected at draft time (SnapshotIncrementUTxOIsNull).
    genDeposit :: Var HeadId -> Gen (Any (Action WorldState))
genDeposit Var HeadId
headIdVar = do
      CardanoSigningKey
sk <- [CardanoSigningKey] -> Gen CardanoSigningKey
forall a. HasCallStack => [a] -> Gen a
elements ([CardanoSigningKey] -> [CardanoSigningKey]
forall a. Eq a => [a] -> [a]
nub ([CardanoSigningKey] -> [CardanoSigningKey])
-> [CardanoSigningKey] -> [CardanoSigningKey]
forall a b. (a -> b) -> a -> b
$ (CardanoSigningKey, Value) -> CardanoSigningKey
forall a b. (a, b) -> a
fst ((CardanoSigningKey, Value) -> CardanoSigningKey)
-> [(CardanoSigningKey, Value)] -> [CardanoSigningKey]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(CardanoSigningKey, Value)]
UTxOType Payment
availableToDeposit)
      let utxoToDeposit :: [(CardanoSigningKey, Value)]
utxoToDeposit = ((CardanoSigningKey, Value) -> Bool)
-> [(CardanoSigningKey, Value)] -> [(CardanoSigningKey, Value)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((CardanoSigningKey
sk ==) (CardanoSigningKey -> Bool)
-> ((CardanoSigningKey, Value) -> CardanoSigningKey)
-> (CardanoSigningKey, Value)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CardanoSigningKey, Value) -> CardanoSigningKey
forall a b. (a, b) -> a
fst) [(CardanoSigningKey, Value)]
UTxOType Payment
availableToDeposit
      Any (Action WorldState) -> Gen (Any (Action WorldState))
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Any (Action WorldState) -> Gen (Any (Action WorldState)))
-> Any (Action WorldState) -> Gen (Any (Action WorldState))
forall a b. (a -> b) -> a -> b
$ Action WorldState () -> Any (Action WorldState)
forall a (f :: * -> *). (Typeable a, Eq (f a)) => f a -> Any f
Some Deposit{Var HeadId
$sel:headIdVar:Seed :: Var HeadId
headIdVar :: Var HeadId
headIdVar, [(CardanoSigningKey, Value)]
UTxOType Payment
$sel:utxoToDeposit:Seed :: UTxOType Payment
utxoToDeposit :: [(CardanoSigningKey, Value)]
utxoToDeposit}

    genDecommit :: Gen (Any (Action WorldState))
genDecommit =
      WorldState -> Gen (Party, Payment)
genPayment WorldState
st Gen (Party, Payment)
-> ((Party, Payment) -> Gen (Any (Action WorldState)))
-> Gen (Any (Action WorldState))
forall a b. Gen a -> (a -> Gen b) -> Gen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(Party
party, Payment
tx) -> Any (Action WorldState) -> Gen (Any (Action WorldState))
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Any (Action WorldState) -> Gen (Any (Action WorldState)))
-> (Action WorldState () -> Any (Action WorldState))
-> Action WorldState ()
-> Gen (Any (Action WorldState))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Action WorldState () -> Any (Action WorldState)
forall a (f :: * -> *). (Typeable a, Eq (f a)) => f a -> Any f
Some (Action WorldState () -> Gen (Any (Action WorldState)))
-> Action WorldState () -> Gen (Any (Action WorldState))
forall a b. (a -> b) -> a -> b
$ Party -> Payment -> Action WorldState ()
Decommit Party
party Payment
tx

    genSubmitDeposit :: Var HeadId -> Gen (Any (Action WorldState))
genSubmitDeposit Var HeadId
headIdVar = do
      CardanoSigningKey
sk <- [CardanoSigningKey] -> Gen CardanoSigningKey
forall a. HasCallStack => [a] -> Gen a
elements ([CardanoSigningKey] -> [CardanoSigningKey]
forall a. Eq a => [a] -> [a]
nub ([CardanoSigningKey] -> [CardanoSigningKey])
-> [CardanoSigningKey] -> [CardanoSigningKey]
forall a b. (a -> b) -> a -> b
$ (CardanoSigningKey, Value) -> CardanoSigningKey
forall a b. (a, b) -> a
fst ((CardanoSigningKey, Value) -> CardanoSigningKey)
-> [(CardanoSigningKey, Value)] -> [CardanoSigningKey]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(CardanoSigningKey, Value)]
UTxOType Payment
availableToDeposit)
      let utxoToDeposit :: [(CardanoSigningKey, Value)]
utxoToDeposit = ((CardanoSigningKey, Value) -> Bool)
-> [(CardanoSigningKey, Value)] -> [(CardanoSigningKey, Value)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((CardanoSigningKey
sk ==) (CardanoSigningKey -> Bool)
-> ((CardanoSigningKey, Value) -> CardanoSigningKey)
-> (CardanoSigningKey, Value)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CardanoSigningKey, Value) -> CardanoSigningKey
forall a b. (a, b) -> a
fst) [(CardanoSigningKey, Value)]
UTxOType Payment
availableToDeposit
      Any (Action WorldState) -> Gen (Any (Action WorldState))
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Any (Action WorldState) -> Gen (Any (Action WorldState)))
-> Any (Action WorldState) -> Gen (Any (Action WorldState))
forall a b. (a -> b) -> a -> b
$ Action WorldState TxId -> Any (Action WorldState)
forall a (f :: * -> *). (Typeable a, Eq (f a)) => f a -> Any f
Some (Action WorldState TxId -> Any (Action WorldState))
-> Action WorldState TxId -> Any (Action WorldState)
forall a b. (a -> b) -> a -> b
$ Var HeadId -> UTxOType Payment -> Action WorldState TxId
SubmitDeposit Var HeadId
headIdVar [(CardanoSigningKey, Value)]
UTxOType Payment
utxoToDeposit

    genObserveCommitFinalized :: Gen (Any (Action WorldState))
genObserveCommitFinalized =
      Action WorldState () -> Any (Action WorldState)
forall a (f :: * -> *). (Typeable a, Eq (f a)) => f a -> Any f
Some (Action WorldState () -> Any (Action WorldState))
-> ((Var TxId, [(CardanoSigningKey, Value)])
    -> Action WorldState ())
-> (Var TxId, [(CardanoSigningKey, Value)])
-> Any (Action WorldState)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Var TxId -> Action WorldState ()
ObserveCommitFinalized (Var TxId -> Action WorldState ())
-> ((Var TxId, [(CardanoSigningKey, Value)]) -> Var TxId)
-> (Var TxId, [(CardanoSigningKey, Value)])
-> Action WorldState ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Var TxId, [(CardanoSigningKey, Value)]) -> Var TxId
forall a b. (a, b) -> a
fst ((Var TxId, [(CardanoSigningKey, Value)])
 -> Any (Action WorldState))
-> Gen (Var TxId, [(CardanoSigningKey, Value)])
-> Gen (Any (Action WorldState))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Var TxId, [(CardanoSigningKey, Value)])]
-> Gen (Var TxId, [(CardanoSigningKey, Value)])
forall a. HasCallStack => [a] -> Gen a
elements [(Var TxId, [(CardanoSigningKey, Value)])]
[(Var TxId, UTxOType Payment)]
pendingCommits

    genSubmitDecommit :: Gen (Any (Action WorldState))
genSubmitDecommit =
      WorldState -> Gen (Party, Payment)
genPayment WorldState
st Gen (Party, Payment)
-> ((Party, Payment) -> Gen (Any (Action WorldState)))
-> Gen (Any (Action WorldState))
forall a b. Gen a -> (a -> Gen b) -> Gen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(Party
party, Payment
tx) -> Any (Action WorldState) -> Gen (Any (Action WorldState))
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Any (Action WorldState) -> Gen (Any (Action WorldState)))
-> (Action WorldState (UTxO Era) -> Any (Action WorldState))
-> Action WorldState (UTxO Era)
-> Gen (Any (Action WorldState))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Action WorldState (UTxO Era) -> Any (Action WorldState)
forall a (f :: * -> *). (Typeable a, Eq (f a)) => f a -> Any f
Some (Action WorldState (UTxO Era) -> Gen (Any (Action WorldState)))
-> Action WorldState (UTxO Era) -> Gen (Any (Action WorldState))
forall a b. (a -> b) -> a -> b
$ Party -> Payment -> Action WorldState (UTxO Era)
SubmitDecommit Party
party Payment
tx

    genObserveDecommitFinalized :: Gen (Any (Action WorldState))
genObserveDecommitFinalized =
      Action WorldState () -> Any (Action WorldState)
forall a (f :: * -> *). (Typeable a, Eq (f a)) => f a -> Any f
Some (Action WorldState () -> Any (Action WorldState))
-> ((Var (UTxO Era), Payment) -> Action WorldState ())
-> (Var (UTxO Era), Payment)
-> Any (Action WorldState)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Var (UTxO Era) -> Action WorldState ()
ObserveDecommitFinalized (Var (UTxO Era) -> Action WorldState ())
-> ((Var (UTxO Era), Payment) -> Var (UTxO Era))
-> (Var (UTxO Era), Payment)
-> Action WorldState ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Var (UTxO Era), Payment) -> Var (UTxO Era)
forall a b. (a, b) -> a
fst ((Var (UTxO Era), Payment) -> Any (Action WorldState))
-> Gen (Var (UTxO Era), Payment) -> Gen (Any (Action WorldState))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Var (UTxO Era), Payment)] -> Gen (Var (UTxO Era), Payment)
forall a. HasCallStack => [a] -> Gen a
elements [(Var (UTxO Era), Payment)]
pendingDecommits

    genNewTx :: Gen (Any (Action WorldState))
genNewTx = WorldState -> Gen (Party, Payment)
genPayment WorldState
st Gen (Party, Payment)
-> ((Party, Payment) -> Gen (Any (Action WorldState)))
-> Gen (Any (Action WorldState))
forall a b. Gen a -> (a -> Gen b) -> Gen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(Party
party, Payment
transaction) -> Any (Action WorldState) -> Gen (Any (Action WorldState))
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Any (Action WorldState) -> Gen (Any (Action WorldState)))
-> (Action WorldState Payment -> Any (Action WorldState))
-> Action WorldState Payment
-> Gen (Any (Action WorldState))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Action WorldState Payment -> Any (Action WorldState)
forall a (f :: * -> *). (Typeable a, Eq (f a)) => f a -> Any f
Some (Action WorldState Payment -> Gen (Any (Action WorldState)))
-> Action WorldState Payment -> Gen (Any (Action WorldState))
forall a b. (a -> b) -> a -> b
$ Party -> Payment -> Action WorldState Payment
NewTx Party
party Payment
transaction

    genClose :: Gen (Any (Action WorldState))
genClose =
      Action WorldState () -> Any (Action WorldState)
forall a (f :: * -> *). (Typeable a, Eq (f a)) => f a -> Any f
Some (Action WorldState () -> Any (Action WorldState))
-> ((Secret (SigningKey HydraKey), CardanoSigningKey)
    -> Action WorldState ())
-> (Secret (SigningKey HydraKey), CardanoSigningKey)
-> Any (Action WorldState)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Party -> Action WorldState ()
Close (Party -> Action WorldState ())
-> ((Secret (SigningKey HydraKey), CardanoSigningKey) -> Party)
-> (Secret (SigningKey HydraKey), CardanoSigningKey)
-> Action WorldState ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Secret (SigningKey HydraKey) -> Party
deriveParty (Secret (SigningKey HydraKey) -> Party)
-> ((Secret (SigningKey HydraKey), CardanoSigningKey)
    -> Secret (SigningKey HydraKey))
-> (Secret (SigningKey HydraKey), CardanoSigningKey)
-> Party
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Secret (SigningKey HydraKey), CardanoSigningKey)
-> Secret (SigningKey HydraKey)
forall a b. (a, b) -> a
fst ((Secret (SigningKey HydraKey), CardanoSigningKey)
 -> Any (Action WorldState))
-> Gen (Secret (SigningKey HydraKey), CardanoSigningKey)
-> Gen (Any (Action WorldState))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Secret (SigningKey HydraKey), CardanoSigningKey)]
-> Gen (Secret (SigningKey HydraKey), CardanoSigningKey)
forall a. HasCallStack => [a] -> Gen a
elements [(Secret (SigningKey HydraKey), CardanoSigningKey)]
hydraParties

    genFanout :: Gen (Any (Action WorldState))
genFanout =
      Action WorldState (UTxO Era) -> Any (Action WorldState)
forall a (f :: * -> *). (Typeable a, Eq (f a)) => f a -> Any f
Some (Action WorldState (UTxO Era) -> Any (Action WorldState))
-> ((Secret (SigningKey HydraKey), CardanoSigningKey)
    -> Action WorldState (UTxO Era))
-> (Secret (SigningKey HydraKey), CardanoSigningKey)
-> Any (Action WorldState)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Party -> Action WorldState (UTxO Era)
Fanout (Party -> Action WorldState (UTxO Era))
-> ((Secret (SigningKey HydraKey), CardanoSigningKey) -> Party)
-> (Secret (SigningKey HydraKey), CardanoSigningKey)
-> Action WorldState (UTxO Era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Secret (SigningKey HydraKey) -> Party
deriveParty (Secret (SigningKey HydraKey) -> Party)
-> ((Secret (SigningKey HydraKey), CardanoSigningKey)
    -> Secret (SigningKey HydraKey))
-> (Secret (SigningKey HydraKey), CardanoSigningKey)
-> Party
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Secret (SigningKey HydraKey), CardanoSigningKey)
-> Secret (SigningKey HydraKey)
forall a b. (a, b) -> a
fst ((Secret (SigningKey HydraKey), CardanoSigningKey)
 -> Any (Action WorldState))
-> Gen (Secret (SigningKey HydraKey), CardanoSigningKey)
-> Gen (Any (Action WorldState))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Secret (SigningKey HydraKey), CardanoSigningKey)]
-> Gen (Secret (SigningKey HydraKey), CardanoSigningKey)
forall a. HasCallStack => [a] -> Gen a
elements [(Secret (SigningKey HydraKey), CardanoSigningKey)]
hydraParties

    genRollbackAndForward :: Gen (Any (Action WorldState))
genRollbackAndForward = do
      Word
numberOfBlocks <- (Word, Word) -> Gen Word
forall a. Random a => (a, a) -> Gen a
choose (Word
1, Word
2)
      Any (Action WorldState) -> Gen (Any (Action WorldState))
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Any (Action WorldState) -> Gen (Any (Action WorldState)))
-> (Action WorldState () -> Any (Action WorldState))
-> Action WorldState ()
-> Gen (Any (Action WorldState))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Action WorldState () -> Any (Action WorldState)
forall a (f :: * -> *). (Typeable a, Eq (f a)) => f a -> Any f
Some (Action WorldState () -> Gen (Any (Action WorldState)))
-> Action WorldState () -> Gen (Any (Action WorldState))
forall a b. (a -> b) -> a -> b
$ Natural -> Action WorldState ()
RollbackAndForward (Word -> Natural
wordToNatural Word
numberOfBlocks)

    genRollbackAndFork :: Gen (Any (Action WorldState))
genRollbackAndFork = do
      -- Deep enough to reach a settlement observed a couple of blocks ago
      -- while a later one is still in flight.
      Word
numberOfBlocks <- (Word, Word) -> Gen Word
forall a. Random a => (a, a) -> Gen a
choose (Word
1, Word
4)
      -- Only the concurrent walk relies on the nodes re-posting erased
      -- settlements; the sequential one lets the mempool re-land them.
      RequeueMode
requeueErased <-
        if Bool
concurrentSettlements
          then [RequeueMode] -> Gen RequeueMode
forall a. HasCallStack => [a] -> Gen a
elements [RequeueMode
RequeueAll, RequeueMode
RequeueDeposits, RequeueMode
RequeueNone]
          else RequeueMode -> Gen RequeueMode
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RequeueMode
RequeueAll
      Any (Action WorldState) -> Gen (Any (Action WorldState))
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Any (Action WorldState) -> Gen (Any (Action WorldState)))
-> (Action WorldState () -> Any (Action WorldState))
-> Action WorldState ()
-> Gen (Any (Action WorldState))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Action WorldState () -> Any (Action WorldState)
forall a (f :: * -> *). (Typeable a, Eq (f a)) => f a -> Any f
Some (Action WorldState () -> Gen (Any (Action WorldState)))
-> Action WorldState () -> Gen (Any (Action WorldState))
forall a b. (a -> b) -> a -> b
$ RollbackAndFork{$sel:numberOfBlocks:Seed :: Natural
numberOfBlocks = Word -> Natural
wordToNatural Word
numberOfBlocks, RequeueMode
$sel:requeueErased:Seed :: RequeueMode
requeueErased :: RequeueMode
requeueErased}

    genRestartNode :: Gen (Any (Action WorldState))
genRestartNode =
      Action WorldState () -> Any (Action WorldState)
forall a (f :: * -> *). (Typeable a, Eq (f a)) => f a -> Any f
Some (Action WorldState () -> Any (Action WorldState))
-> ((Secret (SigningKey HydraKey), CardanoSigningKey)
    -> Action WorldState ())
-> (Secret (SigningKey HydraKey), CardanoSigningKey)
-> Any (Action WorldState)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Party -> Action WorldState ()
RestartNode (Party -> Action WorldState ())
-> ((Secret (SigningKey HydraKey), CardanoSigningKey) -> Party)
-> (Secret (SigningKey HydraKey), CardanoSigningKey)
-> Action WorldState ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Secret (SigningKey HydraKey) -> Party
deriveParty (Secret (SigningKey HydraKey) -> Party)
-> ((Secret (SigningKey HydraKey), CardanoSigningKey)
    -> Secret (SigningKey HydraKey))
-> (Secret (SigningKey HydraKey), CardanoSigningKey)
-> Party
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Secret (SigningKey HydraKey), CardanoSigningKey)
-> Secret (SigningKey HydraKey)
forall a b. (a, b) -> a
fst ((Secret (SigningKey HydraKey), CardanoSigningKey)
 -> Any (Action WorldState))
-> Gen (Secret (SigningKey HydraKey), CardanoSigningKey)
-> Gen (Any (Action WorldState))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Secret (SigningKey HydraKey), CardanoSigningKey)]
-> Gen (Secret (SigningKey HydraKey), CardanoSigningKey)
forall a. HasCallStack => [a] -> Gen a
elements [(Secret (SigningKey HydraKey), CardanoSigningKey)]
hydraParties

  precondition :: forall a. WorldState -> Action WorldState a -> Bool
precondition WorldState{$sel:hydraState:WorldState :: WorldState -> GlobalState
hydraState = GlobalState
Start} Seed{} =
    Bool
True
  precondition WorldState{$sel:hydraState:WorldState :: WorldState -> GlobalState
hydraState = Idle{[Party]
$sel:idleParties:Start :: GlobalState -> [Party]
idleParties :: [Party]
idleParties}} (Init Party
p) =
    Party
p Party -> [Party] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` [Party]
idleParties
  precondition WorldState{$sel:hydraState:WorldState :: WorldState -> GlobalState
hydraState = Open{HeadParameters
$sel:headParameters:Start :: GlobalState -> HeadParameters
headParameters :: HeadParameters
headParameters}} Close{Party
$sel:party:Seed :: Action WorldState () -> Party
party :: Party
party} =
    Party
party Party -> [Party] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` HeadParameters
headParameters.parties
  precondition WorldState{$sel:hydraState:WorldState :: WorldState -> GlobalState
hydraState = Open{HeadParameters
$sel:headParameters:Start :: GlobalState -> HeadParameters
headParameters :: HeadParameters
headParameters, OffChainState
$sel:offChainState:Start :: GlobalState -> OffChainState
offChainState :: OffChainState
offChainState}} (NewTx Party
party Payment
tx) =
    Party
party Party -> [Party] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` HeadParameters
headParameters.parties
      Bool -> Bool -> Bool
&& (Payment -> CardanoSigningKey
from Payment
tx, Payment -> Value
value Payment
tx) (CardanoSigningKey, Value) -> [(CardanoSigningKey, Value)] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`List.elem` OffChainState -> UTxOType Payment
confirmedUTxO OffChainState
offChainState
  precondition WorldState
_ Wait{} =
    Bool
True
  precondition WorldState{$sel:hydraState:WorldState :: WorldState -> GlobalState
hydraState = Open{Var HeadId
$sel:headIdVar:Start :: GlobalState -> Var HeadId
headIdVar :: Var HeadId
headIdVar}} Deposit{$sel:headIdVar:Seed :: Action WorldState () -> Var HeadId
headIdVar = Var HeadId
var, UTxOType Payment
$sel:utxoToDeposit:Seed :: Action WorldState () -> UTxOType Payment
utxoToDeposit :: UTxOType Payment
utxoToDeposit} =
    Var HeadId
var Var HeadId -> Var HeadId -> Bool
forall a. Eq a => a -> a -> Bool
== Var HeadId
headIdVar
      -- An empty deposit is rejected at draft time; also keeps shrinking from
      -- emptying a deposit's utxo.
      Bool -> Bool -> Bool
&& Bool -> Bool
not ([(CardanoSigningKey, Value)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(CardanoSigningKey, Value)]
UTxOType Payment
utxoToDeposit)
  precondition WorldState{$sel:hydraState:WorldState :: WorldState -> GlobalState
hydraState = Open{HeadParameters
$sel:headParameters:Start :: GlobalState -> HeadParameters
headParameters :: HeadParameters
headParameters, OffChainState
$sel:offChainState:Start :: GlobalState -> OffChainState
offChainState :: OffChainState
offChainState}} Decommit{Party
$sel:party:Seed :: Action WorldState () -> Party
party :: Party
party, Payment
$sel:decommitTx:Seed :: Action WorldState () -> Payment
decommitTx :: Payment
decommitTx} =
    Party
party Party -> [Party] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` HeadParameters
headParameters.parties
      Bool -> Bool -> Bool
&& (Payment -> CardanoSigningKey
from Payment
decommitTx, Payment -> Value
value Payment
decommitTx) (CardanoSigningKey, Value) -> [(CardanoSigningKey, Value)] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`List.elem` OffChainState -> UTxOType Payment
confirmedUTxO OffChainState
offChainState
  precondition WorldState{$sel:hydraState:WorldState :: WorldState -> GlobalState
hydraState = Open{Var HeadId
$sel:headIdVar:Start :: GlobalState -> Var HeadId
headIdVar :: Var HeadId
headIdVar}} (SubmitDeposit Var HeadId
var UTxOType Payment
utxoToDeposit) =
    Var HeadId
var Var HeadId -> Var HeadId -> Bool
forall a. Eq a => a -> a -> Bool
== Var HeadId
headIdVar
      Bool -> Bool -> Bool
&& Bool -> Bool
not ([(CardanoSigningKey, Value)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(CardanoSigningKey, Value)]
UTxOType Payment
utxoToDeposit)
  precondition WorldState{$sel:hydraState:WorldState :: WorldState -> GlobalState
hydraState = Open{}, [(Var TxId, UTxOType Payment)]
$sel:pendingCommits:WorldState :: WorldState -> [(Var TxId, UTxOType Payment)]
pendingCommits :: [(Var TxId, UTxOType Payment)]
pendingCommits} (ObserveCommitApproved Var TxId
var) =
    Var TxId
var Var TxId -> [Var TxId] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` ((Var TxId, [(CardanoSigningKey, Value)]) -> Var TxId
forall a b. (a, b) -> a
fst ((Var TxId, [(CardanoSigningKey, Value)]) -> Var TxId)
-> [(Var TxId, [(CardanoSigningKey, Value)])] -> [Var TxId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Var TxId, [(CardanoSigningKey, Value)])]
[(Var TxId, UTxOType Payment)]
pendingCommits)
  precondition WorldState{$sel:hydraState:WorldState :: WorldState -> GlobalState
hydraState = Open{}, [(Var TxId, UTxOType Payment)]
$sel:pendingCommits:WorldState :: WorldState -> [(Var TxId, UTxOType Payment)]
pendingCommits :: [(Var TxId, UTxOType Payment)]
pendingCommits, [Var TxId]
$sel:settledCommits:WorldState :: WorldState -> [Var TxId]
settledCommits :: [Var TxId]
settledCommits} (ObserveCommitFinalized Var TxId
var) =
    Var TxId
var Var TxId -> [Var TxId] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` ((Var TxId, [(CardanoSigningKey, Value)]) -> Var TxId
forall a b. (a, b) -> a
fst ((Var TxId, [(CardanoSigningKey, Value)]) -> Var TxId)
-> [(Var TxId, [(CardanoSigningKey, Value)])] -> [Var TxId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Var TxId, [(CardanoSigningKey, Value)])]
[(Var TxId, UTxOType Payment)]
pendingCommits) Bool -> Bool -> Bool
|| Var TxId
var Var TxId -> [Var TxId] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` [Var TxId]
settledCommits
  precondition WorldState{$sel:hydraState:WorldState :: WorldState -> GlobalState
hydraState = Open{HeadParameters
$sel:headParameters:Start :: GlobalState -> HeadParameters
headParameters :: HeadParameters
headParameters, OffChainState
$sel:offChainState:Start :: GlobalState -> OffChainState
offChainState :: OffChainState
offChainState}, [(Var (UTxO Era), Payment)]
$sel:pendingDecommits:WorldState :: WorldState -> [(Var (UTxO Era), Payment)]
pendingDecommits :: [(Var (UTxO Era), Payment)]
pendingDecommits} (SubmitDecommit Party
party Payment
decommitTx) =
    Party
party Party -> [Party] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` HeadParameters
headParameters.parties
      Bool -> Bool -> Bool
&& (Payment -> CardanoSigningKey
from Payment
decommitTx, Payment -> Value
value Payment
decommitTx) (CardanoSigningKey, Value) -> [(CardanoSigningKey, Value)] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`List.elem` OffChainState -> UTxOType Payment
confirmedUTxO OffChainState
offChainState
      -- A decommit requested while another one is unsettled is rejected right
      -- away ('DecommitAlreadyInFlight'): decommits are sequential by design.
      -- One requested while a deposit is unsettled is fine, see
      -- 'performSubmitDecommit'.
      Bool -> Bool -> Bool
&& [(Var (UTxO Era), Payment)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Var (UTxO Era), Payment)]
pendingDecommits
  precondition WorldState{$sel:hydraState:WorldState :: WorldState -> GlobalState
hydraState = Open{}, [(Var (UTxO Era), Payment)]
$sel:pendingDecommits:WorldState :: WorldState -> [(Var (UTxO Era), Payment)]
pendingDecommits :: [(Var (UTxO Era), Payment)]
pendingDecommits, [Var (UTxO Era)]
$sel:settledDecommits:WorldState :: WorldState -> [Var (UTxO Era)]
settledDecommits :: [Var (UTxO Era)]
settledDecommits} (ObserveDecommitFinalized Var (UTxO Era)
var) =
    Var (UTxO Era)
var Var (UTxO Era) -> [Var (UTxO Era)] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` ((Var (UTxO Era), Payment) -> Var (UTxO Era)
forall a b. (a, b) -> a
fst ((Var (UTxO Era), Payment) -> Var (UTxO Era))
-> [(Var (UTxO Era), Payment)] -> [Var (UTxO Era)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Var (UTxO Era), Payment)]
pendingDecommits) Bool -> Bool -> Bool
|| Var (UTxO Era)
var Var (UTxO Era) -> [Var (UTxO Era)] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` [Var (UTxO Era)]
settledDecommits
  precondition WorldState{$sel:hydraState:WorldState :: WorldState -> GlobalState
hydraState = Open{}} (ObserveConfirmedTx Var Payment
_) =
    Bool
True
  precondition WorldState{$sel:hydraState:WorldState :: WorldState -> GlobalState
hydraState = Open{}} Action WorldState a
R:ActionWorldStatea a
ObserveHeadIsOpen =
    Bool
True
  precondition WorldState{$sel:hydraState:WorldState :: WorldState -> GlobalState
hydraState = Closed{HeadParameters
$sel:headParameters:Start :: GlobalState -> HeadParameters
headParameters :: HeadParameters
headParameters, FanoutDriving
$sel:fanoutDriving:Start :: GlobalState -> FanoutDriving
fanoutDriving :: FanoutDriving
fanoutDriving}} (Fanout Party
party) =
    Party
party Party -> [Party] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` HeadParameters
headParameters.parties
      Bool -> Bool -> Bool
&& FanoutDriving
fanoutDriving FanoutDriving -> FanoutDriving -> Bool
forall a. Eq a => a -> a -> Bool
== FanoutDriving
FanoutNotStarted
  precondition WorldState{$sel:hydraState:WorldState :: WorldState -> GlobalState
hydraState = Closed{HeadParameters
$sel:headParameters:Start :: GlobalState -> HeadParameters
headParameters :: HeadParameters
headParameters, FanoutDriving
$sel:fanoutDriving:Start :: GlobalState -> FanoutDriving
fanoutDriving :: FanoutDriving
fanoutDriving}} (StartFanout Party
party) =
    Party
party Party -> [Party] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` HeadParameters
headParameters.parties
      Bool -> Bool -> Bool
&& FanoutDriving
fanoutDriving FanoutDriving -> FanoutDriving -> Bool
forall a. Eq a => a -> a -> Bool
== FanoutDriving
FanoutNotStarted
  precondition WorldState{$sel:hydraState:WorldState :: WorldState -> GlobalState
hydraState = Closed{HeadParameters
$sel:headParameters:Start :: GlobalState -> HeadParameters
headParameters :: HeadParameters
headParameters, FanoutDriving
$sel:fanoutDriving:Start :: GlobalState -> FanoutDriving
fanoutDriving :: FanoutDriving
fanoutDriving, UTxOType Payment
$sel:closedUTxO:Start :: GlobalState -> UTxOType Payment
closedUTxO :: UTxOType Payment
closedUTxO, UTxOType Payment
$sel:fannedOut:Start :: GlobalState -> UTxOType Payment
fannedOut :: UTxOType Payment
fannedOut}} (PartialFanoutStep Party
party UTxOType Payment
selection) =
    Party
party Party -> [Party] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` HeadParameters
headParameters.parties
      Bool -> Bool -> Bool
&& FanoutDriving
fanoutDriving FanoutDriving -> FanoutDriving -> Bool
forall a. Eq a => a -> a -> Bool
/= FanoutDriving
FanoutAutoDraining
      Bool -> Bool -> Bool
&& Bool -> Bool
not ([(CardanoSigningKey, Value)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(CardanoSigningKey, Value)]
UTxOType Payment
selection)
      Bool -> Bool -> Bool
&& ((CardanoSigningKey, Value) -> Bool)
-> [(CardanoSigningKey, Value)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((CardanoSigningKey, Value) -> [(CardanoSigningKey, Value)] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` ([(CardanoSigningKey, Value)]
UTxOType Payment
closedUTxO [(CardanoSigningKey, Value)]
-> [(CardanoSigningKey, Value)] -> [(CardanoSigningKey, Value)]
forall a. Eq a => [a] -> [a] -> [a]
\\ [(CardanoSigningKey, Value)]
UTxOType Payment
fannedOut)) [(CardanoSigningKey, Value)]
UTxOType Payment
selection
  precondition WorldState{$sel:hydraState:WorldState :: WorldState -> GlobalState
hydraState = Closed{FanoutDriving
$sel:fanoutDriving:Start :: GlobalState -> FanoutDriving
fanoutDriving :: FanoutDriving
fanoutDriving}} (ObservePartialFanoutSteps Int
n) =
    FanoutDriving
fanoutDriving FanoutDriving -> FanoutDriving -> Bool
forall a. Eq a => a -> a -> Bool
/= FanoutDriving
FanoutNotStarted Bool -> Bool -> Bool
&& Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
  precondition WorldState{$sel:hydraState:WorldState :: WorldState -> GlobalState
hydraState = Closed{HeadParameters
$sel:headParameters:Start :: GlobalState -> HeadParameters
headParameters :: HeadParameters
headParameters, FanoutDriving
$sel:fanoutDriving:Start :: GlobalState -> FanoutDriving
fanoutDriving :: FanoutDriving
fanoutDriving}} (ObserveFanoutFinalized Party
party) =
    Party
party Party -> [Party] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` HeadParameters
headParameters.parties
      Bool -> Bool -> Bool
&& FanoutDriving
fanoutDriving FanoutDriving -> FanoutDriving -> Bool
forall a. Eq a => a -> a -> Bool
/= FanoutDriving
FanoutNotStarted
  precondition WorldState{$sel:hydraState:WorldState :: WorldState -> GlobalState
hydraState = Open{HeadParameters
$sel:headParameters:Start :: GlobalState -> HeadParameters
headParameters :: HeadParameters
headParameters, Natural
$sel:onChainVersion:Start :: GlobalState -> Natural
onChainVersion :: Natural
onChainVersion}, [(Var TxId, UTxOType Payment)]
$sel:pendingCommits:WorldState :: WorldState -> [(Var TxId, UTxOType Payment)]
pendingCommits :: [(Var TxId, UTxOType Payment)]
pendingCommits, [(Var (UTxO Era), Payment)]
$sel:pendingDecommits:WorldState :: WorldState -> [(Var (UTxO Era), Payment)]
pendingDecommits :: [(Var (UTxO Era), Payment)]
pendingDecommits} (CloseWithInitialSnapshot Party
p) =
    -- Only head members have a node to close with; keeps shrinking from
    -- rebinding the action to a party outside the (shrunk) seed. Closing with
    -- the initial snapshot (and open version 0) is only valid on-chain while
    -- no increment or decrement has settled — nor is about to.
    Party
p Party -> [Party] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` HeadParameters
headParameters.parties
      Bool -> Bool -> Bool
&& Natural
onChainVersion Natural -> Natural -> Bool
forall a. Eq a => a -> a -> Bool
== Natural
0
      Bool -> Bool -> Bool
&& [(Var TxId, [(CardanoSigningKey, Value)])] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Var TxId, [(CardanoSigningKey, Value)])]
[(Var TxId, UTxOType Payment)]
pendingCommits
      Bool -> Bool -> Bool
&& [(Var (UTxO Era), Payment)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Var (UTxO Era), Payment)]
pendingDecommits
  -- A fork while the fanout is in progress: the node has to re-post the step
  -- that was erased.
  precondition WorldState{$sel:hydraState:WorldState :: WorldState -> GlobalState
hydraState = Closed{FanoutDriving
$sel:fanoutDriving:Start :: GlobalState -> FanoutDriving
fanoutDriving :: FanoutDriving
fanoutDriving}} RollbackAndFork{} =
    FanoutDriving
fanoutDriving FanoutDriving -> FanoutDriving -> Bool
forall a. Eq a => a -> a -> Bool
/= FanoutDriving
FanoutNotStarted
  precondition WorldState{$sel:hydraState:WorldState :: WorldState -> GlobalState
hydraState = Open{}, [(Var TxId, UTxOType Payment)]
$sel:pendingCommits:WorldState :: WorldState -> [(Var TxId, UTxOType Payment)]
pendingCommits :: [(Var TxId, UTxOType Payment)]
pendingCommits} RollbackAndFork{RequeueMode
$sel:requeueErased:Seed :: Action WorldState () -> RequeueMode
requeueErased :: RequeueMode
requeueErased} =
    -- A fork that drops deposit transactions for good may hit one that is
    -- only a few blocks old: those funds are then simply gone from L1 (the
    -- depositor would have to deposit again), which the model does not track.
    -- Settled deposits are safe: their deposit transaction precedes the
    -- increment by at least the activation period (5 blocks), more than the
    -- generated fork depth.
    RequeueMode
requeueErased RequeueMode -> RequeueMode -> Bool
forall a. Eq a => a -> a -> Bool
/= RequeueMode
RequeueNone Bool -> Bool -> Bool
|| [(Var TxId, [(CardanoSigningKey, Value)])] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Var TxId, [(CardanoSigningKey, Value)])]
[(Var TxId, UTxOType Payment)]
pendingCommits
  precondition WorldState{$sel:hydraState:WorldState :: WorldState -> GlobalState
hydraState = Open{HeadParameters
$sel:headParameters:Start :: GlobalState -> HeadParameters
headParameters :: HeadParameters
headParameters}} (RestartNode Party
p) =
    Party
p Party -> [Party] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` HeadParameters
headParameters.parties
  precondition WorldState{GlobalState
$sel:hydraState:WorldState :: WorldState -> GlobalState
hydraState :: GlobalState
hydraState} (RollbackAndForward Natural
_) =
    case GlobalState
hydraState of
      Start{} -> Bool
False
      Idle{} -> Bool
False
      Open{} -> Bool
True
      Closed{} -> Bool
True
      Final{} -> Bool
False
  precondition WorldState
_ Action WorldState a
R:ActionWorldStatea a
StopTheWorld =
    Bool
True
  precondition WorldState
_ Action WorldState a
_ =
    Bool
False

  nextState :: forall a.
Typeable a =>
WorldState -> Action WorldState a -> Var a -> WorldState
nextState s :: WorldState
s@WorldState{GlobalState
$sel:hydraState:WorldState :: WorldState -> GlobalState
hydraState :: GlobalState
hydraState, UTxOType Payment
$sel:availableToDeposit:WorldState :: WorldState -> UTxOType Payment
availableToDeposit :: UTxOType Payment
availableToDeposit, [(Var TxId, UTxOType Payment)]
$sel:pendingCommits:WorldState :: WorldState -> [(Var TxId, UTxOType Payment)]
pendingCommits :: [(Var TxId, UTxOType Payment)]
pendingCommits, [(Var (UTxO Era), Payment)]
$sel:pendingDecommits:WorldState :: WorldState -> [(Var (UTxO Era), Payment)]
pendingDecommits :: [(Var (UTxO Era), Payment)]
pendingDecommits, [Var TxId]
$sel:settledCommits:WorldState :: WorldState -> [Var TxId]
settledCommits :: [Var TxId]
settledCommits, [Var (UTxO Era)]
$sel:settledDecommits:WorldState :: WorldState -> [Var (UTxO Era)]
settledDecommits :: [Var (UTxO Era)]
settledDecommits} Action WorldState a
a Var a
result =
    case Action WorldState a
a of
      Seed{[(Secret (SigningKey HydraKey), CardanoSigningKey)]
$sel:seedKeys:Seed :: Action WorldState ()
-> [(Secret (SigningKey HydraKey), CardanoSigningKey)]
seedKeys :: [(Secret (SigningKey HydraKey), CardanoSigningKey)]
seedKeys, ContestationPeriod
$sel:contestationPeriod:Seed :: Action WorldState () -> ContestationPeriod
contestationPeriod :: ContestationPeriod
contestationPeriod, UTxOType Payment
additionalUTxO :: Action WorldState () -> UTxOType Payment
additionalUTxO :: UTxOType Payment
additionalUTxO, Bool
$sel:concurrentSettlements:Seed :: Action WorldState () -> Bool
concurrentSettlements :: Bool
concurrentSettlements} ->
        WorldState
s{hydraParties = seedKeys, hydraState = idleState, availableToDeposit = additionalUTxO, concurrentSettlements}
       where
        idleState :: GlobalState
idleState = Idle{[Party]
$sel:idleParties:Start :: [Party]
idleParties :: [Party]
idleParties, [VerificationKey PaymentKey]
$sel:cardanoKeys:Start :: [VerificationKey PaymentKey]
cardanoKeys :: [VerificationKey PaymentKey]
cardanoKeys, ContestationPeriod
$sel:contestationPeriod:Start :: ContestationPeriod
contestationPeriod :: ContestationPeriod
contestationPeriod}
        idleParties :: [Party]
idleParties = ((Secret (SigningKey HydraKey), CardanoSigningKey) -> Party)
-> [(Secret (SigningKey HydraKey), CardanoSigningKey)] -> [Party]
forall a b. (a -> b) -> [a] -> [b]
map (Secret (SigningKey HydraKey) -> Party
deriveParty (Secret (SigningKey HydraKey) -> Party)
-> ((Secret (SigningKey HydraKey), CardanoSigningKey)
    -> Secret (SigningKey HydraKey))
-> (Secret (SigningKey HydraKey), CardanoSigningKey)
-> Party
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Secret (SigningKey HydraKey), CardanoSigningKey)
-> Secret (SigningKey HydraKey)
forall a b. (a, b) -> a
fst) [(Secret (SigningKey HydraKey), CardanoSigningKey)]
seedKeys
        cardanoKeys :: [VerificationKey PaymentKey]
cardanoKeys = ((Secret (SigningKey HydraKey), CardanoSigningKey)
 -> VerificationKey PaymentKey)
-> [(Secret (SigningKey HydraKey), CardanoSigningKey)]
-> [VerificationKey PaymentKey]
forall a b. (a -> b) -> [a] -> [b]
map (\(Secret (SigningKey HydraKey)
_, CardanoSigningKey Secret (SigningKey PaymentKey)
sk) -> Secret (SigningKey PaymentKey) -> VerificationKey PaymentKey
forall s k. HasVerificationKey s k => s -> VerificationKey k
getVerificationKey Secret (SigningKey PaymentKey)
sk) [(Secret (SigningKey HydraKey), CardanoSigningKey)]
seedKeys
      Init{} ->
        WorldState
s{hydraState = mkInitialState hydraState}
       where
        mkInitialState :: GlobalState -> GlobalState
mkInitialState = \case
          Idle{[Party]
$sel:idleParties:Start :: GlobalState -> [Party]
idleParties :: [Party]
idleParties, ContestationPeriod
$sel:contestationPeriod:Start :: GlobalState -> ContestationPeriod
contestationPeriod :: ContestationPeriod
contestationPeriod} ->
            Open
              { $sel:headIdVar:Start :: Var HeadId
headIdVar = Var a
Var HeadId
result
              , $sel:headParameters:Start :: HeadParameters
headParameters =
                  HeadParameters
                    { $sel:parties:HeadParameters :: [Party]
parties = [Party]
idleParties
                    , $sel:contestationPeriod:HeadParameters :: ContestationPeriod
contestationPeriod = ContestationPeriod
contestationPeriod
                    , $sel:depositPeriod:HeadParameters :: DepositPeriod
depositPeriod = DepositPeriod
defaultDepositPeriod
                    }
              , $sel:offChainState:Start :: OffChainState
offChainState = OffChainState{$sel:confirmedUTxO:OffChainState :: UTxOType Payment
confirmedUTxO = [(CardanoSigningKey, Value)]
UTxOType Payment
forall a. Monoid a => a
mempty}
              , $sel:committed:Start :: Map Party (UTxOType Payment)
committed = Map Party [(CardanoSigningKey, Value)]
Map Party (UTxOType Payment)
forall a. Monoid a => a
mempty
              , $sel:onChainVersion:Start :: Natural
onChainVersion = Natural
0
              }
          GlobalState
_ -> Text -> GlobalState
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"unexpected state"
      Deposit{UTxOType Payment
$sel:utxoToDeposit:Seed :: Action WorldState () -> UTxOType Payment
utxoToDeposit :: UTxOType Payment
utxoToDeposit} ->
        WorldState
s
          { hydraState = settleCommit utxoToDeposit hydraState
          , availableToDeposit = availableToDeposit \\ utxoToDeposit
          }
      Decommit Party
_party Payment
tx ->
        WorldState
s{hydraState = settleDecommit tx (removeDecommitted tx hydraState)}
      -- The deposit leaves the pool right away, but only counts as in the
      -- head (and bumps the on-chain version) once observed as finalized.
      SubmitDeposit Var HeadId
_ UTxOType Payment
utxoToDeposit ->
        WorldState
s
          { availableToDeposit = availableToDeposit \\ utxoToDeposit
          , pendingCommits = (result, utxoToDeposit) : pendingCommits
          }
      ObserveCommitApproved Var TxId
_ -> WorldState
s
      ObserveCommitFinalized Var TxId
var ->
        case Var TxId
-> [(Var TxId, [(CardanoSigningKey, Value)])]
-> Maybe [(CardanoSigningKey, Value)]
forall a b. Eq a => a -> [(a, b)] -> Maybe b
List.lookup Var TxId
var [(Var TxId, [(CardanoSigningKey, Value)])]
[(Var TxId, UTxOType Payment)]
pendingCommits of
          -- Re-observation of an already settled commit: only count it.
          Maybe [(CardanoSigningKey, Value)]
Nothing -> WorldState
s{settledCommits = var : settledCommits}
          Just [(CardanoSigningKey, Value)]
utxo ->
            WorldState
s
              { hydraState = settleCommit utxo hydraState
              , pendingCommits = filter ((/= var) . fst) pendingCommits
              , settledCommits = var : settledCommits
              }
      -- The decommitted output leaves the L2 ledger with the snapshot (which
      -- 'SubmitDecommit' waits for), the on-chain version bumps with the
      -- decrement.
      SubmitDecommit Party
_ Payment
tx ->
        WorldState
s
          { hydraState = removeDecommitted tx hydraState
          , pendingDecommits = (result, tx) : pendingDecommits
          }
      ObserveDecommitFinalized Var (UTxO Era)
var ->
        case Var (UTxO Era) -> [(Var (UTxO Era), Payment)] -> Maybe Payment
forall a b. Eq a => a -> [(a, b)] -> Maybe b
List.lookup Var (UTxO Era)
var [(Var (UTxO Era), Payment)]
pendingDecommits of
          Maybe Payment
Nothing -> WorldState
s{settledDecommits = var : settledDecommits}
          Just Payment
tx ->
            WorldState
s
              { hydraState = settleDecommit tx hydraState
              , pendingDecommits = filter ((/= var) . fst) pendingDecommits
              , settledDecommits = var : settledDecommits
              }
      Close{} ->
        GlobalState -> WorldState
closeWith GlobalState
hydraState
      Fanout{} ->
        WorldState
s{hydraState = updateWithFanout hydraState}
      ObserveFanoutFinalized{} ->
        WorldState
s{hydraState = updateWithFanout hydraState}
      StartFanout{} ->
        WorldState
s{hydraState = startAutoFanout hydraState}
      PartialFanoutStep Party
_ UTxOType Payment
selection ->
        WorldState
s{hydraState = manualFanoutStep selection hydraState}
      ObservePartialFanoutSteps{} -> WorldState
s
      (NewTx Party
_ Payment
tx) ->
        WorldState
s{hydraState = updateWithNewTx hydraState}
       where
        updateWithNewTx :: GlobalState -> GlobalState
updateWithNewTx = \case
          hs :: GlobalState
hs@Open{$sel:offChainState:Start :: GlobalState -> OffChainState
offChainState = OffChainState{UTxOType Payment
$sel:confirmedUTxO:OffChainState :: OffChainState -> UTxOType Payment
confirmedUTxO :: UTxOType Payment
confirmedUTxO}} ->
            GlobalState
hs
              { offChainState =
                  OffChainState
                    { confirmedUTxO = confirmedUTxO `applyTx` tx
                    }
              }
          GlobalState
_ -> Text -> GlobalState
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"unexpected state"
      CloseWithInitialSnapshot Party
_ ->
        GlobalState -> WorldState
closeWith GlobalState
hydraState
      RollbackAndForward Natural
_numberOfBlocks -> WorldState
s
      RollbackAndFork{} -> WorldState
s
      RestartNode{} -> WorldState
s
      Wait DiffTime
_ -> WorldState
s
      ObserveConfirmedTx Var Payment
_ -> WorldState
s
      Action WorldState a
R:ActionWorldStatea a
ObserveHeadIsOpen -> WorldState
s
      Action WorldState a
R:ActionWorldStatea a
StopTheWorld -> WorldState
s
   where
    updateWithFanout :: GlobalState -> GlobalState
updateWithFanout = \case
      Closed{UTxOType Payment
$sel:closedUTxO:Start :: GlobalState -> UTxOType Payment
closedUTxO :: UTxOType Payment
closedUTxO, UTxOType Payment
$sel:unsettledAtClose:Start :: GlobalState -> UTxOType Payment
unsettledAtClose :: UTxOType Payment
unsettledAtClose} -> Final{$sel:finalUTxO:Start :: UTxOType Payment
finalUTxO = UTxOType Payment
closedUTxO, $sel:unsettledAtFinal:Start :: UTxOType Payment
unsettledAtFinal = UTxOType Payment
unsettledAtClose}
      GlobalState
_ -> Text -> GlobalState
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"unexpected state"

    startAutoFanout :: GlobalState -> GlobalState
startAutoFanout = \case
      c :: GlobalState
c@Closed{} -> GlobalState
c{fanoutDriving = FanoutAutoDraining}
      GlobalState
_ -> Text -> GlobalState
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"unexpected state"

    manualFanoutStep :: [(CardanoSigningKey, Value)] -> GlobalState -> GlobalState
manualFanoutStep [(CardanoSigningKey, Value)]
selection = \case
      c :: GlobalState
c@Closed{UTxOType Payment
$sel:fannedOut:Start :: GlobalState -> UTxOType Payment
fannedOut :: UTxOType Payment
fannedOut} -> GlobalState
c{fanoutDriving = FanoutManual, fannedOut = fannedOut <> selection}
      GlobalState
_ -> Text -> GlobalState
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"unexpected state"

    -- Closing settles the pending lists: whatever was still in flight may or
    -- may not make it into the head, see 'unsettledAtClose'.
    closeWith :: GlobalState -> WorldState
closeWith = \case
      Open{$sel:offChainState:Start :: GlobalState -> OffChainState
offChainState = OffChainState{UTxOType Payment
$sel:confirmedUTxO:OffChainState :: OffChainState -> UTxOType Payment
confirmedUTxO :: UTxOType Payment
confirmedUTxO}, HeadParameters
$sel:headParameters:Start :: GlobalState -> HeadParameters
headParameters :: HeadParameters
headParameters} ->
        WorldState
s
          { hydraState =
              Closed
                { headParameters
                , closedUTxO = confirmedUTxO
                , unsettledAtClose =
                    concatMap snd pendingCommits
                      <> [(to, value) | (_, Payment{to, value}) <- pendingDecommits]
                , fanoutDriving = FanoutNotStarted
                , fannedOut = mempty
                }
          , pendingCommits = mempty
          , pendingDecommits = mempty
          }
      GlobalState
_ -> Text -> WorldState
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"unexpected state"

  shrinkAction :: forall a.
Typeable a =>
VarContext
-> WorldState -> Action WorldState a -> [Any (Action WorldState)]
shrinkAction VarContext
_ctx WorldState
_st = \case
    seed :: Action WorldState a
seed@Seed{[(Secret (SigningKey HydraKey), CardanoSigningKey)]
$sel:seedKeys:Seed :: Action WorldState ()
-> [(Secret (SigningKey HydraKey), CardanoSigningKey)]
seedKeys :: [(Secret (SigningKey HydraKey), CardanoSigningKey)]
seedKeys, UTxOType Payment
additionalUTxO :: Action WorldState () -> UTxOType Payment
additionalUTxO :: UTxOType Payment
additionalUTxO} -> do
      [(Secret (SigningKey HydraKey), CardanoSigningKey)]
seedKeys' <- [(Secret (SigningKey HydraKey), CardanoSigningKey)]
-> [[(Secret (SigningKey HydraKey), CardanoSigningKey)]]
forall a. Arbitrary a => a -> [a]
shrink [(Secret (SigningKey HydraKey), CardanoSigningKey)]
seedKeys
      Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> [()]) -> Bool -> [()]
forall a b. (a -> b) -> a -> b
$ [(Secret (SigningKey HydraKey), CardanoSigningKey)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Secret (SigningKey HydraKey), CardanoSigningKey)]
seedKeys' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< [(Secret (SigningKey HydraKey), CardanoSigningKey)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Secret (SigningKey HydraKey), CardanoSigningKey)]
seedKeys
      let cardanoKeys' :: [CardanoSigningKey]
cardanoKeys' = (Secret (SigningKey HydraKey), CardanoSigningKey)
-> CardanoSigningKey
forall a b. (a, b) -> b
snd ((Secret (SigningKey HydraKey), CardanoSigningKey)
 -> CardanoSigningKey)
-> [(Secret (SigningKey HydraKey), CardanoSigningKey)]
-> [CardanoSigningKey]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Secret (SigningKey HydraKey), CardanoSigningKey)]
seedKeys'
      Any (Action WorldState) -> [Any (Action WorldState)]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Any (Action WorldState) -> [Any (Action WorldState)])
-> Any (Action WorldState) -> [Any (Action WorldState)]
forall a b. (a -> b) -> a -> b
$ Action WorldState () -> Any (Action WorldState)
forall a (f :: * -> *). (Typeable a, Eq (f a)) => f a -> Any f
Some (Action WorldState () -> Any (Action WorldState))
-> Action WorldState () -> Any (Action WorldState)
forall a b. (a -> b) -> a -> b
$ Action WorldState a
seed{seedKeys = seedKeys', additionalUTxO = filter ((`elem` cardanoKeys') . fst) additionalUTxO}
    Action WorldState a
_other -> []

-- | Add a finalized commit to the head's UTxO and bump the on-chain version.
settleCommit :: UTxOType Payment -> GlobalState -> GlobalState
settleCommit :: UTxOType Payment -> GlobalState -> GlobalState
settleCommit UTxOType Payment
utxo = \case
  hs :: GlobalState
hs@Open{$sel:offChainState:Start :: GlobalState -> OffChainState
offChainState = OffChainState{UTxOType Payment
$sel:confirmedUTxO:OffChainState :: OffChainState -> UTxOType Payment
confirmedUTxO :: UTxOType Payment
confirmedUTxO}, Natural
$sel:onChainVersion:Start :: GlobalState -> Natural
onChainVersion :: Natural
onChainVersion} ->
    GlobalState
hs
      { offChainState = OffChainState{confirmedUTxO = utxo <> confirmedUTxO}
      , onChainVersion = onChainVersion + 1
      }
  GlobalState
_ -> Text -> GlobalState
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"unexpected state"

-- | Remove a decommitted output from the head's UTxO (it leaves the L2 ledger
-- with the snapshot carrying the decommit).
removeDecommitted :: Payment -> GlobalState -> GlobalState
removeDecommitted :: Payment -> GlobalState -> GlobalState
removeDecommitted Payment
tx = \case
  hs :: GlobalState
hs@Open{$sel:offChainState:Start :: GlobalState -> OffChainState
offChainState = OffChainState{UTxOType Payment
$sel:confirmedUTxO:OffChainState :: OffChainState -> UTxOType Payment
confirmedUTxO :: UTxOType Payment
confirmedUTxO}} ->
    GlobalState
hs{offChainState = OffChainState{confirmedUTxO = List.delete (from tx, value tx) confirmedUTxO}}
  GlobalState
_ -> Text -> GlobalState
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"unexpected state"

-- | Account for a finalized decrement: bump the on-chain version.
settleDecommit :: Payment -> GlobalState -> GlobalState
settleDecommit :: Payment -> GlobalState -> GlobalState
settleDecommit Payment
_ = \case
  hs :: GlobalState
hs@Open{Natural
$sel:onChainVersion:Start :: GlobalState -> Natural
onChainVersion :: Natural
onChainVersion} -> GlobalState
hs{onChainVersion = onChainVersion + 1}
  GlobalState
_ -> Text -> GlobalState
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"unexpected state"

instance HasVariables WorldState where
  getAllVariables :: WorldState -> Set (Any Var)
getAllVariables WorldState{GlobalState
$sel:hydraState:WorldState :: WorldState -> GlobalState
hydraState :: GlobalState
hydraState, [(Var TxId, UTxOType Payment)]
$sel:pendingCommits:WorldState :: WorldState -> [(Var TxId, UTxOType Payment)]
pendingCommits :: [(Var TxId, UTxOType Payment)]
pendingCommits, [(Var (UTxO Era), Payment)]
$sel:pendingDecommits:WorldState :: WorldState -> [(Var (UTxO Era), Payment)]
pendingDecommits :: [(Var (UTxO Era), Payment)]
pendingDecommits, [Var TxId]
$sel:settledCommits:WorldState :: WorldState -> [Var TxId]
settledCommits :: [Var TxId]
settledCommits, [Var (UTxO Era)]
$sel:settledDecommits:WorldState :: WorldState -> [Var (UTxO Era)]
settledDecommits :: [Var (UTxO Era)]
settledDecommits} =
    [Any Var] -> Set (Any Var)
forall a. Ord a => [a] -> Set a
Set.fromList (Var TxId -> Any Var
forall a (f :: * -> *). (Typeable a, Eq (f a)) => f a -> Any f
Some (Var TxId -> Any Var)
-> ((Var TxId, [(CardanoSigningKey, Value)]) -> Var TxId)
-> (Var TxId, [(CardanoSigningKey, Value)])
-> Any Var
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Var TxId, [(CardanoSigningKey, Value)]) -> Var TxId
forall a b. (a, b) -> a
fst ((Var TxId, [(CardanoSigningKey, Value)]) -> Any Var)
-> [(Var TxId, [(CardanoSigningKey, Value)])] -> [Any Var]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Var TxId, [(CardanoSigningKey, Value)])]
[(Var TxId, UTxOType Payment)]
pendingCommits)
      Set (Any Var) -> Set (Any Var) -> Set (Any Var)
forall a. Semigroup a => a -> a -> a
<> [Any Var] -> Set (Any Var)
forall a. Ord a => [a] -> Set a
Set.fromList (Var (UTxO Era) -> Any Var
forall a (f :: * -> *). (Typeable a, Eq (f a)) => f a -> Any f
Some (Var (UTxO Era) -> Any Var)
-> ((Var (UTxO Era), Payment) -> Var (UTxO Era))
-> (Var (UTxO Era), Payment)
-> Any Var
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Var (UTxO Era), Payment) -> Var (UTxO Era)
forall a b. (a, b) -> a
fst ((Var (UTxO Era), Payment) -> Any Var)
-> [(Var (UTxO Era), Payment)] -> [Any Var]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Var (UTxO Era), Payment)]
pendingDecommits)
      Set (Any Var) -> Set (Any Var) -> Set (Any Var)
forall a. Semigroup a => a -> a -> a
<> [Any Var] -> Set (Any Var)
forall a. Ord a => [a] -> Set a
Set.fromList (Var TxId -> Any Var
forall a (f :: * -> *). (Typeable a, Eq (f a)) => f a -> Any f
Some (Var TxId -> Any Var) -> [Var TxId] -> [Any Var]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Var TxId]
settledCommits)
      Set (Any Var) -> Set (Any Var) -> Set (Any Var)
forall a. Semigroup a => a -> a -> a
<> [Any Var] -> Set (Any Var)
forall a. Ord a => [a] -> Set a
Set.fromList (Var (UTxO Era) -> Any Var
forall a (f :: * -> *). (Typeable a, Eq (f a)) => f a -> Any f
Some (Var (UTxO Era) -> Any Var) -> [Var (UTxO Era)] -> [Any Var]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Var (UTxO Era)]
settledDecommits)
      Set (Any Var) -> Set (Any Var) -> Set (Any Var)
forall a. Semigroup a => a -> a -> a
<> case GlobalState
hydraState of
        Open{Var HeadId
$sel:headIdVar:Start :: GlobalState -> Var HeadId
headIdVar :: Var HeadId
headIdVar} -> Any Var -> Set (Any Var)
forall a. a -> Set a
Set.singleton (Any Var -> Set (Any Var)) -> Any Var -> Set (Any Var)
forall a b. (a -> b) -> a -> b
$ Var HeadId -> Any Var
forall a (f :: * -> *). (Typeable a, Eq (f a)) => f a -> Any f
Some Var HeadId
headIdVar
        GlobalState
_ -> Set (Any Var)
forall a. Monoid a => a
mempty

instance HasVariables (Action WorldState a) where
  getAllVariables :: Action WorldState a -> Set (Any Var)
getAllVariables = \case
    Deposit{Var HeadId
$sel:headIdVar:Seed :: Action WorldState () -> Var HeadId
headIdVar :: Var HeadId
headIdVar} -> Any Var -> Set (Any Var)
forall a. a -> Set a
Set.singleton (Any Var -> Set (Any Var)) -> Any Var -> Set (Any Var)
forall a b. (a -> b) -> a -> b
$ Var HeadId -> Any Var
forall a (f :: * -> *). (Typeable a, Eq (f a)) => f a -> Any f
Some Var HeadId
headIdVar
    SubmitDeposit Var HeadId
headIdVar UTxOType Payment
_ -> Any Var -> Set (Any Var)
forall a. a -> Set a
Set.singleton (Any Var -> Set (Any Var)) -> Any Var -> Set (Any Var)
forall a b. (a -> b) -> a -> b
$ Var HeadId -> Any Var
forall a (f :: * -> *). (Typeable a, Eq (f a)) => f a -> Any f
Some Var HeadId
headIdVar
    ObserveCommitApproved Var TxId
var -> Any Var -> Set (Any Var)
forall a. a -> Set a
Set.singleton (Any Var -> Set (Any Var)) -> Any Var -> Set (Any Var)
forall a b. (a -> b) -> a -> b
$ Var TxId -> Any Var
forall a (f :: * -> *). (Typeable a, Eq (f a)) => f a -> Any f
Some Var TxId
var
    ObserveCommitFinalized Var TxId
var -> Any Var -> Set (Any Var)
forall a. a -> Set a
Set.singleton (Any Var -> Set (Any Var)) -> Any Var -> Set (Any Var)
forall a b. (a -> b) -> a -> b
$ Var TxId -> Any Var
forall a (f :: * -> *). (Typeable a, Eq (f a)) => f a -> Any f
Some Var TxId
var
    ObserveDecommitFinalized Var (UTxO Era)
var -> Any Var -> Set (Any Var)
forall a. a -> Set a
Set.singleton (Any Var -> Set (Any Var)) -> Any Var -> Set (Any Var)
forall a b. (a -> b) -> a -> b
$ Var (UTxO Era) -> Any Var
forall a (f :: * -> *). (Typeable a, Eq (f a)) => f a -> Any f
Some Var (UTxO Era)
var
    ObserveConfirmedTx Var Payment
tx -> Any Var -> Set (Any Var)
forall a. a -> Set a
Set.singleton (Any Var -> Set (Any Var)) -> Any Var -> Set (Any Var)
forall a b. (a -> b) -> a -> b
$ Var Payment -> Any Var
forall a (f :: * -> *). (Typeable a, Eq (f a)) => f a -> Any f
Some Var Payment
tx
    Action WorldState a
_other -> Set (Any Var)
forall a. Monoid a => a
mempty

deriving stock instance Show (Action WorldState a)
deriving stock instance Eq (Action WorldState a)

-- ** Generator Helper

-- | Whether random 'RestartNode' actions are generated. On: a restarted node
-- recovers head state (event store), chain point, network consumer offset
-- (etcd-style) and the full chain-sync 'localChainState' history, so it
-- converges under load like a real fail-recovery. Flip to 'False' to drop the
-- fail-recovery dimension if it ever proves flaky.
restartNodeEnabled :: Bool
restartNodeEnabled :: Bool
restartNodeEnabled = Bool
True

-- | The default seed settles each deposit and decommit before the next
-- action, see 'concurrentSettlements'.
genSeed :: Gen (Action WorldState ())
genSeed :: Gen (Action WorldState ())
genSeed = Bool -> Gen (Action WorldState ())
genSeedWith Bool
False

genSeedWith :: Bool -> Gen (Action WorldState ())
genSeedWith :: Bool -> Gen (Action WorldState ())
genSeedWith Bool
concurrentSettlements = do
  [(Secret (SigningKey HydraKey), CardanoSigningKey)]
seedKeys <- Int
-> Gen [(Secret (SigningKey HydraKey), CardanoSigningKey)]
-> Gen [(Secret (SigningKey HydraKey), CardanoSigningKey)]
forall a. HasCallStack => Int -> Gen a -> Gen a
resize Int
maximumNumberOfParties Gen [(Secret (SigningKey HydraKey), CardanoSigningKey)]
partyKeys
  ContestationPeriod
contestationPeriod <- Gen ContestationPeriod
genContestationPeriod
  -- NOTE: Unique (signer, value) pairs: 'toRealUTxO' derives mocked TxIns
  -- from them, so duplicates deposited in separate actions would collide.
  [(CardanoSigningKey, Value)]
additionalUTxO <- ([(CardanoSigningKey, Value)] -> [(CardanoSigningKey, Value)])
-> Gen [(CardanoSigningKey, Value)]
-> Gen [(CardanoSigningKey, Value)]
forall a b. (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(CardanoSigningKey, Value)] -> [(CardanoSigningKey, Value)]
forall a. Eq a => [a] -> [a]
nub (Gen [(CardanoSigningKey, Value)]
 -> Gen [(CardanoSigningKey, Value)])
-> (Gen (CardanoSigningKey, Value)
    -> Gen [(CardanoSigningKey, Value)])
-> Gen (CardanoSigningKey, Value)
-> Gen [(CardanoSigningKey, Value)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Gen (CardanoSigningKey, Value) -> Gen [(CardanoSigningKey, Value)]
forall a. Gen a -> Gen [a]
listOf (Gen (CardanoSigningKey, Value)
 -> Gen [(CardanoSigningKey, Value)])
-> Gen (CardanoSigningKey, Value)
-> Gen [(CardanoSigningKey, Value)]
forall a b. (a -> b) -> a -> b
$ do
    CardanoSigningKey
sk <- (Secret (SigningKey HydraKey), CardanoSigningKey)
-> CardanoSigningKey
forall a b. (a, b) -> b
snd ((Secret (SigningKey HydraKey), CardanoSigningKey)
 -> CardanoSigningKey)
-> Gen (Secret (SigningKey HydraKey), CardanoSigningKey)
-> Gen CardanoSigningKey
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Secret (SigningKey HydraKey), CardanoSigningKey)]
-> Gen (Secret (SigningKey HydraKey), CardanoSigningKey)
forall a. HasCallStack => [a] -> Gen a
elements [(Secret (SigningKey HydraKey), CardanoSigningKey)]
seedKeys
    Value
value <- Gen Value
genAdaValue
    (CardanoSigningKey, Value) -> Gen (CardanoSigningKey, Value)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CardanoSigningKey
sk, Value
value)
  Action WorldState () -> Gen (Action WorldState ())
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Action WorldState () -> Gen (Action WorldState ()))
-> Action WorldState () -> Gen (Action WorldState ())
forall a b. (a -> b) -> a -> b
$ Seed{[(Secret (SigningKey HydraKey), CardanoSigningKey)]
$sel:seedKeys:Seed :: [(Secret (SigningKey HydraKey), CardanoSigningKey)]
seedKeys :: [(Secret (SigningKey HydraKey), CardanoSigningKey)]
seedKeys, ContestationPeriod
$sel:contestationPeriod:Seed :: ContestationPeriod
contestationPeriod :: ContestationPeriod
contestationPeriod, [(CardanoSigningKey, Value)]
UTxOType Payment
additionalUTxO :: UTxOType Payment
additionalUTxO :: [(CardanoSigningKey, Value)]
additionalUTxO, Bool
$sel:concurrentSettlements:Seed :: Bool
concurrentSettlements :: Bool
concurrentSettlements}

genContestationPeriod :: Gen ContestationPeriod
genContestationPeriod :: Gen ContestationPeriod
genContestationPeriod =
  (ContestationPeriod, ContestationPeriod) -> Gen ContestationPeriod
forall a. Enum a => (a, a) -> Gen a
chooseEnum (ContestationPeriod
1, ContestationPeriod
200)

genInit :: [(Secret (SigningKey HydraKey), b)] -> Gen (Action WorldState HeadId)
genInit :: forall b.
[(Secret (SigningKey HydraKey), b)]
-> Gen (Action WorldState HeadId)
genInit [(Secret (SigningKey HydraKey), b)]
hydraParties = do
  Secret (SigningKey HydraKey)
key <- (Secret (SigningKey HydraKey), b) -> Secret (SigningKey HydraKey)
forall a b. (a, b) -> a
fst ((Secret (SigningKey HydraKey), b) -> Secret (SigningKey HydraKey))
-> Gen (Secret (SigningKey HydraKey), b)
-> Gen (Secret (SigningKey HydraKey))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Secret (SigningKey HydraKey), b)]
-> Gen (Secret (SigningKey HydraKey), b)
forall a. HasCallStack => [a] -> Gen a
elements [(Secret (SigningKey HydraKey), b)]
hydraParties
  let party :: Party
party = Secret (SigningKey HydraKey) -> Party
deriveParty Secret (SigningKey HydraKey)
key
  Action WorldState HeadId -> Gen (Action WorldState HeadId)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Action WorldState HeadId -> Gen (Action WorldState HeadId))
-> Action WorldState HeadId -> Gen (Action WorldState HeadId)
forall a b. (a -> b) -> a -> b
$ Party -> Action WorldState HeadId
Init Party
party

genPayment :: WorldState -> Gen (Party, Payment)
genPayment :: WorldState -> Gen (Party, Payment)
genPayment WorldState{[(Secret (SigningKey HydraKey), CardanoSigningKey)]
$sel:hydraParties:WorldState :: WorldState -> [(Secret (SigningKey HydraKey), CardanoSigningKey)]
hydraParties :: [(Secret (SigningKey HydraKey), CardanoSigningKey)]
hydraParties, GlobalState
$sel:hydraState:WorldState :: WorldState -> GlobalState
hydraState :: GlobalState
hydraState} =
  case GlobalState
hydraState of
    Open{$sel:offChainState:Start :: GlobalState -> OffChainState
offChainState = OffChainState{UTxOType Payment
$sel:confirmedUTxO:OffChainState :: OffChainState -> UTxOType Payment
confirmedUTxO :: UTxOType Payment
confirmedUTxO}} -> do
      let spendable :: [(CardanoSigningKey, Value, Party)]
spendable =
            ((CardanoSigningKey, Value)
 -> Maybe (CardanoSigningKey, Value, Party))
-> [(CardanoSigningKey, Value)]
-> [(CardanoSigningKey, Value, Party)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
              ( \(CardanoSigningKey
from, Value
value) ->
                  (CardanoSigningKey
from,Value
value,) (Party -> (CardanoSigningKey, Value, Party))
-> ((Secret (SigningKey HydraKey), CardanoSigningKey) -> Party)
-> (Secret (SigningKey HydraKey), CardanoSigningKey)
-> (CardanoSigningKey, Value, Party)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Secret (SigningKey HydraKey) -> Party
deriveParty (Secret (SigningKey HydraKey) -> Party)
-> ((Secret (SigningKey HydraKey), CardanoSigningKey)
    -> Secret (SigningKey HydraKey))
-> (Secret (SigningKey HydraKey), CardanoSigningKey)
-> Party
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Secret (SigningKey HydraKey), CardanoSigningKey)
-> Secret (SigningKey HydraKey)
forall a b. (a, b) -> a
fst ((Secret (SigningKey HydraKey), CardanoSigningKey)
 -> (CardanoSigningKey, Value, Party))
-> Maybe (Secret (SigningKey HydraKey), CardanoSigningKey)
-> Maybe (CardanoSigningKey, Value, Party)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Secret (SigningKey HydraKey), CardanoSigningKey) -> Bool)
-> [(Secret (SigningKey HydraKey), CardanoSigningKey)]
-> Maybe (Secret (SigningKey HydraKey), CardanoSigningKey)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find ((CardanoSigningKey -> CardanoSigningKey -> Bool
forall a. Eq a => a -> a -> Bool
== CardanoSigningKey
from) (CardanoSigningKey -> Bool)
-> ((Secret (SigningKey HydraKey), CardanoSigningKey)
    -> CardanoSigningKey)
-> (Secret (SigningKey HydraKey), CardanoSigningKey)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Secret (SigningKey HydraKey), CardanoSigningKey)
-> CardanoSigningKey
forall a b. (a, b) -> b
snd) [(Secret (SigningKey HydraKey), CardanoSigningKey)]
hydraParties
              )
              ([(CardanoSigningKey, Value)]
 -> [(CardanoSigningKey, Value, Party)])
-> [(CardanoSigningKey, Value)]
-> [(CardanoSigningKey, Value, Party)]
forall a b. (a -> b) -> a -> b
$ ((CardanoSigningKey, Value) -> Bool)
-> [(CardanoSigningKey, Value)] -> [(CardanoSigningKey, Value)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ((CardanoSigningKey, Value) -> Bool)
-> (CardanoSigningKey, Value)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(AssetId, Quantity)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([(AssetId, Quantity)] -> Bool)
-> ((CardanoSigningKey, Value) -> [(AssetId, Quantity)])
-> (CardanoSigningKey, Value)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> [(AssetId, Quantity)]
Value -> [Item Value]
forall l. IsList l => l -> [Item l]
toList (Value -> [(AssetId, Quantity)])
-> ((CardanoSigningKey, Value) -> Value)
-> (CardanoSigningKey, Value)
-> [(AssetId, Quantity)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CardanoSigningKey, Value) -> Value
forall a b. (a, b) -> b
snd) [(CardanoSigningKey, Value)]
UTxOType Payment
confirmedUTxO
      case [(CardanoSigningKey, Value, Party)]
spendable of
        [] -> Gen (Party, Payment)
forall a. a
discard
        [(CardanoSigningKey, Value, Party)]
_ -> do
          (CardanoSigningKey
from, Value
value, Party
party) <- [(CardanoSigningKey, Value, Party)]
-> Gen (CardanoSigningKey, Value, Party)
forall a. HasCallStack => [a] -> Gen a
elements [(CardanoSigningKey, Value, Party)]
spendable
          -- NOTE: It's perfectly possible this yields a payment to self and it
          -- assumes hydraParties is not empty else `elements` will crash
          (Secret (SigningKey HydraKey)
_, CardanoSigningKey
to) <- [(Secret (SigningKey HydraKey), CardanoSigningKey)]
-> Gen (Secret (SigningKey HydraKey), CardanoSigningKey)
forall a. HasCallStack => [a] -> Gen a
elements [(Secret (SigningKey HydraKey), CardanoSigningKey)]
hydraParties
          (Party, Payment) -> Gen (Party, Payment)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Party
party, Payment{CardanoSigningKey
$sel:from:Payment :: CardanoSigningKey
from :: CardanoSigningKey
from, CardanoSigningKey
$sel:to:Payment :: CardanoSigningKey
to :: CardanoSigningKey
to, Value
$sel:value:Payment :: Value
value :: Value
value})
    GlobalState
_ -> Text -> Gen (Party, Payment)
forall a t. (HasCallStack, IsText t) => t -> a
error (Text -> Gen (Party, Payment)) -> Text -> Gen (Party, Payment)
forall a b. (a -> b) -> a -> b
$ Text
"genPayment impossible in state: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> GlobalState -> Text
forall b a. (Show a, IsString b) => a -> b
show GlobalState
hydraState

unsafeConstructorName :: Show a => a -> String
unsafeConstructorName :: forall a. Show a => a -> String
unsafeConstructorName = [String] -> String
forall a. HasCallStack => [a] -> a
Prelude.head ([String] -> String) -> (a -> [String]) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
Prelude.words (String -> [String]) -> (a -> String) -> a -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall b a. (Show a, IsString b) => a -> b
show

-- | Generate a list of pairs of Hydra/Cardano signing keys.
--  All the keys in this list are guaranteed to be unique.
partyKeys :: Gen [(Secret (SigningKey HydraKey), CardanoSigningKey)]
partyKeys :: Gen [(Secret (SigningKey HydraKey), CardanoSigningKey)]
partyKeys =
  (Int -> Gen [(Secret (SigningKey HydraKey), CardanoSigningKey)])
-> Gen [(Secret (SigningKey HydraKey), CardanoSigningKey)]
forall a. (Int -> Gen a) -> Gen a
sized ((Int -> Gen [(Secret (SigningKey HydraKey), CardanoSigningKey)])
 -> Gen [(Secret (SigningKey HydraKey), CardanoSigningKey)])
-> (Int -> Gen [(Secret (SigningKey HydraKey), CardanoSigningKey)])
-> Gen [(Secret (SigningKey HydraKey), CardanoSigningKey)]
forall a b. (a -> b) -> a -> b
$ \Int
len -> do
    Int
numParties <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
1, Int
len)
    [Secret (SigningKey HydraKey)]
hks <- [Secret (SigningKey HydraKey)] -> [Secret (SigningKey HydraKey)]
forall a. Eq a => [a] -> [a]
nub ([Secret (SigningKey HydraKey)] -> [Secret (SigningKey HydraKey)])
-> Gen [Secret (SigningKey HydraKey)]
-> Gen [Secret (SigningKey HydraKey)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int
-> Gen (Secret (SigningKey HydraKey))
-> Gen [Secret (SigningKey HydraKey)]
forall a. Int -> Gen a -> Gen [a]
vectorOf Int
numParties Gen (Secret (SigningKey HydraKey))
forall a. Arbitrary a => Gen a
arbitrary
    [CardanoSigningKey]
cks <- [CardanoSigningKey] -> [CardanoSigningKey]
forall a. Eq a => [a] -> [a]
nub ([CardanoSigningKey] -> [CardanoSigningKey])
-> ([SigningKey PaymentKey] -> [CardanoSigningKey])
-> [SigningKey PaymentKey]
-> [CardanoSigningKey]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SigningKey PaymentKey -> CardanoSigningKey)
-> [SigningKey PaymentKey] -> [CardanoSigningKey]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Secret (SigningKey PaymentKey) -> CardanoSigningKey
CardanoSigningKey (Secret (SigningKey PaymentKey) -> CardanoSigningKey)
-> (SigningKey PaymentKey -> Secret (SigningKey PaymentKey))
-> SigningKey PaymentKey
-> CardanoSigningKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SigningKey PaymentKey -> Secret (SigningKey PaymentKey)
forall a. a -> Secret a
mkSecret) ([SigningKey PaymentKey] -> [CardanoSigningKey])
-> Gen [SigningKey PaymentKey] -> Gen [CardanoSigningKey]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Gen (SigningKey PaymentKey) -> Gen [SigningKey PaymentKey]
forall a. Int -> Gen a -> Gen [a]
vectorOf Int
numParties Gen (SigningKey PaymentKey)
genSigningKey
    [(Secret (SigningKey HydraKey), CardanoSigningKey)]
-> Gen [(Secret (SigningKey HydraKey), CardanoSigningKey)]
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(Secret (SigningKey HydraKey), CardanoSigningKey)]
 -> Gen [(Secret (SigningKey HydraKey), CardanoSigningKey)])
-> [(Secret (SigningKey HydraKey), CardanoSigningKey)]
-> Gen [(Secret (SigningKey HydraKey), CardanoSigningKey)]
forall a b. (a -> b) -> a -> b
$ [Secret (SigningKey HydraKey)]
-> [CardanoSigningKey]
-> [(Secret (SigningKey HydraKey), CardanoSigningKey)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Secret (SigningKey HydraKey)]
hks [CardanoSigningKey]
cks

-- | Exactly @n@ distinct parties, for scripted scenarios (see 'partyKeys').
genPartyKeysExactly :: Int -> Gen [(Secret (SigningKey HydraKey), CardanoSigningKey)]
genPartyKeysExactly :: Int -> Gen [(Secret (SigningKey HydraKey), CardanoSigningKey)]
genPartyKeysExactly Int
n =
  Gen [(Secret (SigningKey HydraKey), CardanoSigningKey)]
gen Gen [(Secret (SigningKey HydraKey), CardanoSigningKey)]
-> ([(Secret (SigningKey HydraKey), CardanoSigningKey)] -> Bool)
-> Gen [(Secret (SigningKey HydraKey), CardanoSigningKey)]
forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` ((Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n) (Int -> Bool)
-> ([(Secret (SigningKey HydraKey), CardanoSigningKey)] -> Int)
-> [(Secret (SigningKey HydraKey), CardanoSigningKey)]
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Secret (SigningKey HydraKey), CardanoSigningKey)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length)
 where
  gen :: Gen [(Secret (SigningKey HydraKey), CardanoSigningKey)]
gen = do
    [Secret (SigningKey HydraKey)]
hks <- [Secret (SigningKey HydraKey)] -> [Secret (SigningKey HydraKey)]
forall a. Eq a => [a] -> [a]
nub ([Secret (SigningKey HydraKey)] -> [Secret (SigningKey HydraKey)])
-> Gen [Secret (SigningKey HydraKey)]
-> Gen [Secret (SigningKey HydraKey)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int
-> Gen (Secret (SigningKey HydraKey))
-> Gen [Secret (SigningKey HydraKey)]
forall a. Int -> Gen a -> Gen [a]
vectorOf Int
n Gen (Secret (SigningKey HydraKey))
forall a. Arbitrary a => Gen a
arbitrary
    [CardanoSigningKey]
cks <- [CardanoSigningKey] -> [CardanoSigningKey]
forall a. Eq a => [a] -> [a]
nub ([CardanoSigningKey] -> [CardanoSigningKey])
-> ([SigningKey PaymentKey] -> [CardanoSigningKey])
-> [SigningKey PaymentKey]
-> [CardanoSigningKey]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SigningKey PaymentKey -> CardanoSigningKey)
-> [SigningKey PaymentKey] -> [CardanoSigningKey]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Secret (SigningKey PaymentKey) -> CardanoSigningKey
CardanoSigningKey (Secret (SigningKey PaymentKey) -> CardanoSigningKey)
-> (SigningKey PaymentKey -> Secret (SigningKey PaymentKey))
-> SigningKey PaymentKey
-> CardanoSigningKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SigningKey PaymentKey -> Secret (SigningKey PaymentKey)
forall a. a -> Secret a
mkSecret) ([SigningKey PaymentKey] -> [CardanoSigningKey])
-> Gen [SigningKey PaymentKey] -> Gen [CardanoSigningKey]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Gen (SigningKey PaymentKey) -> Gen [SigningKey PaymentKey]
forall a. Int -> Gen a -> Gen [a]
vectorOf Int
n Gen (SigningKey PaymentKey)
genSigningKey
    [(Secret (SigningKey HydraKey), CardanoSigningKey)]
-> Gen [(Secret (SigningKey HydraKey), CardanoSigningKey)]
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(Secret (SigningKey HydraKey), CardanoSigningKey)]
 -> Gen [(Secret (SigningKey HydraKey), CardanoSigningKey)])
-> [(Secret (SigningKey HydraKey), CardanoSigningKey)]
-> Gen [(Secret (SigningKey HydraKey), CardanoSigningKey)]
forall a b. (a -> b) -> a -> b
$ [Secret (SigningKey HydraKey)]
-> [CardanoSigningKey]
-> [(Secret (SigningKey HydraKey), CardanoSigningKey)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Secret (SigningKey HydraKey)]
hks [CardanoSigningKey]
cks

-- * Running the model

-- | Concrete state needed to run actions against the implementation.
-- This state is used and might be updated when actually `perform`ing actions generated from the `StateModel`.
data Nodes m = Nodes
  { forall (m :: * -> *). Nodes m -> Map Party (TestHydraClient Tx m)
nodes :: Map.Map Party (TestHydraClient Tx m)
  -- ^ Map from party identifiers to a /handle/ for interacting with a node.
  , forall (m :: * -> *). Nodes m -> Tracer m (HydraLog Tx)
logger :: Tracer m (HydraLog Tx)
  -- ^ Logger used by each node.
  -- The reason we put this here is because the concrete value needs to be
  -- instantiated upon the test run initialisation, outiside of the model.
  , forall (m :: * -> *). Nodes m -> [Async m ()]
threads :: [Async m ()]
  -- ^ List of threads spawned when executing `RunMonad`
  , forall (m :: * -> *). Nodes m -> SimulatedChainNetwork Tx m
chain :: SimulatedChainNetwork Tx m
  , forall (m :: * -> *).
Nodes m
-> Map Party (EventStore (StateEvent Tx) m, m [StateEvent Tx])
eventStores :: Map.Map Party (EventStore (StateEvent Tx) m, m [StateEvent Tx])
  -- ^ Each node's event store (with a direct reader), so 'RestartNode' can
  -- recover a node from its own persisted events like fail-recovery would.
  , forall (m :: * -> *). Nodes m -> Map Party (Async m ())
nodeThreads :: Map.Map Party (Async m ())
  -- ^ Each node's main thread, so 'RestartNode' can crash one selectively.
  }

-- NOTE: This newtype is needed to allow its use in typeclass instances
newtype RunState m = RunState {forall (m :: * -> *). RunState m -> TVar m (Nodes m)
nodesState :: TVar m (Nodes m)}

-- | Our execution `MonadTrans`former.
--
-- This type is needed in order to keep the execution monad `m` abstract  and thus
-- simplify the definition of the `RunModel` instance which requires a proper definition
-- of `Realized`  type family. See [this issue](https://github.com/input-output-hk/quickcheck-dynamic/issues/29)
-- for a discussion on why this monad is needed.
--
-- We could perhaps getaway with it and just have a type based on `IOSim` monad
-- but this is cumbersome to write.
newtype RunMonad m a = RunMonad {forall (m :: * -> *) a. RunMonad m a -> ReaderT (RunState m) m a
runMonad :: ReaderT (RunState m) m a}
  deriving newtype ((forall a b. (a -> b) -> RunMonad m a -> RunMonad m b)
-> (forall a b. a -> RunMonad m b -> RunMonad m a)
-> Functor (RunMonad m)
forall a b. a -> RunMonad m b -> RunMonad m a
forall a b. (a -> b) -> RunMonad m a -> RunMonad m b
forall (m :: * -> *) a b.
Functor m =>
a -> RunMonad m b -> RunMonad m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> RunMonad m a -> RunMonad m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> RunMonad m a -> RunMonad m b
fmap :: forall a b. (a -> b) -> RunMonad m a -> RunMonad m b
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> RunMonad m b -> RunMonad m a
<$ :: forall a b. a -> RunMonad m b -> RunMonad m a
Functor, Functor (RunMonad m)
Functor (RunMonad m) =>
(forall a. a -> RunMonad m a)
-> (forall a b.
    RunMonad m (a -> b) -> RunMonad m a -> RunMonad m b)
-> (forall a b c.
    (a -> b -> c) -> RunMonad m a -> RunMonad m b -> RunMonad m c)
-> (forall a b. RunMonad m a -> RunMonad m b -> RunMonad m b)
-> (forall a b. RunMonad m a -> RunMonad m b -> RunMonad m a)
-> Applicative (RunMonad m)
forall a. a -> RunMonad m a
forall a b. RunMonad m a -> RunMonad m b -> RunMonad m a
forall a b. RunMonad m a -> RunMonad m b -> RunMonad m b
forall a b. RunMonad m (a -> b) -> RunMonad m a -> RunMonad m b
forall a b c.
(a -> b -> c) -> RunMonad m a -> RunMonad m b -> RunMonad m c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
forall (m :: * -> *). Applicative m => Functor (RunMonad m)
forall (m :: * -> *) a. Applicative m => a -> RunMonad m a
forall (m :: * -> *) a b.
Applicative m =>
RunMonad m a -> RunMonad m b -> RunMonad m a
forall (m :: * -> *) a b.
Applicative m =>
RunMonad m a -> RunMonad m b -> RunMonad m b
forall (m :: * -> *) a b.
Applicative m =>
RunMonad m (a -> b) -> RunMonad m a -> RunMonad m b
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> RunMonad m a -> RunMonad m b -> RunMonad m c
$cpure :: forall (m :: * -> *) a. Applicative m => a -> RunMonad m a
pure :: forall a. a -> RunMonad m a
$c<*> :: forall (m :: * -> *) a b.
Applicative m =>
RunMonad m (a -> b) -> RunMonad m a -> RunMonad m b
<*> :: forall a b. RunMonad m (a -> b) -> RunMonad m a -> RunMonad m b
$cliftA2 :: forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> RunMonad m a -> RunMonad m b -> RunMonad m c
liftA2 :: forall a b c.
(a -> b -> c) -> RunMonad m a -> RunMonad m b -> RunMonad m c
$c*> :: forall (m :: * -> *) a b.
Applicative m =>
RunMonad m a -> RunMonad m b -> RunMonad m b
*> :: forall a b. RunMonad m a -> RunMonad m b -> RunMonad m b
$c<* :: forall (m :: * -> *) a b.
Applicative m =>
RunMonad m a -> RunMonad m b -> RunMonad m a
<* :: forall a b. RunMonad m a -> RunMonad m b -> RunMonad m a
Applicative, Applicative (RunMonad m)
Applicative (RunMonad m) =>
(forall a b. RunMonad m a -> (a -> RunMonad m b) -> RunMonad m b)
-> (forall a b. RunMonad m a -> RunMonad m b -> RunMonad m b)
-> (forall a. a -> RunMonad m a)
-> Monad (RunMonad m)
forall a. a -> RunMonad m a
forall a b. RunMonad m a -> RunMonad m b -> RunMonad m b
forall a b. RunMonad m a -> (a -> RunMonad m b) -> RunMonad m b
forall (m :: * -> *). Monad m => Applicative (RunMonad m)
forall (m :: * -> *) a. Monad m => a -> RunMonad m a
forall (m :: * -> *) a b.
Monad m =>
RunMonad m a -> RunMonad m b -> RunMonad m b
forall (m :: * -> *) a b.
Monad m =>
RunMonad m a -> (a -> RunMonad m b) -> RunMonad m b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
RunMonad m a -> (a -> RunMonad m b) -> RunMonad m b
>>= :: forall a b. RunMonad m a -> (a -> RunMonad m b) -> RunMonad m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
RunMonad m a -> RunMonad m b -> RunMonad m b
>> :: forall a b. RunMonad m a -> RunMonad m b -> RunMonad m b
$creturn :: forall (m :: * -> *) a. Monad m => a -> RunMonad m a
return :: forall a. a -> RunMonad m a
Monad, MonadReader (RunState m), Monad (RunMonad m)
Monad (RunMonad m) =>
(forall e a. Exception e => e -> RunMonad m a)
-> (forall a b c.
    RunMonad m a
    -> (a -> RunMonad m b) -> (a -> RunMonad m c) -> RunMonad m c)
-> (forall a b c.
    RunMonad m a -> RunMonad m b -> RunMonad m c -> RunMonad m c)
-> (forall a b. RunMonad m a -> RunMonad m b -> RunMonad m a)
-> MonadThrow (RunMonad m)
forall e a. Exception e => e -> RunMonad m a
forall a b. RunMonad m a -> RunMonad m b -> RunMonad m a
forall a b c.
RunMonad m a -> RunMonad m b -> RunMonad m c -> RunMonad m c
forall a b c.
RunMonad m a
-> (a -> RunMonad m b) -> (a -> RunMonad m c) -> RunMonad m c
forall (m :: * -> *).
Monad m =>
(forall e a. Exception e => e -> m a)
-> (forall a b c. m a -> (a -> m b) -> (a -> m c) -> m c)
-> (forall a b c. m a -> m b -> m c -> m c)
-> (forall a b. m a -> m b -> m a)
-> MonadThrow m
forall (m :: * -> *). MonadThrow m => Monad (RunMonad m)
forall (m :: * -> *) e a.
(MonadThrow m, Exception e) =>
e -> RunMonad m a
forall (m :: * -> *) a b.
MonadThrow m =>
RunMonad m a -> RunMonad m b -> RunMonad m a
forall (m :: * -> *) a b c.
MonadThrow m =>
RunMonad m a -> RunMonad m b -> RunMonad m c -> RunMonad m c
forall (m :: * -> *) a b c.
MonadThrow m =>
RunMonad m a
-> (a -> RunMonad m b) -> (a -> RunMonad m c) -> RunMonad m c
$cthrowIO :: forall (m :: * -> *) e a.
(MonadThrow m, Exception e) =>
e -> RunMonad m a
throwIO :: forall e a. Exception e => e -> RunMonad m a
$cbracket :: forall (m :: * -> *) a b c.
MonadThrow m =>
RunMonad m a
-> (a -> RunMonad m b) -> (a -> RunMonad m c) -> RunMonad m c
bracket :: forall a b c.
RunMonad m a
-> (a -> RunMonad m b) -> (a -> RunMonad m c) -> RunMonad m c
$cbracket_ :: forall (m :: * -> *) a b c.
MonadThrow m =>
RunMonad m a -> RunMonad m b -> RunMonad m c -> RunMonad m c
bracket_ :: forall a b c.
RunMonad m a -> RunMonad m b -> RunMonad m c -> RunMonad m c
$cfinally :: forall (m :: * -> *) a b.
MonadThrow m =>
RunMonad m a -> RunMonad m b -> RunMonad m a
finally :: forall a b. RunMonad m a -> RunMonad m b -> RunMonad m a
MonadThrow, Monad (RunMonad m)
RunMonad m UTCTime
Monad (RunMonad m) => RunMonad m UTCTime -> MonadTime (RunMonad m)
forall (m :: * -> *). Monad m => m UTCTime -> MonadTime m
forall (m :: * -> *). MonadTime m => Monad (RunMonad m)
forall (m :: * -> *). MonadTime m => RunMonad m UTCTime
$cgetCurrentTime :: forall (m :: * -> *). MonadTime m => RunMonad m UTCTime
getCurrentTime :: RunMonad m UTCTime
MonadTime)

instance MonadTrans RunMonad where
  lift :: forall (m :: * -> *) a. Monad m => m a -> RunMonad m a
lift = ReaderT (RunState m) m a -> RunMonad m a
forall (m :: * -> *) a. ReaderT (RunState m) m a -> RunMonad m a
RunMonad (ReaderT (RunState m) m a -> RunMonad m a)
-> (m a -> ReaderT (RunState m) m a) -> m a -> RunMonad m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> ReaderT (RunState m) m a
forall (m :: * -> *) a. Monad m => m a -> ReaderT (RunState m) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

instance MonadSTM m => MonadState (Nodes m) (RunMonad m) where
  get :: RunMonad m (Nodes m)
get = RunMonad m (RunState m)
forall r (m :: * -> *). MonadReader r m => m r
ask RunMonad m (RunState m)
-> (RunState m -> RunMonad m (Nodes m)) -> RunMonad m (Nodes m)
forall a b. RunMonad m a -> (a -> RunMonad m b) -> RunMonad m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= m (Nodes m) -> RunMonad m (Nodes m)
forall (m :: * -> *) a. Monad m => m a -> RunMonad m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Nodes m) -> RunMonad m (Nodes m))
-> (RunState m -> m (Nodes m))
-> RunState m
-> RunMonad m (Nodes m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar m (Nodes m) -> m (Nodes m)
forall a. TVar m a -> m a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> m a
readTVarIO (TVar m (Nodes m) -> m (Nodes m))
-> (RunState m -> TVar m (Nodes m)) -> RunState m -> m (Nodes m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RunState m -> TVar m (Nodes m)
forall (m :: * -> *). RunState m -> TVar m (Nodes m)
nodesState

  put :: Nodes m -> RunMonad m ()
put Nodes m
n = RunMonad m (RunState m)
forall r (m :: * -> *). MonadReader r m => m r
ask RunMonad m (RunState m)
-> (RunState m -> RunMonad m ()) -> RunMonad m ()
forall a b. RunMonad m a -> (a -> RunMonad m b) -> RunMonad m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= m () -> RunMonad m ()
forall (m :: * -> *) a. Monad m => m a -> RunMonad m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> RunMonad m ())
-> (RunState m -> m ()) -> RunState m -> RunMonad m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ())
-> (RunState m -> STM m ()) -> RunState m -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TVar m (Nodes m) -> (Nodes m -> Nodes m) -> STM m ())
-> (Nodes m -> Nodes m) -> TVar m (Nodes m) -> STM m ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip TVar m (Nodes m) -> (Nodes m -> Nodes m) -> STM m ()
forall a. TVar m a -> (a -> a) -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
TVar m a -> (a -> a) -> STM m ()
modifyTVar (Nodes m -> Nodes m -> Nodes m
forall a b. a -> b -> a
const Nodes m
n) (TVar m (Nodes m) -> STM m ())
-> (RunState m -> TVar m (Nodes m)) -> RunState m -> STM m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RunState m -> TVar m (Nodes m)
forall (m :: * -> *). RunState m -> TVar m (Nodes m)
nodesState

data RunException
  = TransactionNotObserved Payment UTxO
  | UnexpectedParty Party
  | UnknownAddress AddressInEra [(AddressInEra, CardanoSigningKey)]
  | CannotFindSpendableUTxO Payment UTxO
  deriving stock (RunException -> RunException -> Bool
(RunException -> RunException -> Bool)
-> (RunException -> RunException -> Bool) -> Eq RunException
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RunException -> RunException -> Bool
== :: RunException -> RunException -> Bool
$c/= :: RunException -> RunException -> Bool
/= :: RunException -> RunException -> Bool
Eq, Int -> RunException -> ShowS
[RunException] -> ShowS
RunException -> String
(Int -> RunException -> ShowS)
-> (RunException -> String)
-> ([RunException] -> ShowS)
-> Show RunException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RunException -> ShowS
showsPrec :: Int -> RunException -> ShowS
$cshow :: RunException -> String
show :: RunException -> String
$cshowList :: [RunException] -> ShowS
showList :: [RunException] -> ShowS
Show)

instance Exception RunException

-- | This type family is needed to link the _actual_ output from running actions
-- with the ones that are modelled.
--
-- In our case we can keep things simple and use the same types on both side of
-- the fence.
type instance Realized (RunMonad m) a = a

-- NOTE: Sort `[TxOut]` by the address and values. We want to make
-- sure that the fanout outputs match what we had in the open Head
-- exactly.
sortTxOuts :: [TxOut ctx] -> [TxOut ctx]
sortTxOuts :: forall ctx. [TxOut ctx] -> [TxOut ctx]
sortTxOuts = (TxOut ctx -> (AddressInEra, Lovelace))
-> [TxOut ctx] -> [TxOut ctx]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (\TxOut ctx
o -> (TxOut ctx -> AddressInEra
forall ctx. TxOut ctx -> AddressInEra
txOutAddress TxOut ctx
o, Value -> Lovelace
selectLovelace (TxOut ctx -> Value
forall ctx. TxOut ctx -> Value
txOutValue TxOut ctx
o)))

instance
  ( MonadAsync m
  , MonadFork m
  , MonadMask m
  , MonadTimer m
  , MonadThrow (STM m)
  , MonadLabelledSTM m
  , MonadDelay m
  , MonadTime m
  ) =>
  RunModel WorldState (RunMonad m)
  where
  postcondition :: forall a.
(WorldState, WorldState)
-> Action WorldState a
-> LookUp (RunMonad m)
-> Realized (RunMonad m) a
-> PostconditionM (RunMonad m) Bool
postcondition (WorldState
_, WorldState
st) Action WorldState a
action LookUp (RunMonad m)
_lookup Realized (RunMonad m) a
result = do
    String -> PostconditionM (RunMonad m) ()
forall (m :: * -> *). Monad m => String -> PostconditionM m ()
counterexamplePost String
"Postcondition failed"
    String -> PostconditionM (RunMonad m) ()
forall (m :: * -> *). Monad m => String -> PostconditionM m ()
counterexamplePost (String
"Action:   " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Action WorldState a -> String
forall b a. (Show a, IsString b) => a -> b
show Action WorldState a
action)
    String -> PostconditionM (RunMonad m) ()
forall (m :: * -> *). Monad m => String -> PostconditionM m ()
counterexamplePost (String
"State:    " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> WorldState -> String
forall b a. (Show a, IsString b) => a -> b
show WorldState
st)

    case Action WorldState a
action of
      Fanout{} -> UTxO Era -> PostconditionM (RunMonad m) Bool
fanoutDistributedEverything UTxO Era
Realized (RunMonad m) a
result
      ObserveFanoutFinalized{} -> UTxO Era -> PostconditionM (RunMonad m) Bool
fanoutDistributedEverything UTxO Era
Realized (RunMonad m) a
result
      Action WorldState a
_ -> Bool -> PostconditionM (RunMonad m) Bool
forall a. a -> PostconditionM (RunMonad m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
   where
    -- The fanout must distribute everything confirmed in the head, and nothing
    -- else but outputs of settlements that were still pending at close (see
    -- 'unsettledAtClose').
    fanoutDistributedEverything :: UTxO -> PostconditionM (RunMonad m) Bool
    fanoutDistributedEverything :: UTxO Era -> PostconditionM (RunMonad m) Bool
fanoutDistributedEverything UTxO Era
distributed =
      case WorldState -> GlobalState
hydraState WorldState
st of
        Final{UTxOType Payment
$sel:finalUTxO:Start :: GlobalState -> UTxOType Payment
finalUTxO :: UTxOType Payment
finalUTxO, UTxOType Payment
$sel:unsettledAtFinal:Start :: GlobalState -> UTxOType Payment
unsettledAtFinal :: UTxOType Payment
unsettledAtFinal} -> do
          let expected :: [TxOut CtxUTxO]
expected = [TxOut CtxUTxO] -> [TxOut CtxUTxO]
forall ctx. [TxOut ctx] -> [TxOut ctx]
sortTxOuts ([(CardanoSigningKey, Value)] -> [TxOut CtxUTxO]
toTxOuts [(CardanoSigningKey, Value)]
UTxOType Payment
finalUTxO)
              actual :: [TxOut CtxUTxO]
actual = [TxOut CtxUTxO] -> [TxOut CtxUTxO]
forall ctx. [TxOut ctx] -> [TxOut ctx]
sortTxOuts ((TxIn, TxOut CtxUTxO) -> TxOut CtxUTxO
forall a b. (a, b) -> b
snd ((TxIn, TxOut CtxUTxO) -> TxOut CtxUTxO)
-> [(TxIn, TxOut CtxUTxO)] -> [TxOut CtxUTxO]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UTxO Era -> [(TxIn, TxOut CtxUTxO)]
forall era. UTxO era -> [(TxIn, TxOut CtxUTxO era)]
UTxO.toList UTxO Era
distributed)
              missing :: [TxOut CtxUTxO]
missing = [TxOut CtxUTxO]
expected [TxOut CtxUTxO] -> [TxOut CtxUTxO] -> [TxOut CtxUTxO]
forall a. Eq a => [a] -> [a] -> [a]
\\ [TxOut CtxUTxO]
actual
              unexpected :: [TxOut CtxUTxO]
unexpected = ([TxOut CtxUTxO]
actual [TxOut CtxUTxO] -> [TxOut CtxUTxO] -> [TxOut CtxUTxO]
forall a. Eq a => [a] -> [a] -> [a]
\\ [TxOut CtxUTxO]
expected) [TxOut CtxUTxO] -> [TxOut CtxUTxO] -> [TxOut CtxUTxO]
forall a. Eq a => [a] -> [a] -> [a]
\\ [TxOut CtxUTxO] -> [TxOut CtxUTxO]
forall ctx. [TxOut ctx] -> [TxOut ctx]
sortTxOuts ([(CardanoSigningKey, Value)] -> [TxOut CtxUTxO]
toTxOuts [(CardanoSigningKey, Value)]
UTxOType Payment
unsettledAtFinal)
          String -> PostconditionM (RunMonad m) ()
forall (m :: * -> *). Monad m => String -> PostconditionM m ()
counterexamplePost (String
"Missing from fanout:    " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [TxOut CtxUTxO] -> String
forall b a. (Show a, IsString b) => a -> b
show [TxOut CtxUTxO]
missing)
          String -> PostconditionM (RunMonad m) ()
forall (m :: * -> *). Monad m => String -> PostconditionM m ()
counterexamplePost (String
"Unexpected in fanout:   " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [TxOut CtxUTxO] -> String
forall b a. (Show a, IsString b) => a -> b
show [TxOut CtxUTxO]
unexpected)
          Bool -> PostconditionM (RunMonad m) Bool
forall a. a -> PostconditionM (RunMonad m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([TxOut CtxUTxO] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TxOut CtxUTxO]
missing Bool -> Bool -> Bool
&& [TxOut CtxUTxO] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TxOut CtxUTxO]
unexpected)
        GlobalState
_ -> Bool -> PostconditionM (RunMonad m) Bool
forall a. a -> PostconditionM (RunMonad m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False

  monitoring :: forall a.
(WorldState, WorldState)
-> Action WorldState a
-> LookUp (RunMonad m)
-> Either (Error WorldState) (Realized (RunMonad m) a)
-> Property
-> Property
monitoring (WorldState
s, WorldState
s') Action WorldState a
_action LookUp (RunMonad m)
_lookup Either (Error WorldState) (Realized (RunMonad m) a)
_result =
    Property -> Property
decorateTransitions
   where
    decorateTransitions :: Property -> Property
decorateTransitions =
      case (WorldState -> GlobalState
hydraState WorldState
s, WorldState -> GlobalState
hydraState WorldState
s') of
        (GlobalState
st, GlobalState
st') -> String -> [String] -> Property -> Property
forall prop.
Testable prop =>
String -> [String] -> prop -> Property
tabulate String
"Transitions" [GlobalState -> String
forall a. Show a => a -> String
unsafeConstructorName GlobalState
st String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" -> " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> GlobalState -> String
forall a. Show a => a -> String
unsafeConstructorName GlobalState
st']

  perform :: forall a.
Typeable a =>
WorldState
-> Action WorldState a
-> LookUp (RunMonad m)
-> RunMonad
     m (PerformResult (Error WorldState) (Realized (RunMonad m) a))
perform WorldState
st Action WorldState a
action LookUp (RunMonad m)
lookup = do
    case Action WorldState a
action of
      Seed{[(Secret (SigningKey HydraKey), CardanoSigningKey)]
$sel:seedKeys:Seed :: Action WorldState ()
-> [(Secret (SigningKey HydraKey), CardanoSigningKey)]
seedKeys :: [(Secret (SigningKey HydraKey), CardanoSigningKey)]
seedKeys, ContestationPeriod
$sel:contestationPeriod:Seed :: Action WorldState () -> ContestationPeriod
contestationPeriod :: ContestationPeriod
contestationPeriod} ->
        [(Secret (SigningKey HydraKey), CardanoSigningKey)]
-> ContestationPeriod -> RunMonad m ()
forall (m :: * -> *).
(MonadAsync m, MonadTimer m, MonadThrow (STM m),
 MonadLabelledSTM m, MonadFork m, MonadMask m, MonadDelay m,
 MonadTime m) =>
[(Secret (SigningKey HydraKey), CardanoSigningKey)]
-> ContestationPeriod -> RunMonad m ()
seedWorld [(Secret (SigningKey HydraKey), CardanoSigningKey)]
seedKeys ContestationPeriod
contestationPeriod
      Init Party
party ->
        Party -> RunMonad m HeadId
forall (m :: * -> *).
(MonadThrow m, MonadAsync m, MonadTimer m, MonadDelay m,
 MonadLabelledSTM m) =>
Party -> RunMonad m HeadId
performInit Party
party
      Deposit Var HeadId
headIdVar UTxOType Payment
utxo -> do
        let headId :: Realized (RunMonad m) HeadId
headId = Var HeadId -> Realized (RunMonad m) HeadId
LookUp (RunMonad m)
lookup Var HeadId
headIdVar
        HeadId -> [(CardanoSigningKey, Value)] -> RunMonad m ()
forall (m :: * -> *).
(MonadThrow m, MonadTimer m, MonadAsync m, MonadTime m,
 MonadLabelledSTM m) =>
HeadId -> [(CardanoSigningKey, Value)] -> RunMonad m ()
performDeposit HeadId
Realized (RunMonad m) HeadId
headId [(CardanoSigningKey, Value)]
UTxOType Payment
utxo
      Decommit Party
party Payment
tx ->
        Party -> Payment -> RunMonad m ()
forall (m :: * -> *).
(MonadThrow m, MonadTimer m, MonadAsync m, MonadDelay m,
 MonadLabelledSTM m) =>
Party -> Payment -> RunMonad m ()
performDecommit Party
party Payment
tx
      SubmitDeposit Var HeadId
headIdVar UTxOType Payment
utxo ->
        HeadId -> [(CardanoSigningKey, Value)] -> RunMonad m TxId
forall (m :: * -> *).
(MonadThrow m, MonadTimer m, MonadDelay m, MonadTime m) =>
HeadId -> [(CardanoSigningKey, Value)] -> RunMonad m TxId
performSubmitDeposit (Var HeadId -> Realized (RunMonad m) HeadId
LookUp (RunMonad m)
lookup Var HeadId
headIdVar) [(CardanoSigningKey, Value)]
UTxOType Payment
utxo
      ObserveCommitApproved Var TxId
var ->
        UTxOType Payment -> RunMonad m ()
forall (m :: * -> *).
(MonadThrow m, MonadTimer m, MonadDelay m) =>
UTxOType Payment -> RunMonad m ()
performObserveCommitApproved (UTxOType Payment -> Maybe (UTxOType Payment) -> UTxOType Payment
forall a. a -> Maybe a -> a
fromMaybe [(CardanoSigningKey, Value)]
UTxOType Payment
forall a. Monoid a => a
mempty (Maybe (UTxOType Payment) -> UTxOType Payment)
-> Maybe (UTxOType Payment) -> UTxOType Payment
forall a b. (a -> b) -> a -> b
$ Var TxId
-> [(Var TxId, [(CardanoSigningKey, Value)])]
-> Maybe [(CardanoSigningKey, Value)]
forall a b. Eq a => a -> [(a, b)] -> Maybe b
List.lookup Var TxId
var (WorldState -> [(Var TxId, UTxOType Payment)]
pendingCommits WorldState
st))
      ObserveCommitFinalized Var TxId
var ->
        -- The n-th observation of this commit waits for its n-th report.
        Int -> TxId -> RunMonad m ()
forall (m :: * -> *).
(MonadThrow m, MonadTimer m, MonadDelay m) =>
Int -> TxId -> RunMonad m ()
performObserveCommitFinalized (Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Var TxId] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((Var TxId -> Bool) -> [Var TxId] -> [Var TxId]
forall a. (a -> Bool) -> [a] -> [a]
filter (Var TxId -> Var TxId -> Bool
forall a. Eq a => a -> a -> Bool
== Var TxId
var) (WorldState -> [Var TxId]
settledCommits WorldState
st))) (Var TxId -> Realized (RunMonad m) TxId
LookUp (RunMonad m)
lookup Var TxId
var)
      SubmitDecommit Party
party Payment
tx ->
        Party -> Payment -> RunMonad m (UTxO Era)
forall (m :: * -> *).
(MonadThrow m, MonadTimer m, MonadDelay m) =>
Party -> Payment -> RunMonad m (UTxO Era)
performSubmitDecommit Party
party Payment
tx
      ObserveDecommitFinalized Var (UTxO Era)
var ->
        Int -> UTxO Era -> RunMonad m ()
forall (m :: * -> *).
(MonadThrow m, MonadTimer m, MonadDelay m) =>
Int -> UTxO Era -> RunMonad m ()
performObserveDecommitFinalized (Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Var (UTxO Era)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((Var (UTxO Era) -> Bool) -> [Var (UTxO Era)] -> [Var (UTxO Era)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Var (UTxO Era) -> Var (UTxO Era) -> Bool
forall a. Eq a => a -> a -> Bool
== Var (UTxO Era)
var) (WorldState -> [Var (UTxO Era)]
settledDecommits WorldState
st))) (Var (UTxO Era) -> Realized (RunMonad m) (UTxO Era)
LookUp (RunMonad m)
lookup Var (UTxO Era)
var)
      Close Party
party ->
        Party -> RunMonad m ()
forall (m :: * -> *).
(MonadThrow m, MonadDelay m, MonadLabelledSTM m) =>
Party -> RunMonad m ()
performClose Party
party
      Fanout Party
party ->
        Party -> RunMonad m (UTxO Era)
forall (m :: * -> *).
(MonadThrow m, MonadAsync m, MonadDelay m) =>
Party -> RunMonad m (UTxO Era)
performFanout Party
party
      StartFanout Party
party ->
        Party -> RunMonad m ()
forall (m :: * -> *).
(MonadSTM m, MonadThrow m, MonadDelay m) =>
Party -> RunMonad m ()
performStartFanout Party
party
      PartialFanoutStep Party
party UTxOType Payment
selection ->
        Party -> UTxOType Payment -> RunMonad m ()
forall (m :: * -> *).
(MonadThrow m, MonadTimer m, MonadDelay m) =>
Party -> UTxOType Payment -> RunMonad m ()
performPartialFanoutStep Party
party UTxOType Payment
selection
      ObservePartialFanoutSteps Int
n ->
        Int -> RunMonad m ()
forall (m :: * -> *).
(MonadThrow m, MonadTimer m, MonadDelay m) =>
Int -> RunMonad m ()
performObservePartialFanoutSteps Int
n
      ObserveFanoutFinalized Party
party ->
        Party -> RunMonad m (UTxO Era)
forall (m :: * -> *).
(MonadSTM m, MonadThrow m, MonadDelay m) =>
Party -> RunMonad m (UTxO Era)
performObserveFanoutFinalized Party
party
      NewTx Party
party Payment
transaction ->
        Party -> Payment -> RunMonad m Payment
forall (m :: * -> *).
(MonadThrow m, MonadAsync m, MonadTimer m, MonadDelay m,
 MonadLabelledSTM m) =>
Party -> Payment -> RunMonad m Payment
performNewTx Party
party Payment
transaction
      Wait DiffTime
delay ->
        m (PerformResult (Error WorldState) (Realized (RunMonad m) a))
-> RunMonad
     m (PerformResult (Error WorldState) (Realized (RunMonad m) a))
forall (m :: * -> *) a. Monad m => m a -> RunMonad m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (PerformResult (Error WorldState) (Realized (RunMonad m) a))
 -> RunMonad
      m (PerformResult (Error WorldState) (Realized (RunMonad m) a)))
-> m (PerformResult (Error WorldState) (Realized (RunMonad m) a))
-> RunMonad
     m (PerformResult (Error WorldState) (Realized (RunMonad m) a))
forall a b. (a -> b) -> a -> b
$ DiffTime -> m ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
delay
      ObserveConfirmedTx Var Payment
var -> do
        let tx :: Realized (RunMonad m) Payment
tx = Var Payment -> Realized (RunMonad m) Payment
LookUp (RunMonad m)
lookup Var Payment
var
        [(Party, TestHydraClient Tx m)]
nodes <- Map Party (TestHydraClient Tx m) -> [(Party, TestHydraClient Tx m)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map Party (TestHydraClient Tx m)
 -> [(Party, TestHydraClient Tx m)])
-> RunMonad m (Map Party (TestHydraClient Tx m))
-> RunMonad m [(Party, TestHydraClient Tx m)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Nodes m -> Map Party (TestHydraClient Tx m))
-> RunMonad m (Map Party (TestHydraClient Tx m))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Nodes m -> Map Party (TestHydraClient Tx m)
forall (m :: * -> *). Nodes m -> Map Party (TestHydraClient Tx m)
nodes
        [(Party, TestHydraClient Tx m)]
-> ((Party, TestHydraClient Tx m) -> RunMonad m ())
-> RunMonad m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Party, TestHydraClient Tx m)]
nodes (((Party, TestHydraClient Tx m) -> RunMonad m ()) -> RunMonad m ())
-> ((Party, TestHydraClient Tx m) -> RunMonad m ())
-> RunMonad m ()
forall a b. (a -> b) -> a -> b
$ \(Party
_, TestHydraClient Tx m
node) -> do
          m (Either (UTxO Era) (TxIn, TxOut CtxUTxO))
-> RunMonad m (Either (UTxO Era) (TxIn, TxOut CtxUTxO))
forall (m :: * -> *) a. Monad m => m a -> RunMonad m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (UTxO Era
-> CardanoSigningKey
-> Value
-> TestHydraClient Tx m
-> m (Either (UTxO Era) (TxIn, TxOut CtxUTxO))
forall (m :: * -> *).
MonadDelay m =>
UTxO Era
-> CardanoSigningKey
-> Value
-> TestHydraClient Tx m
-> m (Either (UTxO Era) (TxIn, TxOut CtxUTxO))
waitForUTxOToSpend UTxO Era
forall a. Monoid a => a
mempty (Payment -> CardanoSigningKey
to Payment
Realized (RunMonad m) Payment
tx) (Payment -> Value
value Payment
Realized (RunMonad m) Payment
tx) TestHydraClient Tx m
node) RunMonad m (Either (UTxO Era) (TxIn, TxOut CtxUTxO))
-> (Either (UTxO Era) (TxIn, TxOut CtxUTxO) -> RunMonad m ())
-> RunMonad m ()
forall a b. RunMonad m a -> (a -> RunMonad m b) -> RunMonad m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Left UTxO Era
u -> RunException -> RunMonad m ()
forall e a. Exception e => e -> RunMonad m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (RunException -> RunMonad m ()) -> RunException -> RunMonad m ()
forall a b. (a -> b) -> a -> b
$ Payment -> UTxO Era -> RunException
TransactionNotObserved Payment
Realized (RunMonad m) Payment
tx UTxO Era
u
            Right (TxIn, TxOut CtxUTxO)
_ -> () -> RunMonad m ()
forall a. a -> RunMonad m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Action WorldState a
R:ActionWorldStatea a
ObserveHeadIsOpen -> do
        [(Party, TestHydraClient Tx m)]
nodes' <- Map Party (TestHydraClient Tx m) -> [(Party, TestHydraClient Tx m)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map Party (TestHydraClient Tx m)
 -> [(Party, TestHydraClient Tx m)])
-> RunMonad m (Map Party (TestHydraClient Tx m))
-> RunMonad m [(Party, TestHydraClient Tx m)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Nodes m -> Map Party (TestHydraClient Tx m))
-> RunMonad m (Map Party (TestHydraClient Tx m))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Nodes m -> Map Party (TestHydraClient Tx m)
forall (m :: * -> *). Nodes m -> Map Party (TestHydraClient Tx m)
nodes
        [(Party, TestHydraClient Tx m)]
-> ((Party, TestHydraClient Tx m) -> RunMonad m ())
-> RunMonad m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Party, TestHydraClient Tx m)]
nodes' (((Party, TestHydraClient Tx m) -> RunMonad m ()) -> RunMonad m ())
-> ((Party, TestHydraClient Tx m) -> RunMonad m ())
-> RunMonad m ()
forall a b. (a -> b) -> a -> b
$ \(Party
_, TestHydraClient Tx m
node) -> do
          [ServerOutput Tx]
outputs <- m [ServerOutput Tx] -> RunMonad m [ServerOutput Tx]
forall (m :: * -> *) a. Monad m => m a -> RunMonad m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m [ServerOutput Tx] -> RunMonad m [ServerOutput Tx])
-> m [ServerOutput Tx] -> RunMonad m [ServerOutput Tx]
forall a b. (a -> b) -> a -> b
$ TestHydraClient Tx m -> m [ServerOutput Tx]
forall tx (m :: * -> *).
TestHydraClient tx m -> m [ServerOutput tx]
serverOutputs TestHydraClient Tx m
node
          case (ServerOutput Tx -> Bool)
-> [ServerOutput Tx] -> Maybe (ServerOutput Tx)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ServerOutput Tx -> Bool
forall tx. ServerOutput tx -> Bool
headIsOpen [ServerOutput Tx]
outputs of
            Just ServerOutput Tx
_ -> () -> RunMonad m ()
forall a. a -> RunMonad m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            Maybe (ServerOutput Tx)
Nothing -> Text -> RunMonad m ()
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"The head is not open for node"
      CloseWithInitialSnapshot Party
party ->
        WorldState -> Party -> RunMonad m ()
forall (m :: * -> *).
(MonadThrow m, MonadTimer m, MonadDelay m, MonadAsync m,
 MonadLabelledSTM m) =>
WorldState -> Party -> RunMonad m ()
performCloseWithInitialSnapshot WorldState
st Party
party
      RollbackAndForward Natural
numberOfBlocks ->
        Natural -> RunMonad m ()
forall (m :: * -> *).
(MonadThrow m, MonadTimer m) =>
Natural -> RunMonad m ()
performRollbackAndForward Natural
numberOfBlocks
      RollbackAndFork{Natural
$sel:numberOfBlocks:Seed :: Action WorldState () -> Natural
numberOfBlocks :: Natural
numberOfBlocks, RequeueMode
$sel:requeueErased:Seed :: Action WorldState () -> RequeueMode
requeueErased :: RequeueMode
requeueErased} ->
        Natural -> RequeueMode -> RunMonad m ()
forall (m :: * -> *).
(MonadThrow m, MonadTimer m) =>
Natural -> RequeueMode -> RunMonad m ()
performRollbackAndFork Natural
numberOfBlocks RequeueMode
requeueErased
      RestartNode Party
party ->
        WorldState -> Party -> RunMonad m ()
forall (m :: * -> *).
(MonadAsync m, MonadLabelledSTM m, MonadFork m, MonadMask m,
 MonadDelay m, MonadTime m) =>
WorldState -> Party -> RunMonad m ()
performRestartNode WorldState
st Party
party
      Action WorldState a
R:ActionWorldStatea a
StopTheWorld ->
        RunMonad m ()
RunMonad
  m (PerformResult (Error WorldState) (Realized (RunMonad m) a))
forall (m :: * -> *). MonadAsync m => RunMonad m ()
stopTheWorld

-- ** Performing actions

-- | Deposit period used by all nodes and the 'performDeposit'.
testDepositPeriod :: DepositPeriod
testDepositPeriod :: DepositPeriod
testDepositPeriod = DepositPeriod
100

seedWorld ::
  ( MonadAsync m
  , MonadTimer m
  , MonadThrow (STM m)
  , MonadLabelledSTM m
  , MonadFork m
  , MonadMask m
  , MonadDelay m
  , MonadTime m
  ) =>
  [(Secret (SigningKey HydraKey), CardanoSigningKey)] ->
  ContestationPeriod ->
  RunMonad m ()
seedWorld :: forall (m :: * -> *).
(MonadAsync m, MonadTimer m, MonadThrow (STM m),
 MonadLabelledSTM m, MonadFork m, MonadMask m, MonadDelay m,
 MonadTime m) =>
[(Secret (SigningKey HydraKey), CardanoSigningKey)]
-> ContestationPeriod -> RunMonad m ()
seedWorld [(Secret (SigningKey HydraKey), CardanoSigningKey)]
seedKeys ContestationPeriod
seedCP = do
  Tracer m (HydraLog Tx)
tr <- (Nodes m -> Tracer m (HydraLog Tx))
-> RunMonad m (Tracer m (HydraLog Tx))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Nodes m -> Tracer m (HydraLog Tx)
forall (m :: * -> *). Nodes m -> Tracer m (HydraLog Tx)
logger

  mockChain :: SimulatedChainNetwork Tx m
mockChain@SimulatedChainNetwork{Async m ()
tickThread :: Async m ()
$sel:tickThread:SimulatedChainNetwork :: forall tx (m :: * -> *). SimulatedChainNetwork tx m -> Async m ()
tickThread} <-
    m (SimulatedChainNetwork Tx m)
-> RunMonad m (SimulatedChainNetwork Tx m)
forall (m :: * -> *) a. Monad m => m a -> RunMonad m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (SimulatedChainNetwork Tx m)
 -> RunMonad m (SimulatedChainNetwork Tx m))
-> m (SimulatedChainNetwork Tx m)
-> RunMonad m (SimulatedChainNetwork Tx m)
forall a b. (a -> b) -> a -> b
$ Tracer m CardanoChainLog
-> [(Secret (SigningKey HydraKey), CardanoSigningKey)]
-> m (SimulatedChainNetwork Tx m)
forall (m :: * -> *).
(MonadTimer m, MonadAsync m, MonadMask m, MonadThrow (STM m),
 MonadLabelledSTM m, MonadFork m, MonadDelay m, MonadTime m) =>
Tracer m CardanoChainLog
-> [(Secret (SigningKey HydraKey), CardanoSigningKey)]
-> m (SimulatedChainNetwork Tx m)
mockChainAndNetwork ((CardanoChainLog -> HydraLog Tx)
-> Tracer m (HydraLog Tx) -> Tracer m CardanoChainLog
forall a' a. (a' -> a) -> Tracer m a -> Tracer m a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap CardanoChainLog -> HydraLog Tx
forall tx. CardanoChainLog -> HydraLog tx
DirectChain Tracer m (HydraLog Tx)
tr) [(Secret (SigningKey HydraKey), CardanoSigningKey)]
seedKeys
  Async m () -> RunMonad m ()
forall (m :: * -> *). MonadSTM m => Async m () -> RunMonad m ()
pushThread Async m ()
tickThread

  [(Party,
  (TestHydraClient Tx m,
   (EventStore (StateEvent Tx) m, m [StateEvent Tx]), Async m ()))]
perNode <- [(Secret (SigningKey HydraKey), CardanoSigningKey)]
-> ((Secret (SigningKey HydraKey), CardanoSigningKey)
    -> RunMonad
         m
         (Party,
          (TestHydraClient Tx m,
           (EventStore (StateEvent Tx) m, m [StateEvent Tx]), Async m ())))
-> RunMonad
     m
     [(Party,
       (TestHydraClient Tx m,
        (EventStore (StateEvent Tx) m, m [StateEvent Tx]), Async m ()))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Secret (SigningKey HydraKey), CardanoSigningKey)]
seedKeys (((Secret (SigningKey HydraKey), CardanoSigningKey)
  -> RunMonad
       m
       (Party,
        (TestHydraClient Tx m,
         (EventStore (StateEvent Tx) m, m [StateEvent Tx]), Async m ())))
 -> RunMonad
      m
      [(Party,
        (TestHydraClient Tx m,
         (EventStore (StateEvent Tx) m, m [StateEvent Tx]), Async m ()))])
-> ((Secret (SigningKey HydraKey), CardanoSigningKey)
    -> RunMonad
         m
         (Party,
          (TestHydraClient Tx m,
           (EventStore (StateEvent Tx) m, m [StateEvent Tx]), Async m ())))
-> RunMonad
     m
     [(Party,
       (TestHydraClient Tx m,
        (EventStore (StateEvent Tx) m, m [StateEvent Tx]), Async m ()))]
forall a b. (a -> b) -> a -> b
$ \(Secret (SigningKey HydraKey)
hsk, CardanoSigningKey
_csk) -> do
    let party :: Party
party = Secret (SigningKey HydraKey) -> Party
deriveParty Secret (SigningKey HydraKey)
hsk
        otherParties :: [Party]
otherParties = (Party -> Bool) -> [Party] -> [Party]
forall a. (a -> Bool) -> [a] -> [a]
filter (Party -> Party -> Bool
forall a. Eq a => a -> a -> Bool
/= Party
party) [Party]
parties
    (EventStore (StateEvent Tx) m, m [StateEvent Tx])
eventStore <- m (EventStore (StateEvent Tx) m, m [StateEvent Tx])
-> RunMonad m (EventStore (StateEvent Tx) m, m [StateEvent Tx])
forall (m :: * -> *) a. Monad m => m a -> RunMonad m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m (EventStore (StateEvent Tx) m, m [StateEvent Tx])
forall (m :: * -> *) a.
MonadLabelledSTM m =>
m (EventStore a m, m [a])
createMockEventStoreWithReader
    (TestHydraClient Tx m
testClient, Async m ()
nodeThread) <- Tracer m (HydraLog Tx)
-> SimulatedChainNetwork Tx m
-> ContestationPeriod
-> (EventStore (StateEvent Tx) m, m [StateEvent Tx])
-> Secret (SigningKey HydraKey)
-> [Party]
-> RunMonad m (TestHydraClient Tx m, Async m ())
forall (m :: * -> *).
(MonadAsync m, MonadLabelledSTM m, MonadFork m, MonadDelay m,
 MonadMask m, MonadTime m) =>
Tracer m (HydraLog Tx)
-> SimulatedChainNetwork Tx m
-> ContestationPeriod
-> (EventStore (StateEvent Tx) m, m [StateEvent Tx])
-> Secret (SigningKey HydraKey)
-> [Party]
-> RunMonad m (TestHydraClient Tx m, Async m ())
startNode Tracer m (HydraLog Tx)
tr SimulatedChainNetwork Tx m
mockChain ContestationPeriod
seedCP (EventStore (StateEvent Tx) m, m [StateEvent Tx])
eventStore Secret (SigningKey HydraKey)
hsk [Party]
otherParties
    Async m () -> RunMonad m ()
forall (m :: * -> *). MonadSTM m => Async m () -> RunMonad m ()
pushThread Async m ()
nodeThread
    (Party,
 (TestHydraClient Tx m,
  (EventStore (StateEvent Tx) m, m [StateEvent Tx]), Async m ()))
-> RunMonad
     m
     (Party,
      (TestHydraClient Tx m,
       (EventStore (StateEvent Tx) m, m [StateEvent Tx]), Async m ()))
forall a. a -> RunMonad m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Party
party, (TestHydraClient Tx m
testClient, (EventStore (StateEvent Tx) m, m [StateEvent Tx])
eventStore, Async m ()
nodeThread))

  (Nodes m -> Nodes m) -> RunMonad m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Nodes m -> Nodes m) -> RunMonad m ())
-> (Nodes m -> Nodes m) -> RunMonad m ()
forall a b. (a -> b) -> a -> b
$ \Nodes m
n ->
    Nodes m
n
      { nodes = Map.fromList [(party, c) | (party, (c, _, _)) <- perNode]
      , eventStores = Map.fromList [(party, es) | (party, (_, es, _)) <- perNode]
      , nodeThreads = Map.fromList [(party, t) | (party, (_, _, t)) <- perNode]
      , chain = mockChain
      }
 where
  parties :: [Party]
parties = ((Secret (SigningKey HydraKey), CardanoSigningKey) -> Party)
-> [(Secret (SigningKey HydraKey), CardanoSigningKey)] -> [Party]
forall a b. (a -> b) -> [a] -> [b]
map (Secret (SigningKey HydraKey) -> Party
deriveParty (Secret (SigningKey HydraKey) -> Party)
-> ((Secret (SigningKey HydraKey), CardanoSigningKey)
    -> Secret (SigningKey HydraKey))
-> (Secret (SigningKey HydraKey), CardanoSigningKey)
-> Party
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Secret (SigningKey HydraKey), CardanoSigningKey)
-> Secret (SigningKey HydraKey)
forall a b. (a, b) -> a
fst) [(Secret (SigningKey HydraKey), CardanoSigningKey)]
seedKeys

  pushThread :: MonadSTM m => Async m () -> RunMonad m ()
  pushThread :: forall (m :: * -> *). MonadSTM m => Async m () -> RunMonad m ()
pushThread Async m ()
t = (Nodes m -> Nodes m) -> RunMonad m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Nodes m -> Nodes m) -> RunMonad m ())
-> (Nodes m -> Nodes m) -> RunMonad m ()
forall a b. (a -> b) -> a -> b
$ \Nodes m
s ->
    Nodes m
s{threads = t : threads s}

-- | (Re-)create and start a single hydra node on the given event store,
-- recovering its state from the store's events, and wait for it to be in sync
-- with the chain. Shared by 'seedWorld' and 'performRestartNode'.
startNode ::
  ( MonadAsync m
  , MonadLabelledSTM m
  , MonadFork m
  , MonadDelay m
  , MonadMask m
  , MonadTime m
  ) =>
  Tracer m (HydraLog Tx) ->
  SimulatedChainNetwork Tx m ->
  ContestationPeriod ->
  (EventStore (StateEvent Tx) m, m [StateEvent Tx]) ->
  Secret (SigningKey HydraKey) ->
  [Party] ->
  RunMonad m (TestHydraClient Tx m, Async m ())
startNode :: forall (m :: * -> *).
(MonadAsync m, MonadLabelledSTM m, MonadFork m, MonadDelay m,
 MonadMask m, MonadTime m) =>
Tracer m (HydraLog Tx)
-> SimulatedChainNetwork Tx m
-> ContestationPeriod
-> (EventStore (StateEvent Tx) m, m [StateEvent Tx])
-> Secret (SigningKey HydraKey)
-> [Party]
-> RunMonad m (TestHydraClient Tx m, Async m ())
startNode Tracer m (HydraLog Tx)
tr SimulatedChainNetwork Tx m
mockChain ContestationPeriod
seedCP (EventStore (StateEvent Tx) m
eventStore, m [StateEvent Tx]
readEvents) Secret (SigningKey HydraKey)
hsk [Party]
otherParties = m (TestHydraClient Tx m, Async m ())
-> RunMonad m (TestHydraClient Tx m, Async m ())
forall (m :: * -> *) a. Monad m => m a -> RunMonad m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (TestHydraClient Tx m, Async m ())
 -> RunMonad m (TestHydraClient Tx m, Async m ()))
-> m (TestHydraClient Tx m, Async m ())
-> RunMonad m (TestHydraClient Tx m, Async m ())
forall a b. (a -> b) -> a -> b
$ do
  TQueue m (ServerOutput Tx)
outputs <- String -> m (TQueue m (ServerOutput Tx))
forall (m :: * -> *) a.
MonadLabelledSTM m =>
String -> m (TQueue m a)
newLabelledTQueueIO (String
"seed-world-outputs-" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Secret (SigningKey HydraKey) -> String
shortLabel Secret (SigningKey HydraKey)
hsk)
  TQueue m (ClientMessage Tx)
messages <- String -> m (TQueue m (ClientMessage Tx))
forall (m :: * -> *) a.
MonadLabelledSTM m =>
String -> m (TQueue m a)
newLabelledTQueueIO (String
"seed-world-messages-" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Secret (SigningKey HydraKey) -> String
shortLabel Secret (SigningKey HydraKey)
hsk)
  TVar m [ServerOutput Tx]
outputHistory <- String -> [ServerOutput Tx] -> m (TVar m [ServerOutput Tx])
forall (m :: * -> *) a.
MonadLabelledSTM m =>
String -> a -> m (TVar m a)
newLabelledTVarIO String
"seed-world-output-history" []
  [StateEvent Tx]
events <- m [StateEvent Tx]
readEvents
  node :: HydraNode Tx m
node@HydraNode{$sel:nodeStateHandler:HydraNode :: forall tx (m :: * -> *). HydraNode tx m -> NodeStateHandler tx m
nodeStateHandler = NodeStateHandler{STM m (NodeState Tx)
queryNodeState :: STM m (NodeState Tx)
$sel:queryNodeState:NodeStateHandler :: forall tx (m :: * -> *).
NodeStateHandler tx m -> STM m (NodeState tx)
queryNodeState}} <-
    EventStore (StateEvent Tx) m
-> [StateEvent Tx]
-> Tracer m (HydraNodeLog Tx)
-> Ledger Tx
-> ChainStateType Tx
-> Secret (SigningKey HydraKey)
-> [Party]
-> TQueue m (ServerOutput Tx)
-> TQueue m (ClientMessage Tx)
-> TVar m [ServerOutput Tx]
-> SimulatedChainNetwork Tx m
-> ContestationPeriod
-> DepositPeriod
-> m (HydraNode Tx m)
forall tx (m :: * -> *).
(IsChainState tx, MonadDelay m, MonadAsync m, MonadLabelledSTM m,
 MonadThrow m) =>
EventStore (StateEvent tx) m
-> [StateEvent tx]
-> Tracer m (HydraNodeLog tx)
-> Ledger tx
-> ChainStateType tx
-> Secret (SigningKey HydraKey)
-> [Party]
-> TQueue m (ServerOutput tx)
-> TQueue m (ClientMessage tx)
-> TVar m [ServerOutput tx]
-> SimulatedChainNetwork tx m
-> ContestationPeriod
-> DepositPeriod
-> m (HydraNode tx m)
createHydraNodeWithEventStore
      EventStore (StateEvent Tx) m
eventStore
      [StateEvent Tx]
events
      ((HydraNodeLog Tx -> HydraLog Tx)
-> Tracer m (HydraLog Tx) -> Tracer m (HydraNodeLog Tx)
forall a' a. (a' -> a) -> Tracer m a -> Tracer m a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap HydraNodeLog Tx -> HydraLog Tx
forall tx. HydraNodeLog tx -> HydraLog tx
Node Tracer m (HydraLog Tx)
tr)
      Ledger Tx
ledger
      ChainStateType Tx
initialChainState
      Secret (SigningKey HydraKey)
hsk
      [Party]
otherParties
      TQueue m (ServerOutput Tx)
outputs
      TQueue m (ClientMessage Tx)
messages
      TVar m [ServerOutput Tx]
outputHistory
      SimulatedChainNetwork Tx m
mockChain
      ContestationPeriod
seedCP
      DepositPeriod
testDepositPeriod
  Async m ()
nodeThread <- String -> m () -> m (Async m ())
forall (m :: * -> *) a.
MonadAsync m =>
String -> m a -> m (Async m a)
asyncLabelled (String
"seed-world-node-" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Secret (SigningKey HydraKey) -> String
shortLabel Secret (SigningKey HydraKey)
hsk) (m () -> m (Async m ())) -> m () -> m (Async m ())
forall a b. (a -> b) -> a -> b
$ HydraNode Tx m -> m ()
forall (m :: * -> *) tx.
(MonadCatch m, MonadAsync m, MonadTime m, IsChainState tx) =>
HydraNode tx m -> m ()
runHydraNode HydraNode Tx m
node
  Async m () -> m ()
forall (m :: * -> *) a.
(MonadAsync m, MonadFork m, MonadMask m) =>
Async m a -> m ()
link Async m ()
nodeThread
  -- await for the node to be in sync with the chain before returning the client
  STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    NodeState Tx
st <- STM m (NodeState Tx)
queryNodeState
    case NodeState Tx
st of
      NodeInSync{} -> () -> STM m ()
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      NodeState Tx
_ -> STM m ()
forall a. STM m a
forall (m :: * -> *) a. MonadSTM m => STM m a
retry
  let testClient :: TestHydraClient Tx m
testClient = TQueue m (ServerOutput Tx)
-> TQueue m (ClientMessage Tx)
-> TVar m [ServerOutput Tx]
-> HydraNode Tx m
-> TestHydraClient Tx m
forall (m :: * -> *) tx.
MonadSTM m =>
TQueue m (ServerOutput tx)
-> TQueue m (ClientMessage tx)
-> TVar m [ServerOutput tx]
-> HydraNode tx m
-> TestHydraClient tx m
createTestHydraClient TQueue m (ServerOutput Tx)
outputs TQueue m (ClientMessage Tx)
messages TVar m [ServerOutput Tx]
outputHistory HydraNode Tx m
node
  (TestHydraClient Tx m, Async m ())
-> m (TestHydraClient Tx m, Async m ())
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TestHydraClient Tx m
testClient, Async m ()
nodeThread)
 where
  ledger :: Ledger Tx
ledger = Globals -> LedgerEnv LedgerEra -> Ledger Tx
cardanoLedger Globals
defaultGlobals LedgerEnv LedgerEra
defaultLedgerEnv

performDeposit ::
  (MonadThrow m, MonadTimer m, MonadAsync m, MonadTime m, MonadLabelledSTM m) =>
  HeadId ->
  [(CardanoSigningKey, Value)] ->
  RunMonad m ()
performDeposit :: forall (m :: * -> *).
(MonadThrow m, MonadTimer m, MonadAsync m, MonadTime m,
 MonadLabelledSTM m) =>
HeadId -> [(CardanoSigningKey, Value)] -> RunMonad m ()
performDeposit HeadId
headId [(CardanoSigningKey, Value)]
utxoToDeposit = do
  Map Party (TestHydraClient Tx m)
nodes <- (Nodes m -> Map Party (TestHydraClient Tx m))
-> RunMonad m (Map Party (TestHydraClient Tx m))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Nodes m -> Map Party (TestHydraClient Tx m)
forall (m :: * -> *). Nodes m -> Map Party (TestHydraClient Tx m)
nodes
  SimulatedChainNetwork{HeadId -> UTxOType Tx -> UTCTime -> m (TxIdType Tx)
simulateDeposit :: HeadId -> UTxOType Tx -> UTCTime -> m (TxIdType Tx)
$sel:simulateDeposit:SimulatedChainNetwork :: forall tx (m :: * -> *).
SimulatedChainNetwork tx m
-> HeadId -> UTxOType tx -> UTCTime -> m (TxIdType tx)
simulateDeposit} <- (Nodes m -> SimulatedChainNetwork Tx m)
-> RunMonad m (SimulatedChainNetwork Tx m)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Nodes m -> SimulatedChainNetwork Tx m
forall (m :: * -> *). Nodes m -> SimulatedChainNetwork Tx m
chain
  UTCTime
deadline <- RunMonad m UTCTime
forall (m :: * -> *). MonadTime m => RunMonad m UTCTime
depositDeadline
  m () -> RunMonad m ()
forall (m :: * -> *) a. Monad m => m a -> RunMonad m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> RunMonad m ()) -> m () -> RunMonad m ()
forall a b. (a -> b) -> a -> b
$ do
    TxId
txid <- HeadId -> UTxOType Tx -> UTCTime -> m (TxIdType Tx)
simulateDeposit HeadId
headId (UTxOType Payment -> UTxOType Tx
toRealUTxO [(CardanoSigningKey, Value)]
UTxOType Payment
utxoToDeposit) UTCTime
deadline
    [TestHydraClient Tx m] -> (ServerOutput Tx -> Maybe ()) -> m ()
forall tx (m :: * -> *) a.
(Show (ServerOutput tx), HasCallStack, MonadThrow m, MonadAsync m,
 MonadTimer m, MonadLabelledSTM m, Eq a, Show a, IsChainState tx) =>
[TestHydraClient tx m] -> (ServerOutput tx -> Maybe a) -> m a
waitUntilMatch (Map Party (TestHydraClient Tx m) -> [TestHydraClient Tx m]
forall t a b. (IsList t, Item t ~ (a, b)) => t -> [b]
elems Map Party (TestHydraClient Tx m)
nodes) ((ServerOutput Tx -> Maybe ()) -> m ())
-> (ServerOutput Tx -> Maybe ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \case
      -- NOTE: We are fine with only recorded outputs if the utxo is not
      -- actually adding something. Honest nodes would not try to
      -- snapshot/increment this.
      CommitRecorded{} | [(CardanoSigningKey, Value)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(CardanoSigningKey, Value)]
utxoToDeposit -> () -> Maybe ()
forall a. a -> Maybe a
Just ()
      CommitFinalized{TxIdType Tx
depositTxId :: TxIdType Tx
$sel:depositTxId:NetworkConnected :: forall tx. ServerOutput tx -> TxIdType tx
depositTxId} -> Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ TxId
txid TxId -> TxId -> Bool
forall a. Eq a => a -> a -> Bool
== TxIdType Tx
TxId
depositTxId
      ServerOutput Tx
_ -> Maybe ()
forall a. Maybe a
Nothing

-- | Deadline for deposits made by the model: far enough in the future that the
-- deposit is still claimable once it activates (at @created +
-- depositActivation@, with @created@ up to half a deposit period ahead of
-- submission) even when several deposits settle one after the other, each
-- taking a few blocks. It expires at @deadline - depositPeriod@.
depositDeadline :: MonadTime m => RunMonad m UTCTime
depositDeadline :: forall (m :: * -> *). MonadTime m => RunMonad m UTCTime
depositDeadline = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime (NominalDiffTime
8 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* DepositPeriod -> NominalDiffTime
toNominalDiffTime DepositPeriod
testDepositPeriod) (UTCTime -> UTCTime) -> RunMonad m UTCTime -> RunMonad m UTCTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RunMonad m UTCTime
forall (m :: * -> *). MonadTime m => m UTCTime
getCurrentTime

-- | Submit a deposit and wait until every node has recorded it on chain. Its
-- settlement is observed separately, see 'performObserveCommitFinalized'.
performSubmitDeposit ::
  (MonadThrow m, MonadTimer m, MonadDelay m, MonadTime m) =>
  HeadId ->
  [(CardanoSigningKey, Value)] ->
  RunMonad m TxId
performSubmitDeposit :: forall (m :: * -> *).
(MonadThrow m, MonadTimer m, MonadDelay m, MonadTime m) =>
HeadId -> [(CardanoSigningKey, Value)] -> RunMonad m TxId
performSubmitDeposit HeadId
headId [(CardanoSigningKey, Value)]
utxoToDeposit = do
  Map Party (TestHydraClient Tx m)
nodes <- (Nodes m -> Map Party (TestHydraClient Tx m))
-> RunMonad m (Map Party (TestHydraClient Tx m))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Nodes m -> Map Party (TestHydraClient Tx m)
forall (m :: * -> *). Nodes m -> Map Party (TestHydraClient Tx m)
nodes
  SimulatedChainNetwork{HeadId -> UTxOType Tx -> UTCTime -> m (TxIdType Tx)
$sel:simulateDeposit:SimulatedChainNetwork :: forall tx (m :: * -> *).
SimulatedChainNetwork tx m
-> HeadId -> UTxOType tx -> UTCTime -> m (TxIdType tx)
simulateDeposit :: HeadId -> UTxOType Tx -> UTCTime -> m (TxIdType Tx)
simulateDeposit} <- (Nodes m -> SimulatedChainNetwork Tx m)
-> RunMonad m (SimulatedChainNetwork Tx m)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Nodes m -> SimulatedChainNetwork Tx m
forall (m :: * -> *). Nodes m -> SimulatedChainNetwork Tx m
chain
  UTCTime
deadline <- RunMonad m UTCTime
forall (m :: * -> *). MonadTime m => RunMonad m UTCTime
depositDeadline
  m TxId -> RunMonad m TxId
forall (m :: * -> *) a. Monad m => m a -> RunMonad m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m TxId -> RunMonad m TxId) -> m TxId -> RunMonad m TxId
forall a b. (a -> b) -> a -> b
$ do
    TxId
txid <- HeadId -> UTxOType Tx -> UTCTime -> m (TxIdType Tx)
simulateDeposit HeadId
headId (UTxOType Payment -> UTxOType Tx
toRealUTxO [(CardanoSigningKey, Value)]
UTxOType Payment
utxoToDeposit) UTCTime
deadline
    String
-> Int
-> [TestHydraClient Tx m]
-> (ServerOutput Tx -> Bool)
-> m ()
forall (m :: * -> *).
(MonadThrow m, MonadTimer m, MonadDelay m) =>
String
-> Int
-> [TestHydraClient Tx m]
-> (ServerOutput Tx -> Bool)
-> m ()
waitForOutputs (String
"deposit " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> TxId -> String
forall b a. (Show a, IsString b) => a -> b
show TxId
txid String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" recorded") Int
1 (Map Party (TestHydraClient Tx m) -> [TestHydraClient Tx m]
forall t a b. (IsList t, Item t ~ (a, b)) => t -> [b]
elems Map Party (TestHydraClient Tx m)
nodes) ((ServerOutput Tx -> Bool) -> m ())
-> (ServerOutput Tx -> Bool) -> m ()
forall a b. (a -> b) -> a -> b
$ \case
      CommitRecorded{TxIdType Tx
pendingDeposit :: TxIdType Tx
$sel:pendingDeposit:NetworkConnected :: forall tx. ServerOutput tx -> TxIdType tx
pendingDeposit} -> TxId
txid TxId -> TxId -> Bool
forall a. Eq a => a -> a -> Bool
== TxIdType Tx
TxId
pendingDeposit
      ServerOutput Tx
_ -> Bool
False
    TxId -> m TxId
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TxId
txid

-- | Wait until every node has confirmed a snapshot claiming the given deposit
-- ('CommitApproved'): the increment is now in flight.
performObserveCommitApproved ::
  (MonadThrow m, MonadTimer m, MonadDelay m) =>
  UTxOType Payment ->
  RunMonad m ()
performObserveCommitApproved :: forall (m :: * -> *).
(MonadThrow m, MonadTimer m, MonadDelay m) =>
UTxOType Payment -> RunMonad m ()
performObserveCommitApproved UTxOType Payment
deposited = do
  Map Party (TestHydraClient Tx m)
nodes <- (Nodes m -> Map Party (TestHydraClient Tx m))
-> RunMonad m (Map Party (TestHydraClient Tx m))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Nodes m -> Map Party (TestHydraClient Tx m)
forall (m :: * -> *). Nodes m -> Map Party (TestHydraClient Tx m)
nodes
  let expected :: [TxOut CtxUTxO]
expected = [TxOut CtxUTxO] -> [TxOut CtxUTxO]
forall ctx. [TxOut ctx] -> [TxOut ctx]
sortTxOuts (UTxO Era -> [TxOut CtxUTxO]
forall era. UTxO era -> [TxOut CtxUTxO era]
UTxO.txOutputs (UTxOType Payment -> UTxOType Tx
toRealUTxO UTxOType Payment
deposited))
  m () -> RunMonad m ()
forall (m :: * -> *) a. Monad m => m a -> RunMonad m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> RunMonad m ())
-> ((ServerOutput Tx -> Bool) -> m ())
-> (ServerOutput Tx -> Bool)
-> RunMonad m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String
-> Int
-> [TestHydraClient Tx m]
-> (ServerOutput Tx -> Bool)
-> m ()
forall (m :: * -> *).
(MonadThrow m, MonadTimer m, MonadDelay m) =>
String
-> Int
-> [TestHydraClient Tx m]
-> (ServerOutput Tx -> Bool)
-> m ()
waitForOutputs String
"commit approved" Int
1 (Map Party (TestHydraClient Tx m) -> [TestHydraClient Tx m]
forall t a b. (IsList t, Item t ~ (a, b)) => t -> [b]
elems Map Party (TestHydraClient Tx m)
nodes) ((ServerOutput Tx -> Bool) -> RunMonad m ())
-> (ServerOutput Tx -> Bool) -> RunMonad m ()
forall a b. (a -> b) -> a -> b
$ \case
    CommitApproved{UTxOType Tx
utxoToCommit :: UTxOType Tx
$sel:utxoToCommit:NetworkConnected :: forall tx. ServerOutput tx -> UTxOType tx
utxoToCommit} -> [TxOut CtxUTxO] -> [TxOut CtxUTxO]
forall ctx. [TxOut ctx] -> [TxOut ctx]
sortTxOuts (UTxO Era -> [TxOut CtxUTxO]
forall era. UTxO era -> [TxOut CtxUTxO era]
UTxO.txOutputs UTxOType Tx
UTxO Era
utxoToCommit) [TxOut CtxUTxO] -> [TxOut CtxUTxO] -> Bool
forall a. Eq a => a -> a -> Bool
== [TxOut CtxUTxO]
expected
    ServerOutput Tx
_ -> Bool
False

-- | Wait until every node has reported the increment claiming the given
-- deposit for the n-th time. A wedged settlement surfaces here as a timeout.
performObserveCommitFinalized ::
  (MonadThrow m, MonadTimer m, MonadDelay m) =>
  Int ->
  TxId ->
  RunMonad m ()
performObserveCommitFinalized :: forall (m :: * -> *).
(MonadThrow m, MonadTimer m, MonadDelay m) =>
Int -> TxId -> RunMonad m ()
performObserveCommitFinalized Int
n TxId
txid = do
  Map Party (TestHydraClient Tx m)
nodes <- (Nodes m -> Map Party (TestHydraClient Tx m))
-> RunMonad m (Map Party (TestHydraClient Tx m))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Nodes m -> Map Party (TestHydraClient Tx m)
forall (m :: * -> *). Nodes m -> Map Party (TestHydraClient Tx m)
nodes
  m () -> RunMonad m ()
forall (m :: * -> *) a. Monad m => m a -> RunMonad m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> RunMonad m ())
-> ((ServerOutput Tx -> Bool) -> m ())
-> (ServerOutput Tx -> Bool)
-> RunMonad m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String
-> Int
-> [TestHydraClient Tx m]
-> (ServerOutput Tx -> Bool)
-> m ()
forall (m :: * -> *).
(MonadThrow m, MonadTimer m, MonadDelay m) =>
String
-> Int
-> [TestHydraClient Tx m]
-> (ServerOutput Tx -> Bool)
-> m ()
waitForOutputs (String
"commit " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> TxId -> String
forall b a. (Show a, IsString b) => a -> b
show TxId
txid String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" finalized (" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall b a. (Show a, IsString b) => a -> b
show Int
n String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
". time)") Int
n (Map Party (TestHydraClient Tx m) -> [TestHydraClient Tx m]
forall t a b. (IsList t, Item t ~ (a, b)) => t -> [b]
elems Map Party (TestHydraClient Tx m)
nodes) ((ServerOutput Tx -> Bool) -> RunMonad m ())
-> (ServerOutput Tx -> Bool) -> RunMonad m ()
forall a b. (a -> b) -> a -> b
$ \case
    CommitFinalized{TxIdType Tx
$sel:depositTxId:NetworkConnected :: forall tx. ServerOutput tx -> TxIdType tx
depositTxId :: TxIdType Tx
depositTxId} -> TxId
txid TxId -> TxId -> Bool
forall a. Eq a => a -> a -> Bool
== TxIdType Tx
TxId
depositTxId
    ServerOutput Tx
_ -> Bool
False

-- | Wait until every node's output history holds at least @n@ outputs
-- matching the predicate, or fail after 'observationTimeout'.
--
-- Unlike 'waitUntilMatch' this does not consume outputs, so settlements can
-- be observed in any order (several may be in flight and finalize in an order
-- the model does not control) and repeatedly (a settlement re-landing after a
-- fork is reported again). It also does not swallow reports that arrive
-- earlier than expected, e.g. a decrement observed on chain before its
-- snapshot confirmed locally.
waitForOutputs ::
  (MonadThrow m, MonadTimer m, MonadDelay m) =>
  String ->
  Int ->
  [TestHydraClient Tx m] ->
  (ServerOutput Tx -> Bool) ->
  m ()
waitForOutputs :: forall (m :: * -> *).
(MonadThrow m, MonadTimer m, MonadDelay m) =>
String
-> Int
-> [TestHydraClient Tx m]
-> (ServerOutput Tx -> Bool)
-> m ()
waitForOutputs String
what Int
n [TestHydraClient Tx m]
nodes ServerOutput Tx -> Bool
p =
  String
-> [TestHydraClient Tx m] -> ([ServerOutput Tx] -> Bool) -> m ()
forall (m :: * -> *).
(MonadThrow m, MonadTimer m, MonadDelay m) =>
String
-> [TestHydraClient Tx m] -> ([ServerOutput Tx] -> Bool) -> m ()
waitUntilHistory (String
what String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall b a. (Show a, IsString b) => a -> b
show Int
n String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" time(s)") [TestHydraClient Tx m]
nodes (([ServerOutput Tx] -> Bool) -> m ())
-> ([ServerOutput Tx] -> Bool) -> m ()
forall a b. (a -> b) -> a -> b
$ \[ServerOutput Tx]
outs ->
    [ServerOutput Tx] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((ServerOutput Tx -> Bool) -> [ServerOutput Tx] -> [ServerOutput Tx]
forall a. (a -> Bool) -> [a] -> [a]
filter ServerOutput Tx -> Bool
p [ServerOutput Tx]
outs) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
n

-- | Wait until every node's output history satisfies the predicate, or fail
-- after 'observationTimeout'. See 'waitForOutputs'.
waitUntilHistory ::
  (MonadThrow m, MonadTimer m, MonadDelay m) =>
  String ->
  [TestHydraClient Tx m] ->
  ([ServerOutput Tx] -> Bool) ->
  m ()
waitUntilHistory :: forall (m :: * -> *).
(MonadThrow m, MonadTimer m, MonadDelay m) =>
String
-> [TestHydraClient Tx m] -> ([ServerOutput Tx] -> Bool) -> m ()
waitUntilHistory String
what [TestHydraClient Tx m]
nodes [ServerOutput Tx] -> Bool
p =
  DiffTime -> m () -> m (Maybe ())
forall a. DiffTime -> m a -> m (Maybe a)
forall (m :: * -> *) a.
MonadTimer m =>
DiffTime -> m a -> m (Maybe a)
timeout DiffTime
observationTimeout ([TestHydraClient Tx m] -> (TestHydraClient Tx m -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [TestHydraClient Tx m]
nodes TestHydraClient Tx m -> m ()
waitOne) m (Maybe ()) -> (Maybe () -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just () -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Maybe ()
Nothing -> do
      [Bool]
satisfied <- [TestHydraClient Tx m]
-> (TestHydraClient Tx m -> m Bool) -> m [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [TestHydraClient Tx m]
nodes (([ServerOutput Tx] -> Bool) -> m [ServerOutput Tx] -> m Bool
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [ServerOutput Tx] -> Bool
p (m [ServerOutput Tx] -> m Bool)
-> (TestHydraClient Tx m -> m [ServerOutput Tx])
-> TestHydraClient Tx m
-> m Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestHydraClient Tx m -> m [ServerOutput Tx]
forall tx (m :: * -> *).
TestHydraClient tx m -> m [ServerOutput tx]
serverOutputs)
      String -> m ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$
        String
"waitUntilHistory: not all nodes reported " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
what String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" within " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> DiffTime -> String
forall b a. (Show a, IsString b) => a -> b
show DiffTime
observationTimeout String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"; per node: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Bool] -> String
forall b a. (Show a, IsString b) => a -> b
show [Bool]
satisfied
 where
  waitOne :: TestHydraClient Tx m -> m ()
waitOne TestHydraClient Tx m
node = do
    [ServerOutput Tx]
outs <- TestHydraClient Tx m -> m [ServerOutput Tx]
forall tx (m :: * -> *).
TestHydraClient tx m -> m [ServerOutput tx]
serverOutputs TestHydraClient Tx m
node
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([ServerOutput Tx] -> Bool
p [ServerOutput Tx]
outs) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ DiffTime -> m ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
1 m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TestHydraClient Tx m -> m ()
waitOne TestHydraClient Tx m
node

-- | How long an observation waits for the nodes to report something. Every
-- observed step (a settlement landing, re-landing after a fork, a snapshot
-- confirming) takes a handful of blocks of 20s, so an hour is generous while
-- still failing a wedged head reasonably fast.
observationTimeout :: DiffTime
observationTimeout :: DiffTime
observationTimeout = DiffTime
3600

-- | Request a decommit and wait until every node has confirmed the snapshot
-- carrying it ('DecommitApproved'), i.e. the outputs have left the L2 ledger
-- and the decrement is in flight. Its settlement is observed separately, see
-- 'performObserveDecommitFinalized'.
performSubmitDecommit ::
  forall m.
  (MonadThrow m, MonadTimer m, MonadDelay m) =>
  Party ->
  Payment ->
  RunMonad m UTxO
performSubmitDecommit :: forall (m :: * -> *).
(MonadThrow m, MonadTimer m, MonadDelay m) =>
Party -> Payment -> RunMonad m (UTxO Era)
performSubmitDecommit Party
party Payment
tx = do
  Map Party (TestHydraClient Tx m)
nodes <- (Nodes m -> Map Party (TestHydraClient Tx m))
-> RunMonad m (Map Party (TestHydraClient Tx m))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Nodes m -> Map Party (TestHydraClient Tx m)
forall (m :: * -> *). Nodes m -> Map Party (TestHydraClient Tx m)
nodes
  let thisNode :: TestHydraClient Tx m
thisNode = Map Party (TestHydraClient Tx m)
nodes Map Party (TestHydraClient Tx m) -> Party -> TestHydraClient Tx m
forall k a. Ord k => Map k a -> k -> a
! Party
party
  TestHydraClient Tx m -> RunMonad m ()
forall (m :: * -> *) tx.
MonadDelay m =>
TestHydraClient tx m -> RunMonad m ()
waitForOpen TestHydraClient Tx m
thisNode

  (TxIn
i, TxOut CtxUTxO
o) <-
    m (Either (UTxO Era) (TxIn, TxOut CtxUTxO))
-> RunMonad m (Either (UTxO Era) (TxIn, TxOut CtxUTxO))
forall (m :: * -> *) a. Monad m => m a -> RunMonad m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (UTxO Era
-> CardanoSigningKey
-> Value
-> TestHydraClient Tx m
-> m (Either (UTxO Era) (TxIn, TxOut CtxUTxO))
forall (m :: * -> *).
MonadDelay m =>
UTxO Era
-> CardanoSigningKey
-> Value
-> TestHydraClient Tx m
-> m (Either (UTxO Era) (TxIn, TxOut CtxUTxO))
waitForUTxOToSpend UTxO Era
forall a. Monoid a => a
mempty (Payment -> CardanoSigningKey
from Payment
tx) (Payment -> Value
value Payment
tx) TestHydraClient Tx m
thisNode) RunMonad m (Either (UTxO Era) (TxIn, TxOut CtxUTxO))
-> (Either (UTxO Era) (TxIn, TxOut CtxUTxO)
    -> RunMonad m (TxIn, TxOut CtxUTxO))
-> RunMonad m (TxIn, TxOut CtxUTxO)
forall a b. RunMonad m a -> (a -> RunMonad m b) -> RunMonad m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Left UTxO Era
u -> Text -> RunMonad m (TxIn, TxOut CtxUTxO)
forall a t. (HasCallStack, IsText t) => t -> a
error (Text -> RunMonad m (TxIn, TxOut CtxUTxO))
-> Text -> RunMonad m (TxIn, TxOut CtxUTxO)
forall a b. (a -> b) -> a -> b
$ Text
"Cannot execute SubmitDecommit for " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Payment -> Text
forall b a. (Show a, IsString b) => a -> b
show Payment
tx Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", no spendable UTxO in " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> UTxO Era -> Text
forall b a. (Show a, IsString b) => a -> b
show UTxO Era
u
      Right (TxIn, TxOut CtxUTxO)
ok -> (TxIn, TxOut CtxUTxO) -> RunMonad m (TxIn, TxOut CtxUTxO)
forall a. a -> RunMonad m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxIn, TxOut CtxUTxO)
ok

  let realTx :: Tx
realTx =
        (TxBodyError -> Tx) -> (Tx -> Tx) -> Either TxBodyError Tx -> Tx
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
          (Text -> Tx
forall a t. (HasCallStack, IsText t) => t -> a
error (Text -> Tx) -> (TxBodyError -> Text) -> TxBodyError -> Tx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxBodyError -> Text
forall b a. (Show a, IsString b) => a -> b
show)
          Tx -> Tx
forall a. a -> a
id
          (case Payment -> CardanoSigningKey
from Payment
tx of CardanoSigningKey Secret (SigningKey PaymentKey)
sk -> (TxIn, TxOut CtxUTxO)
-> (AddressInEra, Value)
-> Secret (SigningKey PaymentKey)
-> Either TxBodyError Tx
mkSimpleTx (TxIn
i, TxOut CtxUTxO
o) (Payment -> AddressInEra
decommitRecipient Payment
tx, Payment -> Value
value Payment
tx) Secret (SigningKey PaymentKey)
sk)

  let decommitted :: UTxOType Tx
decommitted = Tx -> UTxOType Tx
forall tx. IsTx tx => tx -> UTxOType tx
utxoFromTx Tx
realTx
      decommitTxId :: TxId
decommitTxId = TxBody Era -> TxId
forall era. TxBody era -> TxId
getTxId (Tx -> TxBody Era
forall era. Tx era -> TxBody era
getTxBody Tx
realTx)
      -- NOTE: Sync on the confirmed snapshot carrying the decommit rather than
      -- on 'DecommitApproved', which not every node emits.
      approved :: ServerOutput Tx -> Bool
approved = \case
        SnapshotConfirmed{Snapshot Tx
snapshot :: Snapshot Tx
$sel:snapshot:NetworkConnected :: forall tx. ServerOutput tx -> Snapshot tx
snapshot} ->
          ([TxOut CtxUTxO] -> [TxOut CtxUTxO]
forall ctx. [TxOut ctx] -> [TxOut ctx]
sortTxOuts ([TxOut CtxUTxO] -> [TxOut CtxUTxO])
-> (UTxO Era -> [TxOut CtxUTxO]) -> UTxO Era -> [TxOut CtxUTxO]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTxO Era -> [TxOut CtxUTxO]
forall era. UTxO era -> [TxOut CtxUTxO era]
UTxO.txOutputs (UTxO Era -> [TxOut CtxUTxO])
-> Maybe (UTxO Era) -> Maybe [TxOut CtxUTxO]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Snapshot Tx -> Maybe (UTxOType Tx)
forall tx. Snapshot tx -> Maybe (UTxOType tx)
Snapshot.utxoToDecommit Snapshot Tx
snapshot) Maybe [TxOut CtxUTxO] -> Maybe [TxOut CtxUTxO] -> Bool
forall a. Eq a => a -> a -> Bool
== [TxOut CtxUTxO] -> Maybe [TxOut CtxUTxO]
forall a. a -> Maybe a
Just ([TxOut CtxUTxO] -> [TxOut CtxUTxO]
forall ctx. [TxOut ctx] -> [TxOut ctx]
sortTxOuts (UTxO Era -> [TxOut CtxUTxO]
forall era. UTxO era -> [TxOut CtxUTxO era]
UTxO.txOutputs UTxOType Tx
UTxO Era
decommitted))
        ServerOutput Tx
_ -> Bool
False
      -- A decommit requested while a deposit is unsettled is parked by the
      -- node; if the deposit does not settle within the request's TTL the
      -- node rejects it. A client then simply asks again once the deposit is
      -- through, which is what this does.
      rejectedForPendingDeposit :: ServerOutput Tx -> Bool
rejectedForPendingDeposit = \case
        DecommitInvalid{Tx
decommitTx :: Tx
$sel:decommitTx:NetworkConnected :: forall tx. ServerOutput tx -> tx
decommitTx, $sel:decommitInvalidReason:NetworkConnected :: forall tx. ServerOutput tx -> DecommitInvalidReason tx
decommitInvalidReason = DepositInFlight{}} ->
          TxBody Era -> TxId
forall era. TxBody era -> TxId
getTxId (Tx -> TxBody Era
forall era. Tx era -> TxBody era
getTxBody Tx
decommitTx) TxId -> TxId -> Bool
forall a. Eq a => a -> a -> Bool
== TxId
decommitTxId
        ServerOutput Tx
_ -> Bool
False
      submit :: Int -> RunMonad m ()
      submit :: Int -> RunMonad m ()
submit Int
attempt
        | Int
attempt Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxAttempts =
            String -> RunMonad m ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure (String -> RunMonad m ()) -> String -> RunMonad m ()
forall a b. (a -> b) -> a -> b
$ String
"SubmitDecommit " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> TxId -> String
forall b a. (Show a, IsString b) => a -> b
show TxId
decommitTxId String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" rejected " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall b a. (Show a, IsString b) => a -> b
show Int
maxAttempts String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" times for a deposit in flight"
        | Bool
otherwise = do
            Party
party Party -> ClientInput Tx -> RunMonad m ()
forall (m :: * -> *).
(MonadSTM m, MonadThrow m, MonadDelay m) =>
Party -> ClientInput Tx -> RunMonad m ()
`sendsInput` Tx -> ClientInput Tx
forall tx. tx -> ClientInput tx
Input.Decommit Tx
realTx
            m () -> RunMonad m ()
forall (m :: * -> *) a. Monad m => m a -> RunMonad m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> RunMonad m ())
-> (([ServerOutput Tx] -> Bool) -> m ())
-> ([ServerOutput Tx] -> Bool)
-> RunMonad m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String
-> [TestHydraClient Tx m] -> ([ServerOutput Tx] -> Bool) -> m ()
forall (m :: * -> *).
(MonadThrow m, MonadTimer m, MonadDelay m) =>
String
-> [TestHydraClient Tx m] -> ([ServerOutput Tx] -> Bool) -> m ()
waitUntilHistory (String
"snapshot with decommit " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> TxId -> String
forall b a. (Show a, IsString b) => a -> b
show TxId
decommitTxId String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" confirmed (attempt " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall b a. (Show a, IsString b) => a -> b
show Int
attempt String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
")") (Map Party (TestHydraClient Tx m) -> [TestHydraClient Tx m]
forall t a b. (IsList t, Item t ~ (a, b)) => t -> [b]
elems Map Party (TestHydraClient Tx m)
nodes) (([ServerOutput Tx] -> Bool) -> RunMonad m ())
-> ([ServerOutput Tx] -> Bool) -> RunMonad m ()
forall a b. (a -> b) -> a -> b
$ \[ServerOutput Tx]
outs ->
              (ServerOutput Tx -> Bool) -> [ServerOutput Tx] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ServerOutput Tx -> Bool
approved [ServerOutput Tx]
outs Bool -> Bool -> Bool
|| [ServerOutput Tx] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((ServerOutput Tx -> Bool) -> [ServerOutput Tx] -> [ServerOutput Tx]
forall a. (a -> Bool) -> [a] -> [a]
filter ServerOutput Tx -> Bool
rejectedForPendingDeposit [ServerOutput Tx]
outs) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
attempt
            [ServerOutput Tx]
outs <- m [ServerOutput Tx] -> RunMonad m [ServerOutput Tx]
forall (m :: * -> *) a. Monad m => m a -> RunMonad m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m [ServerOutput Tx] -> RunMonad m [ServerOutput Tx])
-> m [ServerOutput Tx] -> RunMonad m [ServerOutput Tx]
forall a b. (a -> b) -> a -> b
$ TestHydraClient Tx m -> m [ServerOutput Tx]
forall tx (m :: * -> *).
TestHydraClient tx m -> m [ServerOutput tx]
serverOutputs TestHydraClient Tx m
thisNode
            Bool -> RunMonad m () -> RunMonad m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ((ServerOutput Tx -> Bool) -> [ServerOutput Tx] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ServerOutput Tx -> Bool
approved [ServerOutput Tx]
outs) (RunMonad m () -> RunMonad m ()) -> RunMonad m () -> RunMonad m ()
forall a b. (a -> b) -> a -> b
$ Int -> RunMonad m ()
submit (Int
attempt Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  Int -> RunMonad m ()
submit Int
1
  UTxO Era -> RunMonad m (UTxO Era)
forall a. a -> RunMonad m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure UTxOType Tx
UTxO Era
decommitted
 where
  maxAttempts :: Int
maxAttempts = Int
5 :: Int

-- | Wait until every node has reported the decrement distributing the given
-- decommitted UTxO for the n-th time.
performObserveDecommitFinalized ::
  (MonadThrow m, MonadTimer m, MonadDelay m) =>
  Int ->
  UTxO ->
  RunMonad m ()
performObserveDecommitFinalized :: forall (m :: * -> *).
(MonadThrow m, MonadTimer m, MonadDelay m) =>
Int -> UTxO Era -> RunMonad m ()
performObserveDecommitFinalized Int
n UTxO Era
decommitted = do
  Map Party (TestHydraClient Tx m)
nodes <- (Nodes m -> Map Party (TestHydraClient Tx m))
-> RunMonad m (Map Party (TestHydraClient Tx m))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Nodes m -> Map Party (TestHydraClient Tx m)
forall (m :: * -> *). Nodes m -> Map Party (TestHydraClient Tx m)
nodes
  m () -> RunMonad m ()
forall (m :: * -> *) a. Monad m => m a -> RunMonad m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> RunMonad m ())
-> ((ServerOutput Tx -> Bool) -> m ())
-> (ServerOutput Tx -> Bool)
-> RunMonad m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String
-> Int
-> [TestHydraClient Tx m]
-> (ServerOutput Tx -> Bool)
-> m ()
forall (m :: * -> *).
(MonadThrow m, MonadTimer m, MonadDelay m) =>
String
-> Int
-> [TestHydraClient Tx m]
-> (ServerOutput Tx -> Bool)
-> m ()
waitForOutputs (String
"decommit finalized (" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall b a. (Show a, IsString b) => a -> b
show Int
n String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
". time)") Int
n (Map Party (TestHydraClient Tx m) -> [TestHydraClient Tx m]
forall t a b. (IsList t, Item t ~ (a, b)) => t -> [b]
elems Map Party (TestHydraClient Tx m)
nodes) ((ServerOutput Tx -> Bool) -> RunMonad m ())
-> (ServerOutput Tx -> Bool) -> RunMonad m ()
forall a b. (a -> b) -> a -> b
$ \case
    DecommitFinalized{UTxOType Tx
distributedUTxO :: UTxOType Tx
$sel:distributedUTxO:NetworkConnected :: forall tx. ServerOutput tx -> UTxOType tx
distributedUTxO} ->
      [TxOut CtxUTxO] -> [TxOut CtxUTxO]
forall ctx. [TxOut ctx] -> [TxOut ctx]
sortTxOuts (UTxO Era -> [TxOut CtxUTxO]
forall era. UTxO era -> [TxOut CtxUTxO era]
UTxO.txOutputs UTxOType Tx
UTxO Era
distributedUTxO) [TxOut CtxUTxO] -> [TxOut CtxUTxO] -> Bool
forall a. Eq a => a -> a -> Bool
== [TxOut CtxUTxO] -> [TxOut CtxUTxO]
forall ctx. [TxOut ctx] -> [TxOut ctx]
sortTxOuts (UTxO Era -> [TxOut CtxUTxO]
forall era. UTxO era -> [TxOut CtxUTxO era]
UTxO.txOutputs UTxO Era
decommitted)
    ServerOutput Tx
_ -> Bool
False

decommitRecipient :: Payment -> AddressInEra
decommitRecipient :: Payment -> AddressInEra
decommitRecipient Payment
tx = case Payment -> CardanoSigningKey
to Payment
tx of
  CardanoSigningKey Secret (SigningKey PaymentKey)
sk -> NetworkId -> VerificationKey PaymentKey -> AddressInEra
forall era.
IsShelleyBasedEra era =>
NetworkId -> VerificationKey PaymentKey -> AddressInEra era
mkVkAddress NetworkId
testNetworkId (Secret (SigningKey PaymentKey) -> VerificationKey PaymentKey
forall s k. HasVerificationKey s k => s -> VerificationKey k
getVerificationKey Secret (SigningKey PaymentKey)
sk)

performDecommit ::
  (MonadThrow m, MonadTimer m, MonadAsync m, MonadDelay m, MonadLabelledSTM m) =>
  Party ->
  Payment ->
  RunMonad m ()
performDecommit :: forall (m :: * -> *).
(MonadThrow m, MonadTimer m, MonadAsync m, MonadDelay m,
 MonadLabelledSTM m) =>
Party -> Payment -> RunMonad m ()
performDecommit Party
party Payment
tx = do
  let recipient :: AddressInEra
recipient = case Payment -> CardanoSigningKey
to Payment
tx of
        CardanoSigningKey Secret (SigningKey PaymentKey)
sk -> NetworkId -> VerificationKey PaymentKey -> AddressInEra
forall era.
IsShelleyBasedEra era =>
NetworkId -> VerificationKey PaymentKey -> AddressInEra era
mkVkAddress NetworkId
testNetworkId (Secret (SigningKey PaymentKey) -> VerificationKey PaymentKey
forall s k. HasVerificationKey s k => s -> VerificationKey k
getVerificationKey Secret (SigningKey PaymentKey)
sk)
  Map Party (TestHydraClient Tx m)
nodes <- (Nodes m -> Map Party (TestHydraClient Tx m))
-> RunMonad m (Map Party (TestHydraClient Tx m))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Nodes m -> Map Party (TestHydraClient Tx m)
forall (m :: * -> *). Nodes m -> Map Party (TestHydraClient Tx m)
nodes
  let thisNode :: TestHydraClient Tx m
thisNode = Map Party (TestHydraClient Tx m)
nodes Map Party (TestHydraClient Tx m) -> Party -> TestHydraClient Tx m
forall k a. Ord k => Map k a -> k -> a
! Party
party
  TestHydraClient Tx m -> RunMonad m ()
forall (m :: * -> *) tx.
MonadDelay m =>
TestHydraClient tx m -> RunMonad m ()
waitForOpen TestHydraClient Tx m
thisNode

  (TxIn
i, TxOut CtxUTxO
o) <-
    m (Either (UTxO Era) (TxIn, TxOut CtxUTxO))
-> RunMonad m (Either (UTxO Era) (TxIn, TxOut CtxUTxO))
forall (m :: * -> *) a. Monad m => m a -> RunMonad m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (UTxO Era
-> CardanoSigningKey
-> Value
-> TestHydraClient Tx m
-> m (Either (UTxO Era) (TxIn, TxOut CtxUTxO))
forall (m :: * -> *).
MonadDelay m =>
UTxO Era
-> CardanoSigningKey
-> Value
-> TestHydraClient Tx m
-> m (Either (UTxO Era) (TxIn, TxOut CtxUTxO))
waitForUTxOToSpend UTxO Era
forall a. Monoid a => a
mempty (Payment -> CardanoSigningKey
from Payment
tx) (Payment -> Value
value Payment
tx) TestHydraClient Tx m
thisNode) RunMonad m (Either (UTxO Era) (TxIn, TxOut CtxUTxO))
-> (Either (UTxO Era) (TxIn, TxOut CtxUTxO)
    -> RunMonad m (TxIn, TxOut CtxUTxO))
-> RunMonad m (TxIn, TxOut CtxUTxO)
forall a b. RunMonad m a -> (a -> RunMonad m b) -> RunMonad m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Left UTxO Era
u -> Text -> RunMonad m (TxIn, TxOut CtxUTxO)
forall a t. (HasCallStack, IsText t) => t -> a
error (Text -> RunMonad m (TxIn, TxOut CtxUTxO))
-> Text -> RunMonad m (TxIn, TxOut CtxUTxO)
forall a b. (a -> b) -> a -> b
$ Text
"Cannot execute Decommit for " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Payment -> Text
forall b a. (Show a, IsString b) => a -> b
show Payment
tx Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", no spendable UTxO in " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> UTxO Era -> Text
forall b a. (Show a, IsString b) => a -> b
show UTxO Era
u
      Right (TxIn, TxOut CtxUTxO)
ok -> (TxIn, TxOut CtxUTxO) -> RunMonad m (TxIn, TxOut CtxUTxO)
forall a. a -> RunMonad m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxIn, TxOut CtxUTxO)
ok

  let realTx :: Tx
realTx =
        (TxBodyError -> Tx) -> (Tx -> Tx) -> Either TxBodyError Tx -> Tx
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
          (Text -> Tx
forall a t. (HasCallStack, IsText t) => t -> a
error (Text -> Tx) -> (TxBodyError -> Text) -> TxBodyError -> Tx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxBodyError -> Text
forall b a. (Show a, IsString b) => a -> b
show)
          Tx -> Tx
forall a. a -> a
id
          (case Payment -> CardanoSigningKey
from Payment
tx of CardanoSigningKey Secret (SigningKey PaymentKey)
sk -> (TxIn, TxOut CtxUTxO)
-> (AddressInEra, Value)
-> Secret (SigningKey PaymentKey)
-> Either TxBodyError Tx
mkSimpleTx (TxIn
i, TxOut CtxUTxO
o) (AddressInEra
recipient, Payment -> Value
value Payment
tx) Secret (SigningKey PaymentKey)
sk)

  Party
party Party -> ClientInput Tx -> RunMonad m ()
forall (m :: * -> *).
(MonadSTM m, MonadThrow m, MonadDelay m) =>
Party -> ClientInput Tx -> RunMonad m ()
`sendsInput` Tx -> ClientInput Tx
forall tx. tx -> ClientInput tx
Input.Decommit Tx
realTx

  m () -> RunMonad m ()
forall (m :: * -> *) a. Monad m => m a -> RunMonad m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> RunMonad m ())
-> ((ServerOutput Tx -> Maybe ()) -> m ())
-> (ServerOutput Tx -> Maybe ())
-> RunMonad m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TestHydraClient Tx m] -> (ServerOutput Tx -> Maybe ()) -> m ()
forall tx (m :: * -> *) a.
(Show (ServerOutput tx), HasCallStack, MonadThrow m, MonadAsync m,
 MonadTimer m, MonadLabelledSTM m, Eq a, Show a, IsChainState tx) =>
[TestHydraClient tx m] -> (ServerOutput tx -> Maybe a) -> m a
waitUntilMatch (Map Party (TestHydraClient Tx m) -> [TestHydraClient Tx m]
forall t a b. (IsList t, Item t ~ (a, b)) => t -> [b]
elems Map Party (TestHydraClient Tx m)
nodes) ((ServerOutput Tx -> Maybe ()) -> RunMonad m ())
-> (ServerOutput Tx -> Maybe ()) -> RunMonad m ()
forall a b. (a -> b) -> a -> b
$ \case
    DecommitFinalized{UTxOType Tx
$sel:distributedUTxO:NetworkConnected :: forall tx. ServerOutput tx -> UTxOType tx
distributedUTxO :: UTxOType Tx
distributedUTxO} ->
      Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ [TxOut CtxUTxO] -> [TxOut CtxUTxO]
forall ctx. [TxOut ctx] -> [TxOut ctx]
sortTxOuts (UTxO Era -> [TxOut CtxUTxO]
forall era. UTxO era -> [TxOut CtxUTxO era]
UTxO.txOutputs UTxOType Tx
UTxO Era
distributedUTxO) [TxOut CtxUTxO] -> [TxOut CtxUTxO] -> Bool
forall a. Eq a => a -> a -> Bool
== [TxOut CtxUTxO] -> [TxOut CtxUTxO]
forall ctx. [TxOut ctx] -> [TxOut ctx]
sortTxOuts (UTxO Era -> [TxOut CtxUTxO]
forall era. UTxO era -> [TxOut CtxUTxO era]
UTxO.txOutputs (UTxO Era -> [TxOut CtxUTxO]) -> UTxO Era -> [TxOut CtxUTxO]
forall a b. (a -> b) -> a -> b
$ Tx -> UTxOType Tx
forall tx. IsTx tx => tx -> UTxOType tx
utxoFromTx Tx
realTx)
    ServerOutput Tx
_ -> Maybe ()
forall a. Maybe a
Nothing

performNewTx ::
  (MonadThrow m, MonadAsync m, MonadTimer m, MonadDelay m, MonadLabelledSTM m) =>
  Party ->
  Payment ->
  RunMonad m Payment
performNewTx :: forall (m :: * -> *).
(MonadThrow m, MonadAsync m, MonadTimer m, MonadDelay m,
 MonadLabelledSTM m) =>
Party -> Payment -> RunMonad m Payment
performNewTx Party
party Payment
tx = do
  let recipient :: AddressInEra
recipient = case Payment -> CardanoSigningKey
to Payment
tx of
        CardanoSigningKey Secret (SigningKey PaymentKey)
sk -> NetworkId -> VerificationKey PaymentKey -> AddressInEra
forall era.
IsShelleyBasedEra era =>
NetworkId -> VerificationKey PaymentKey -> AddressInEra era
mkVkAddress NetworkId
testNetworkId (Secret (SigningKey PaymentKey) -> VerificationKey PaymentKey
forall s k. HasVerificationKey s k => s -> VerificationKey k
getVerificationKey Secret (SigningKey PaymentKey)
sk)
  Map Party (TestHydraClient Tx m)
nodes <- (Nodes m -> Map Party (TestHydraClient Tx m))
-> RunMonad m (Map Party (TestHydraClient Tx m))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Nodes m -> Map Party (TestHydraClient Tx m)
forall (m :: * -> *). Nodes m -> Map Party (TestHydraClient Tx m)
nodes
  let thisNode :: TestHydraClient Tx m
thisNode = Map Party (TestHydraClient Tx m)
nodes Map Party (TestHydraClient Tx m) -> Party -> TestHydraClient Tx m
forall k a. Ord k => Map k a -> k -> a
! Party
party
  TestHydraClient Tx m -> RunMonad m ()
forall (m :: * -> *) tx.
MonadDelay m =>
TestHydraClient tx m -> RunMonad m ()
waitForOpen TestHydraClient Tx m
thisNode

  (TxIn
i, TxOut CtxUTxO
o) <-
    m (Either (UTxO Era) (TxIn, TxOut CtxUTxO))
-> RunMonad m (Either (UTxO Era) (TxIn, TxOut CtxUTxO))
forall (m :: * -> *) a. Monad m => m a -> RunMonad m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (UTxO Era
-> CardanoSigningKey
-> Value
-> TestHydraClient Tx m
-> m (Either (UTxO Era) (TxIn, TxOut CtxUTxO))
forall (m :: * -> *).
MonadDelay m =>
UTxO Era
-> CardanoSigningKey
-> Value
-> TestHydraClient Tx m
-> m (Either (UTxO Era) (TxIn, TxOut CtxUTxO))
waitForUTxOToSpend UTxO Era
forall a. Monoid a => a
mempty (Payment -> CardanoSigningKey
from Payment
tx) (Payment -> Value
value Payment
tx) TestHydraClient Tx m
thisNode) RunMonad m (Either (UTxO Era) (TxIn, TxOut CtxUTxO))
-> (Either (UTxO Era) (TxIn, TxOut CtxUTxO)
    -> RunMonad m (TxIn, TxOut CtxUTxO))
-> RunMonad m (TxIn, TxOut CtxUTxO)
forall a b. RunMonad m a -> (a -> RunMonad m b) -> RunMonad m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Left UTxO Era
u -> String -> RunMonad m (TxIn, TxOut CtxUTxO)
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure (String -> RunMonad m (TxIn, TxOut CtxUTxO))
-> String -> RunMonad m (TxIn, TxOut CtxUTxO)
forall a b. (a -> b) -> a -> b
$ String
"Cannot execute NewTx for " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Payment -> String
forall b a. (Show a, IsString b) => a -> b
show Payment
tx String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
", no spendable UTxO in " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> UTxO Era -> String
forall b a. (Show a, IsString b) => a -> b
show UTxO Era
u
      Right (TxIn, TxOut CtxUTxO)
ok -> (TxIn, TxOut CtxUTxO) -> RunMonad m (TxIn, TxOut CtxUTxO)
forall a. a -> RunMonad m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxIn, TxOut CtxUTxO)
ok

  let realTx :: Tx
realTx =
        (TxBodyError -> Tx) -> (Tx -> Tx) -> Either TxBodyError Tx -> Tx
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
          (Text -> Tx
forall a t. (HasCallStack, IsText t) => t -> a
error (Text -> Tx) -> (TxBodyError -> Text) -> TxBodyError -> Tx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxBodyError -> Text
forall b a. (Show a, IsString b) => a -> b
show)
          Tx -> Tx
forall a. a -> a
id
          (case Payment -> CardanoSigningKey
from Payment
tx of CardanoSigningKey Secret (SigningKey PaymentKey)
sk -> (TxIn, TxOut CtxUTxO)
-> (AddressInEra, Value)
-> Secret (SigningKey PaymentKey)
-> Either TxBodyError Tx
mkSimpleTx (TxIn
i, TxOut CtxUTxO
o) (AddressInEra
recipient, Payment -> Value
value Payment
tx) Secret (SigningKey PaymentKey)
sk)

  Party
party Party -> ClientInput Tx -> RunMonad m ()
forall (m :: * -> *).
(MonadSTM m, MonadThrow m, MonadDelay m) =>
Party -> ClientInput Tx -> RunMonad m ()
`sendsInput` Tx -> ClientInput Tx
forall tx. tx -> ClientInput tx
Input.NewTx Tx
realTx
  m () -> RunMonad m ()
forall (m :: * -> *) a. Monad m => m a -> RunMonad m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> RunMonad m ())
-> ((ServerOutput Tx -> Maybe ()) -> m ())
-> (ServerOutput Tx -> Maybe ())
-> RunMonad m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TestHydraClient Tx m] -> (ServerOutput Tx -> Maybe ()) -> m ()
forall tx (m :: * -> *) a.
(Show (ServerOutput tx), HasCallStack, MonadThrow m, MonadAsync m,
 MonadTimer m, MonadLabelledSTM m, Eq a, Show a, IsChainState tx) =>
[TestHydraClient tx m] -> (ServerOutput tx -> Maybe a) -> m a
waitUntilMatch (Map Party (TestHydraClient Tx m) -> [TestHydraClient Tx m]
forall t a b. (IsList t, Item t ~ (a, b)) => t -> [b]
elems Map Party (TestHydraClient Tx m)
nodes) ((ServerOutput Tx -> Maybe ()) -> RunMonad m ())
-> (ServerOutput Tx -> Maybe ()) -> RunMonad m ()
forall a b. (a -> b) -> a -> b
$ \case
    SnapshotConfirmed{$sel:snapshot:NetworkConnected :: forall tx. ServerOutput tx -> Snapshot tx
snapshot = Snapshot Tx
snapshot} ->
      Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Tx
realTx Tx -> [Tx] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` Snapshot Tx -> [Tx]
forall tx. Snapshot tx -> [tx]
Snapshot.confirmed Snapshot Tx
snapshot
    err :: ServerOutput Tx
err@(TxInvalid{}) -> Text -> Maybe ()
forall a t. (HasCallStack, IsText t) => t -> a
error (Text
"expected tx to be valid: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ServerOutput Tx -> Text
forall b a. (Show a, IsString b) => a -> b
show ServerOutput Tx
err)
    ServerOutput Tx
_ -> Maybe ()
forall a. Maybe a
Nothing
  Payment -> RunMonad m Payment
forall a. a -> RunMonad m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Payment
tx

-- | Wait for the head to be open by searching from the beginning. Note that
-- there rollbacks or multiple life-cycles of heads are not handled here.
waitForOpen :: MonadDelay m => TestHydraClient tx m -> RunMonad m ()
waitForOpen :: forall (m :: * -> *) tx.
MonadDelay m =>
TestHydraClient tx m -> RunMonad m ()
waitForOpen TestHydraClient tx m
node = do
  [ServerOutput tx]
outs <- m [ServerOutput tx] -> RunMonad m [ServerOutput tx]
forall (m :: * -> *) a. Monad m => m a -> RunMonad m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m [ServerOutput tx] -> RunMonad m [ServerOutput tx])
-> m [ServerOutput tx] -> RunMonad m [ServerOutput tx]
forall a b. (a -> b) -> a -> b
$ TestHydraClient tx m -> m [ServerOutput tx]
forall tx (m :: * -> *).
TestHydraClient tx m -> m [ServerOutput tx]
serverOutputs TestHydraClient tx m
node
  Bool -> RunMonad m () -> RunMonad m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ((ServerOutput tx -> Bool) -> [ServerOutput tx] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ServerOutput tx -> Bool
forall tx. ServerOutput tx -> Bool
headIsOpen [ServerOutput tx]
outs) RunMonad m ()
waitAndRetry
 where
  waitAndRetry :: RunMonad m ()
waitAndRetry = m () -> RunMonad m ()
forall (m :: * -> *) a. Monad m => m a -> RunMonad m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (DiffTime -> m ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
0.1) RunMonad m () -> RunMonad m () -> RunMonad m ()
forall a b. RunMonad m a -> RunMonad m b -> RunMonad m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TestHydraClient tx m -> RunMonad m ()
forall (m :: * -> *) tx.
MonadDelay m =>
TestHydraClient tx m -> RunMonad m ()
waitForOpen TestHydraClient tx m
node

-- | Wait for the head to be closed by searching from the beginning. Note that
-- there rollbacks or multiple life-cycles of heads are not handled here.
waitForReadyToFanout :: MonadDelay m => TestHydraClient tx m -> RunMonad m ()
waitForReadyToFanout :: forall (m :: * -> *) tx.
MonadDelay m =>
TestHydraClient tx m -> RunMonad m ()
waitForReadyToFanout TestHydraClient tx m
node = do
  [ServerOutput tx]
outs <- m [ServerOutput tx] -> RunMonad m [ServerOutput tx]
forall (m :: * -> *) a. Monad m => m a -> RunMonad m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m [ServerOutput tx] -> RunMonad m [ServerOutput tx])
-> m [ServerOutput tx] -> RunMonad m [ServerOutput tx]
forall a b. (a -> b) -> a -> b
$ TestHydraClient tx m -> m [ServerOutput tx]
forall tx (m :: * -> *).
TestHydraClient tx m -> m [ServerOutput tx]
serverOutputs TestHydraClient tx m
node
  Bool -> RunMonad m () -> RunMonad m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ((ServerOutput tx -> Bool) -> [ServerOutput tx] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ServerOutput tx -> Bool
forall tx. ServerOutput tx -> Bool
headIsReadyToFanout [ServerOutput tx]
outs) RunMonad m ()
waitAndRetry
 where
  waitAndRetry :: RunMonad m ()
waitAndRetry = m () -> RunMonad m ()
forall (m :: * -> *) a. Monad m => m a -> RunMonad m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (DiffTime -> m ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
0.1) RunMonad m () -> RunMonad m () -> RunMonad m ()
forall a b. RunMonad m a -> RunMonad m b -> RunMonad m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TestHydraClient tx m -> RunMonad m ()
forall (m :: * -> *) tx.
MonadDelay m =>
TestHydraClient tx m -> RunMonad m ()
waitForReadyToFanout TestHydraClient tx m
node

sendsInput :: forall m. (MonadSTM m, MonadThrow m, MonadDelay m) => Party -> ClientInput Tx -> RunMonad m ()
sendsInput :: forall (m :: * -> *).
(MonadSTM m, MonadThrow m, MonadDelay m) =>
Party -> ClientInput Tx -> RunMonad m ()
sendsInput Party
party ClientInput Tx
command = do
  TestHydraClient Tx m
actorNode <- Party -> RunMonad m (TestHydraClient Tx m)
forall (m :: * -> *).
(MonadSTM m, MonadThrow m) =>
Party -> RunMonad m (TestHydraClient Tx m)
getActorNode Party
party
  -- A node rejects client inputs while catching up (e.g. right after a
  -- rollback, until the next block restores its view). A real client sees
  -- 'RejectedInputBecauseUnsynced' and retries; we wait for sync upfront.
  TestHydraClient Tx m -> RunMonad m ()
waitForInSync TestHydraClient Tx m
actorNode
  m () -> RunMonad m ()
forall (m :: * -> *) a. Monad m => m a -> RunMonad m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> RunMonad m ()) -> m () -> RunMonad m ()
forall a b. (a -> b) -> a -> b
$ TestHydraClient Tx m
actorNode TestHydraClient Tx m -> ClientInput Tx -> m ()
forall tx (m :: * -> *).
TestHydraClient tx m -> ClientInput tx -> m ()
`send` ClientInput Tx
command
 where
  waitForInSync :: TestHydraClient Tx m -> RunMonad m ()
  waitForInSync :: TestHydraClient Tx m -> RunMonad m ()
waitForInSync TestHydraClient Tx m
node =
    m (NodeState Tx) -> RunMonad m (NodeState Tx)
forall (m :: * -> *) a. Monad m => m a -> RunMonad m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TestHydraClient Tx m -> m (NodeState Tx)
forall tx (m :: * -> *). TestHydraClient tx m -> m (NodeState tx)
queryState TestHydraClient Tx m
node) RunMonad m (NodeState Tx)
-> (NodeState Tx -> RunMonad m ()) -> RunMonad m ()
forall a b. RunMonad m a -> (a -> RunMonad m b) -> RunMonad m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      NodeInSync{} -> () -> RunMonad m ()
forall a. a -> RunMonad m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      NodeState Tx
_ -> m () -> RunMonad m ()
forall (m :: * -> *) a. Monad m => m a -> RunMonad m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (DiffTime -> m ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
1) RunMonad m () -> RunMonad m () -> RunMonad m ()
forall a b. RunMonad m a -> RunMonad m b -> RunMonad m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TestHydraClient Tx m -> RunMonad m ()
waitForInSync TestHydraClient Tx m
node

getActorNode :: (MonadSTM m, MonadThrow m) => Party -> RunMonad m (TestHydraClient Tx m)
getActorNode :: forall (m :: * -> *).
(MonadSTM m, MonadThrow m) =>
Party -> RunMonad m (TestHydraClient Tx m)
getActorNode Party
party = do
  Map Party (TestHydraClient Tx m)
nodes <- (Nodes m -> Map Party (TestHydraClient Tx m))
-> RunMonad m (Map Party (TestHydraClient Tx m))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Nodes m -> Map Party (TestHydraClient Tx m)
forall (m :: * -> *). Nodes m -> Map Party (TestHydraClient Tx m)
nodes
  case Party
-> Map Party (TestHydraClient Tx m) -> Maybe (TestHydraClient Tx m)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Party
party Map Party (TestHydraClient Tx m)
nodes of
    Maybe (TestHydraClient Tx m)
Nothing -> RunException -> RunMonad m (TestHydraClient Tx m)
forall e a. Exception e => e -> RunMonad m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (RunException -> RunMonad m (TestHydraClient Tx m))
-> RunException -> RunMonad m (TestHydraClient Tx m)
forall a b. (a -> b) -> a -> b
$ Party -> RunException
UnexpectedParty Party
party
    Just TestHydraClient Tx m
actorNode -> TestHydraClient Tx m -> RunMonad m (TestHydraClient Tx m)
forall a. a -> RunMonad m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TestHydraClient Tx m
actorNode

performInit :: (MonadThrow m, MonadAsync m, MonadTimer m, MonadDelay m, MonadLabelledSTM m) => Party -> RunMonad m HeadId
performInit :: forall (m :: * -> *).
(MonadThrow m, MonadAsync m, MonadTimer m, MonadDelay m,
 MonadLabelledSTM m) =>
Party -> RunMonad m HeadId
performInit Party
party = do
  Party
party Party -> ClientInput Tx -> RunMonad m ()
forall (m :: * -> *).
(MonadSTM m, MonadThrow m, MonadDelay m) =>
Party -> ClientInput Tx -> RunMonad m ()
`sendsInput` ClientInput Tx
forall tx. ClientInput tx
Input.Init
  Map Party (TestHydraClient Tx m)
nodes <- (Nodes m -> Map Party (TestHydraClient Tx m))
-> RunMonad m (Map Party (TestHydraClient Tx m))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Nodes m -> Map Party (TestHydraClient Tx m)
forall (m :: * -> *). Nodes m -> Map Party (TestHydraClient Tx m)
nodes
  m HeadId -> RunMonad m HeadId
forall (m :: * -> *) a. Monad m => m a -> RunMonad m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m HeadId -> RunMonad m HeadId)
-> ((ServerOutput Tx -> Maybe HeadId) -> m HeadId)
-> (ServerOutput Tx -> Maybe HeadId)
-> RunMonad m HeadId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TestHydraClient Tx m]
-> (ServerOutput Tx -> Maybe HeadId) -> m HeadId
forall tx (m :: * -> *) a.
(Show (ServerOutput tx), HasCallStack, MonadThrow m, MonadAsync m,
 MonadTimer m, MonadLabelledSTM m, Eq a, Show a, IsChainState tx) =>
[TestHydraClient tx m] -> (ServerOutput tx -> Maybe a) -> m a
waitUntilMatch (Map Party (TestHydraClient Tx m) -> [TestHydraClient Tx m]
forall t a b. (IsList t, Item t ~ (a, b)) => t -> [b]
elems Map Party (TestHydraClient Tx m)
nodes) ((ServerOutput Tx -> Maybe HeadId) -> RunMonad m HeadId)
-> (ServerOutput Tx -> Maybe HeadId) -> RunMonad m HeadId
forall a b. (a -> b) -> a -> b
$ \case
    HeadIsOpen{HeadId
headId :: HeadId
$sel:headId:NetworkConnected :: forall tx. ServerOutput tx -> HeadId
headId} -> HeadId -> Maybe HeadId
forall a. a -> Maybe a
Just HeadId
headId
    ServerOutput Tx
_ -> Maybe HeadId
forall a. Maybe a
Nothing

performClose :: forall m. (MonadThrow m, MonadDelay m, MonadLabelledSTM m) => Party -> RunMonad m ()
performClose :: forall (m :: * -> *).
(MonadThrow m, MonadDelay m, MonadLabelledSTM m) =>
Party -> RunMonad m ()
performClose Party
party = do
  Map Party (TestHydraClient Tx m)
nodes <- (Nodes m -> Map Party (TestHydraClient Tx m))
-> RunMonad m (Map Party (TestHydraClient Tx m))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Nodes m -> Map Party (TestHydraClient Tx m)
forall (m :: * -> *). Nodes m -> Map Party (TestHydraClient Tx m)
nodes
  let thisNode :: TestHydraClient Tx m
thisNode = Map Party (TestHydraClient Tx m)
nodes Map Party (TestHydraClient Tx m) -> Party -> TestHydraClient Tx m
forall k a. Ord k => Map k a -> k -> a
! Party
party
  TestHydraClient Tx m -> RunMonad m ()
forall (m :: * -> *) tx.
MonadDelay m =>
TestHydraClient tx m -> RunMonad m ()
waitForOpen TestHydraClient Tx m
thisNode
  -- A close posted while a settlement race is unresolved (e.g. the increment
  -- was observed on chain but its snapshot has not confirmed locally yet)
  -- fails on-chain and nothing in the node re-posts it: like a real client,
  -- retry until the head is closed. Success is detected by polling every
  -- node's head state for 'Closed' (not by matching a 'HeadIsClosed' server
  -- output, which 'waitUntilMatch' would consume — so a retry would then wait
  -- for a second one that never comes). Only (re-)send Close while this node's
  -- head is still open: once a close has landed, a slow (e.g. just-restarted)
  -- peer may still be catching up, and re-sending would yield a spurious
  -- CommandFailed on the already-closed head.
  let isClosed :: NodeState Tx -> Bool
      isClosed :: NodeState Tx -> Bool
isClosed NodeState Tx
st' = case NodeState Tx -> HeadState Tx
forall tx. NodeState tx -> HeadState tx
headState NodeState Tx
st' of
        HeadLogic.Closed{} -> Bool
True
        HeadState Tx
_ -> Bool
False
  let allClosed :: RunMonad m Bool
allClosed = m Bool -> RunMonad m Bool
forall (m :: * -> *) a. Monad m => m a -> RunMonad m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m Bool -> RunMonad m Bool) -> m Bool -> RunMonad m Bool
forall a b. (a -> b) -> a -> b
$ (NodeState Tx -> Bool) -> [NodeState Tx] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all NodeState Tx -> Bool
isClosed ([NodeState Tx] -> Bool) -> m [NodeState Tx] -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TestHydraClient Tx m -> m (NodeState Tx))
-> [TestHydraClient Tx m] -> m [NodeState Tx]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM TestHydraClient Tx m -> m (NodeState Tx)
forall tx (m :: * -> *). TestHydraClient tx m -> m (NodeState tx)
queryState (Map Party (TestHydraClient Tx m) -> [TestHydraClient Tx m]
forall t a b. (IsList t, Item t ~ (a, b)) => t -> [b]
elems Map Party (TestHydraClient Tx m)
nodes)
  let closeWithRetry :: Int -> RunMonad m ()
      closeWithRetry :: Int -> RunMonad m ()
closeWithRetry Int
n
        | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = String -> RunMonad m ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure String
"performClose: head not closed after retries"
        | Bool
otherwise = do
            Bool
thisClosed <- m Bool -> RunMonad m Bool
forall (m :: * -> *) a. Monad m => m a -> RunMonad m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m Bool -> RunMonad m Bool) -> m Bool -> RunMonad m Bool
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> (NodeState Tx -> Bool) -> NodeState Tx -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NodeState Tx -> Bool
isOpen (NodeState Tx -> Bool) -> m (NodeState Tx) -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TestHydraClient Tx m -> m (NodeState Tx)
forall tx (m :: * -> *). TestHydraClient tx m -> m (NodeState tx)
queryState TestHydraClient Tx m
thisNode
            Bool -> RunMonad m () -> RunMonad m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
thisClosed (RunMonad m () -> RunMonad m ()) -> RunMonad m () -> RunMonad m ()
forall a b. (a -> b) -> a -> b
$ Party
party Party -> ClientInput Tx -> RunMonad m ()
forall (m :: * -> *).
(MonadSTM m, MonadThrow m, MonadDelay m) =>
Party -> ClientInput Tx -> RunMonad m ()
`sendsInput` ClientInput Tx
forall tx. ClientInput tx
Input.Close
            -- Poll for all nodes closed, giving the chain time to observe it.
            let pollFor :: Int -> RunMonad m Bool
                pollFor :: Int -> RunMonad m Bool
pollFor Int
k
                  | Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = Bool -> RunMonad m Bool
forall a. a -> RunMonad m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
                  | Bool
otherwise =
                      RunMonad m Bool
allClosed RunMonad m Bool -> (Bool -> RunMonad m Bool) -> RunMonad m Bool
forall a b. RunMonad m a -> (a -> RunMonad m b) -> RunMonad m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                        Bool
True -> Bool -> RunMonad m Bool
forall a. a -> RunMonad m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
                        Bool
False -> m () -> RunMonad m ()
forall (m :: * -> *) a. Monad m => m a -> RunMonad m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (DiffTime -> m ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
1) RunMonad m () -> RunMonad m Bool -> RunMonad m Bool
forall a b. RunMonad m a -> RunMonad m b -> RunMonad m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> RunMonad m Bool
pollFor (Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
            Int -> RunMonad m Bool
pollFor Int
60 RunMonad m Bool -> (Bool -> RunMonad m ()) -> RunMonad m ()
forall a b. RunMonad m a -> (a -> RunMonad m b) -> RunMonad m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              Bool
True -> () -> RunMonad m ()
forall a. a -> RunMonad m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
              Bool
False -> Int -> RunMonad m ()
closeWithRetry (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
  -- Three attempts a minute apart: the race this covers resolves within a
  -- block or two, and a head that cannot close should fail fast.
  Int -> RunMonad m ()
closeWithRetry Int
3
 where
  isOpen :: NodeState Tx -> Bool
  isOpen :: NodeState Tx -> Bool
isOpen NodeState Tx
st' = case NodeState Tx -> HeadState Tx
forall tx. NodeState tx -> HeadState tx
headState NodeState Tx
st' of
    HeadLogic.Open{} -> Bool
True
    HeadState Tx
_ -> Bool
False

performFanout :: (MonadThrow m, MonadAsync m, MonadDelay m) => Party -> RunMonad m UTxO
performFanout :: forall (m :: * -> *).
(MonadThrow m, MonadAsync m, MonadDelay m) =>
Party -> RunMonad m (UTxO Era)
performFanout Party
party = do
  Party -> RunMonad m ()
forall (m :: * -> *).
(MonadSTM m, MonadThrow m, MonadDelay m) =>
Party -> RunMonad m ()
performStartFanout Party
party
  Party -> RunMonad m (UTxO Era)
forall (m :: * -> *).
(MonadSTM m, MonadThrow m, MonadDelay m) =>
Party -> RunMonad m (UTxO Era)
performObserveFanoutFinalized Party
party

-- | Send 'Fanout' once the head is ready for it, without waiting for the
-- fanout to complete.
performStartFanout :: (MonadSTM m, MonadThrow m, MonadDelay m) => Party -> RunMonad m ()
performStartFanout :: forall (m :: * -> *).
(MonadSTM m, MonadThrow m, MonadDelay m) =>
Party -> RunMonad m ()
performStartFanout Party
party = do
  Map Party (TestHydraClient Tx m)
nodes <- (Nodes m -> Map Party (TestHydraClient Tx m))
-> RunMonad m (Map Party (TestHydraClient Tx m))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Nodes m -> Map Party (TestHydraClient Tx m)
forall (m :: * -> *). Nodes m -> Map Party (TestHydraClient Tx m)
nodes
  TestHydraClient Tx m -> RunMonad m ()
forall (m :: * -> *) tx.
MonadDelay m =>
TestHydraClient tx m -> RunMonad m ()
waitForReadyToFanout (Map Party (TestHydraClient Tx m)
nodes Map Party (TestHydraClient Tx m) -> Party -> TestHydraClient Tx m
forall k a. Ord k => Map k a -> k -> a
! Party
party)
  Party
party Party -> ClientInput Tx -> RunMonad m ()
forall (m :: * -> *).
(MonadSTM m, MonadThrow m, MonadDelay m) =>
Party -> ClientInput Tx -> RunMonad m ()
`sendsInput` ClientInput Tx
forall tx. ClientInput tx
Input.Fanout

-- | Wait for the head to be finalized on the given party's node and return
-- what the fanout distributed.
performObserveFanoutFinalized :: (MonadSTM m, MonadThrow m, MonadDelay m) => Party -> RunMonad m UTxO
performObserveFanoutFinalized :: forall (m :: * -> *).
(MonadSTM m, MonadThrow m, MonadDelay m) =>
Party -> RunMonad m (UTxO Era)
performObserveFanoutFinalized Party
party = do
  Map Party (TestHydraClient Tx m)
nodes <- (Nodes m -> Map Party (TestHydraClient Tx m))
-> RunMonad m (Map Party (TestHydraClient Tx m))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Nodes m -> Map Party (TestHydraClient Tx m)
forall (m :: * -> *). Nodes m -> Map Party (TestHydraClient Tx m)
nodes
  -- A fanout may take several partial steps of one block (20s) each, so give
  -- it well over a handful of blocks.
  TestHydraClient Tx m -> Int -> RunMonad m (UTxO Era)
forall (m :: * -> *).
(MonadDelay m, MonadThrow m) =>
TestHydraClient Tx m -> Int -> RunMonad m (UTxO Era)
findInOutput (Map Party (TestHydraClient Tx m)
nodes Map Party (TestHydraClient Tx m) -> Party -> TestHydraClient Tx m
forall k a. Ord k => Map k a -> k -> a
! Party
party) (Int
600 :: Int)
 where
  findInOutput :: (MonadDelay m, MonadThrow m) => TestHydraClient Tx m -> Int -> RunMonad m UTxO
  findInOutput :: forall (m :: * -> *).
(MonadDelay m, MonadThrow m) =>
TestHydraClient Tx m -> Int -> RunMonad m (UTxO Era)
findInOutput TestHydraClient Tx m
node Int
n
    | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = String -> RunMonad m (UTxO Era)
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure String
"Failed to perform Fanout"
    | Bool
otherwise = do
        [ServerOutput Tx]
outputs <- m [ServerOutput Tx] -> RunMonad m [ServerOutput Tx]
forall (m :: * -> *) a. Monad m => m a -> RunMonad m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m [ServerOutput Tx] -> RunMonad m [ServerOutput Tx])
-> m [ServerOutput Tx] -> RunMonad m [ServerOutput Tx]
forall a b. (a -> b) -> a -> b
$ TestHydraClient Tx m -> m [ServerOutput Tx]
forall tx (m :: * -> *).
TestHydraClient tx m -> m [ServerOutput tx]
serverOutputs TestHydraClient Tx m
node
        case (ServerOutput Tx -> Bool)
-> [ServerOutput Tx] -> Maybe (ServerOutput Tx)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ServerOutput Tx -> Bool
headIsFinalized [ServerOutput Tx]
outputs of
          Just (HeadIsFinalized{UTxOType Tx
finalizedUTxO :: UTxOType Tx
$sel:finalizedUTxO:NetworkConnected :: forall tx. ServerOutput tx -> UTxOType tx
finalizedUTxO}) -> UTxO Era -> RunMonad m (UTxO Era)
forall a. a -> RunMonad m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure UTxOType Tx
UTxO Era
finalizedUTxO
          Maybe (ServerOutput Tx)
_ -> m () -> RunMonad m ()
forall (m :: * -> *) a. Monad m => m a -> RunMonad m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (DiffTime -> m ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
1) RunMonad m () -> RunMonad m (UTxO Era) -> RunMonad m (UTxO Era)
forall a b. RunMonad m a -> RunMonad m b -> RunMonad m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TestHydraClient Tx m -> Int -> RunMonad m (UTxO Era)
forall (m :: * -> *).
(MonadDelay m, MonadThrow m) =>
TestHydraClient Tx m -> Int -> RunMonad m (UTxO Era)
findInOutput TestHydraClient Tx m
node (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)

  headIsFinalized :: ServerOutput Tx -> Bool
  headIsFinalized :: ServerOutput Tx -> Bool
headIsFinalized = \case
    HeadIsFinalized{} -> Bool
True
    ServerOutput Tx
_otherwise -> Bool
False

-- | Hand the node a selection to fan out (manual mode) and wait until every
-- node reports all of it distributed: over one or more partial steps, or by
-- the final fanout if the selection drains the head.
performPartialFanoutStep :: (MonadThrow m, MonadTimer m, MonadDelay m) => Party -> UTxOType Payment -> RunMonad m ()
performPartialFanoutStep :: forall (m :: * -> *).
(MonadThrow m, MonadTimer m, MonadDelay m) =>
Party -> UTxOType Payment -> RunMonad m ()
performPartialFanoutStep Party
party UTxOType Payment
selection = do
  Map Party (TestHydraClient Tx m)
nodes <- (Nodes m -> Map Party (TestHydraClient Tx m))
-> RunMonad m (Map Party (TestHydraClient Tx m))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Nodes m -> Map Party (TestHydraClient Tx m)
forall (m :: * -> *). Nodes m -> Map Party (TestHydraClient Tx m)
nodes
  TestHydraClient Tx m -> RunMonad m ()
forall (m :: * -> *) tx.
MonadDelay m =>
TestHydraClient tx m -> RunMonad m ()
waitForReadyToFanout (Map Party (TestHydraClient Tx m)
nodes Map Party (TestHydraClient Tx m) -> Party -> TestHydraClient Tx m
forall k a. Ord k => Map k a -> k -> a
! Party
party)
  Party
party Party -> ClientInput Tx -> RunMonad m ()
forall (m :: * -> *).
(MonadSTM m, MonadThrow m, MonadDelay m) =>
Party -> ClientInput Tx -> RunMonad m ()
`sendsInput` Input.PartialFanout{$sel:utxoToFanout:Init :: UTxOType Tx
utxoToFanout = UTxOType Payment -> UTxOType Tx
toRealUTxO UTxOType Payment
selection}
  let expected :: [TxOut CtxUTxO]
expected = [TxOut CtxUTxO] -> [TxOut CtxUTxO]
forall ctx. [TxOut ctx] -> [TxOut ctx]
sortTxOuts ([(CardanoSigningKey, Value)] -> [TxOut CtxUTxO]
toTxOuts [(CardanoSigningKey, Value)]
UTxOType Payment
selection)
      distributedSoFar :: [ServerOutput Tx] -> [TxOut CtxUTxO]
      distributedSoFar :: [ServerOutput Tx] -> [TxOut CtxUTxO]
distributedSoFar [ServerOutput Tx]
outs =
        [[TxOut CtxUTxO]] -> [TxOut CtxUTxO]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
          [ UTxO Era -> [TxOut CtxUTxO]
forall era. UTxO era -> [TxOut CtxUTxO era]
UTxO.txOutputs UTxO Era
u
          | ServerOutput Tx
out <- [ServerOutput Tx]
outs
          , UTxO Era
u <- case ServerOutput Tx
out of
              HeadPartiallyFannedOut{UTxOType Tx
$sel:distributedUTxO:NetworkConnected :: forall tx. ServerOutput tx -> UTxOType tx
distributedUTxO :: UTxOType Tx
distributedUTxO} -> [UTxOType Tx
UTxO Era
distributedUTxO]
              HeadIsFinalized{UTxOType Tx
$sel:finalizedUTxO:NetworkConnected :: forall tx. ServerOutput tx -> UTxOType tx
finalizedUTxO :: UTxOType Tx
finalizedUTxO} -> [UTxOType Tx
UTxO Era
finalizedUTxO]
              ServerOutput Tx
_ -> []
          ]
  m () -> RunMonad m ()
forall (m :: * -> *) a. Monad m => m a -> RunMonad m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> RunMonad m ())
-> (([ServerOutput Tx] -> Bool) -> m ())
-> ([ServerOutput Tx] -> Bool)
-> RunMonad m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String
-> [TestHydraClient Tx m] -> ([ServerOutput Tx] -> Bool) -> m ()
forall (m :: * -> *).
(MonadThrow m, MonadTimer m, MonadDelay m) =>
String
-> [TestHydraClient Tx m] -> ([ServerOutput Tx] -> Bool) -> m ()
waitUntilHistory (String
"partial fanout of " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall b a. (Show a, IsString b) => a -> b
show ([(CardanoSigningKey, Value)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(CardanoSigningKey, Value)]
UTxOType Payment
selection) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" outputs") (Map Party (TestHydraClient Tx m) -> [TestHydraClient Tx m]
forall t a b. (IsList t, Item t ~ (a, b)) => t -> [b]
elems Map Party (TestHydraClient Tx m)
nodes) (([ServerOutput Tx] -> Bool) -> RunMonad m ())
-> ([ServerOutput Tx] -> Bool) -> RunMonad m ()
forall a b. (a -> b) -> a -> b
$ \[ServerOutput Tx]
outs ->
    [TxOut CtxUTxO] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([TxOut CtxUTxO]
expected [TxOut CtxUTxO] -> [TxOut CtxUTxO] -> [TxOut CtxUTxO]
forall a. Eq a => [a] -> [a] -> [a]
\\ [TxOut CtxUTxO] -> [TxOut CtxUTxO]
forall ctx. [TxOut ctx] -> [TxOut ctx]
sortTxOuts ([ServerOutput Tx] -> [TxOut CtxUTxO]
distributedSoFar [ServerOutput Tx]
outs))

-- | Wait until every node has reported at least @n@ partial fanout steps.
performObservePartialFanoutSteps :: (MonadThrow m, MonadTimer m, MonadDelay m) => Int -> RunMonad m ()
performObservePartialFanoutSteps :: forall (m :: * -> *).
(MonadThrow m, MonadTimer m, MonadDelay m) =>
Int -> RunMonad m ()
performObservePartialFanoutSteps Int
n = do
  Map Party (TestHydraClient Tx m)
nodes <- (Nodes m -> Map Party (TestHydraClient Tx m))
-> RunMonad m (Map Party (TestHydraClient Tx m))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Nodes m -> Map Party (TestHydraClient Tx m)
forall (m :: * -> *). Nodes m -> Map Party (TestHydraClient Tx m)
nodes
  m () -> RunMonad m ()
forall (m :: * -> *) a. Monad m => m a -> RunMonad m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> RunMonad m ())
-> ((ServerOutput Tx -> Bool) -> m ())
-> (ServerOutput Tx -> Bool)
-> RunMonad m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String
-> Int
-> [TestHydraClient Tx m]
-> (ServerOutput Tx -> Bool)
-> m ()
forall (m :: * -> *).
(MonadThrow m, MonadTimer m, MonadDelay m) =>
String
-> Int
-> [TestHydraClient Tx m]
-> (ServerOutput Tx -> Bool)
-> m ()
waitForOutputs (Int -> String
forall b a. (Show a, IsString b) => a -> b
show Int
n String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" partial fanout steps") Int
n (Map Party (TestHydraClient Tx m) -> [TestHydraClient Tx m]
forall t a b. (IsList t, Item t ~ (a, b)) => t -> [b]
elems Map Party (TestHydraClient Tx m)
nodes) ((ServerOutput Tx -> Bool) -> RunMonad m ())
-> (ServerOutput Tx -> Bool) -> RunMonad m ()
forall a b. (a -> b) -> a -> b
$ \case
    HeadPartiallyFannedOut{} -> Bool
True
    ServerOutput Tx
_ -> Bool
False

performCloseWithInitialSnapshot :: (MonadThrow m, MonadTimer m, MonadDelay m, MonadAsync m, MonadLabelledSTM m) => WorldState -> Party -> RunMonad m ()
performCloseWithInitialSnapshot :: forall (m :: * -> *).
(MonadThrow m, MonadTimer m, MonadDelay m, MonadAsync m,
 MonadLabelledSTM m) =>
WorldState -> Party -> RunMonad m ()
performCloseWithInitialSnapshot WorldState
st Party
party = do
  Map Party (TestHydraClient Tx m)
nodes <- (Nodes m -> Map Party (TestHydraClient Tx m))
-> RunMonad m (Map Party (TestHydraClient Tx m))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Nodes m -> Map Party (TestHydraClient Tx m)
forall (m :: * -> *). Nodes m -> Map Party (TestHydraClient Tx m)
nodes
  let thisNode :: TestHydraClient Tx m
thisNode = Map Party (TestHydraClient Tx m)
nodes Map Party (TestHydraClient Tx m) -> Party -> TestHydraClient Tx m
forall k a. Ord k => Map k a -> k -> a
! Party
party
  TestHydraClient Tx m -> RunMonad m ()
forall (m :: * -> *) tx.
MonadDelay m =>
TestHydraClient tx m -> RunMonad m ()
waitForOpen TestHydraClient Tx m
thisNode
  case WorldState -> GlobalState
hydraState WorldState
st of
    Open{} -> do
      SimulatedChainNetwork{Party -> m ()
closeWithInitialSnapshot :: Party -> m ()
$sel:closeWithInitialSnapshot:SimulatedChainNetwork :: forall tx (m :: * -> *).
SimulatedChainNetwork tx m -> Party -> m ()
closeWithInitialSnapshot} <- (Nodes m -> SimulatedChainNetwork Tx m)
-> RunMonad m (SimulatedChainNetwork Tx m)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Nodes m -> SimulatedChainNetwork Tx m
forall (m :: * -> *). Nodes m -> SimulatedChainNetwork Tx m
chain
      m () -> RunMonad m ()
forall (m :: * -> *) a. Monad m => m a -> RunMonad m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> RunMonad m ()) -> m () -> RunMonad m ()
forall a b. (a -> b) -> a -> b
$ do
        ()
_ <- Party -> m ()
closeWithInitialSnapshot Party
party
        [TestHydraClient Tx m] -> (ServerOutput Tx -> Maybe ()) -> m ()
forall tx (m :: * -> *) a.
(Show (ServerOutput tx), HasCallStack, MonadThrow m, MonadAsync m,
 MonadTimer m, MonadLabelledSTM m, Eq a, Show a, IsChainState tx) =>
[TestHydraClient tx m] -> (ServerOutput tx -> Maybe a) -> m a
waitUntilMatch (Map Party (TestHydraClient Tx m) -> [TestHydraClient Tx m]
forall t a b. (IsList t, Item t ~ (a, b)) => t -> [b]
elems Map Party (TestHydraClient Tx m)
nodes) ((ServerOutput Tx -> Maybe ()) -> m ())
-> (ServerOutput Tx -> Maybe ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \case
          HeadIsClosed{SnapshotNumber
snapshotNumber :: SnapshotNumber
$sel:snapshotNumber:NetworkConnected :: forall tx. ServerOutput tx -> SnapshotNumber
snapshotNumber} ->
            -- we deliberately wait to see close with the initial snapshot
            -- here to mimic one node not seeing the confirmed tx
            Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ SnapshotNumber
snapshotNumber SnapshotNumber -> SnapshotNumber -> Bool
forall a. Eq a => a -> a -> Bool
== Natural -> SnapshotNumber
Snapshot.UnsafeSnapshotNumber Natural
0
          ServerOutput Tx
_ -> Maybe ()
forall a. Maybe a
Nothing
    GlobalState
_ -> Text -> RunMonad m ()
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"Not in open state"

performRollbackAndForward :: (MonadThrow m, MonadTimer m) => Natural -> RunMonad m ()
performRollbackAndForward :: forall (m :: * -> *).
(MonadThrow m, MonadTimer m) =>
Natural -> RunMonad m ()
performRollbackAndForward Natural
numberOfBlocks = do
  SimulatedChainNetwork{Natural -> m ()
rollbackAndForward :: Natural -> m ()
$sel:rollbackAndForward:SimulatedChainNetwork :: forall tx (m :: * -> *).
SimulatedChainNetwork tx m -> Natural -> m ()
rollbackAndForward} <- (Nodes m -> SimulatedChainNetwork Tx m)
-> RunMonad m (SimulatedChainNetwork Tx m)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Nodes m -> SimulatedChainNetwork Tx m
forall (m :: * -> *). Nodes m -> SimulatedChainNetwork Tx m
chain
  m () -> RunMonad m ()
forall (m :: * -> *) a. Monad m => m a -> RunMonad m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> RunMonad m ()) -> m () -> RunMonad m ()
forall a b. (a -> b) -> a -> b
$ Natural -> m ()
rollbackAndForward Natural
numberOfBlocks

performRollbackAndFork :: (MonadThrow m, MonadTimer m) => Natural -> RequeueMode -> RunMonad m ()
performRollbackAndFork :: forall (m :: * -> *).
(MonadThrow m, MonadTimer m) =>
Natural -> RequeueMode -> RunMonad m ()
performRollbackAndFork Natural
numberOfBlocks RequeueMode
requeueErased = do
  SimulatedChainNetwork{Natural -> RequeueMode -> m ()
rollbackAndFork :: Natural -> RequeueMode -> m ()
$sel:rollbackAndFork:SimulatedChainNetwork :: forall tx (m :: * -> *).
SimulatedChainNetwork tx m -> Natural -> RequeueMode -> m ()
rollbackAndFork} <- (Nodes m -> SimulatedChainNetwork Tx m)
-> RunMonad m (SimulatedChainNetwork Tx m)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Nodes m -> SimulatedChainNetwork Tx m
forall (m :: * -> *). Nodes m -> SimulatedChainNetwork Tx m
chain
  m () -> RunMonad m ()
forall (m :: * -> *) a. Monad m => m a -> RunMonad m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> RunMonad m ()) -> m () -> RunMonad m ()
forall a b. (a -> b) -> a -> b
$ Natural -> RequeueMode -> m ()
rollbackAndFork Natural
numberOfBlocks RequeueMode
requeueErased

-- | Crash a node (cancelling its main thread, so any in-flight inputs and
-- in-memory-only state are lost) and start it again from its own event store,
-- re-syncing the chain from genesis. Models a node operator restart /
-- fail-recovery under load: the head must stay live through it.
performRestartNode ::
  ( MonadAsync m
  , MonadLabelledSTM m
  , MonadFork m
  , MonadMask m
  , MonadDelay m
  , MonadTime m
  ) =>
  WorldState ->
  Party ->
  RunMonad m ()
performRestartNode :: forall (m :: * -> *).
(MonadAsync m, MonadLabelledSTM m, MonadFork m, MonadMask m,
 MonadDelay m, MonadTime m) =>
WorldState -> Party -> RunMonad m ()
performRestartNode WorldState
st Party
party = do
  Tracer m (HydraLog Tx)
tr <- (Nodes m -> Tracer m (HydraLog Tx))
-> RunMonad m (Tracer m (HydraLog Tx))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Nodes m -> Tracer m (HydraLog Tx)
forall (m :: * -> *). Nodes m -> Tracer m (HydraLog Tx)
logger
  SimulatedChainNetwork Tx m
mockChain <- (Nodes m -> SimulatedChainNetwork Tx m)
-> RunMonad m (SimulatedChainNetwork Tx m)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Nodes m -> SimulatedChainNetwork Tx m
forall (m :: * -> *). Nodes m -> SimulatedChainNetwork Tx m
chain
  Map Party (EventStore (StateEvent Tx) m, m [StateEvent Tx])
stores <- (Nodes m
 -> Map Party (EventStore (StateEvent Tx) m, m [StateEvent Tx]))
-> RunMonad
     m (Map Party (EventStore (StateEvent Tx) m, m [StateEvent Tx]))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Nodes m
-> Map Party (EventStore (StateEvent Tx) m, m [StateEvent Tx])
forall (m :: * -> *).
Nodes m
-> Map Party (EventStore (StateEvent Tx) m, m [StateEvent Tx])
eventStores
  Map Party (Async m ())
threadsByParty <- (Nodes m -> Map Party (Async m ()))
-> RunMonad m (Map Party (Async m ()))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Nodes m -> Map Party (Async m ())
forall (m :: * -> *). Nodes m -> Map Party (Async m ())
nodeThreads
  case (Party
-> Map Party (EventStore (StateEvent Tx) m, m [StateEvent Tx])
-> Maybe (EventStore (StateEvent Tx) m, m [StateEvent Tx])
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Party
party Map Party (EventStore (StateEvent Tx) m, m [StateEvent Tx])
stores, Party -> Map Party (Async m ()) -> Maybe (Async m ())
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Party
party Map Party (Async m ())
threadsByParty, Maybe (Secret (SigningKey HydraKey))
findHsk) of
    (Just (EventStore (StateEvent Tx) m, m [StateEvent Tx])
eventStore, Just Async m ()
oldThread, Just Secret (SigningKey HydraKey)
hsk) -> do
      -- Crash the node: cancel the main thread; the event store survives.
      m () -> RunMonad m ()
forall (m :: * -> *) a. Monad m => m a -> RunMonad m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> RunMonad m ()) -> m () -> RunMonad m ()
forall a b. (a -> b) -> a -> b
$ Async m () -> m ()
forall a. Async m a -> m ()
forall (m :: * -> *) a. MonadAsync m => Async m a -> m ()
cancel Async m ()
oldThread
      let otherParties :: [Party]
otherParties = (Party -> Bool) -> [Party] -> [Party]
forall a. (a -> Bool) -> [a] -> [a]
filter (Party -> Party -> Bool
forall a. Eq a => a -> a -> Bool
/= Party
party) [Party]
allParties
      (TestHydraClient Tx m
testClient, Async m ()
newThread) <- Tracer m (HydraLog Tx)
-> SimulatedChainNetwork Tx m
-> ContestationPeriod
-> (EventStore (StateEvent Tx) m, m [StateEvent Tx])
-> Secret (SigningKey HydraKey)
-> [Party]
-> RunMonad m (TestHydraClient Tx m, Async m ())
forall (m :: * -> *).
(MonadAsync m, MonadLabelledSTM m, MonadFork m, MonadDelay m,
 MonadMask m, MonadTime m) =>
Tracer m (HydraLog Tx)
-> SimulatedChainNetwork Tx m
-> ContestationPeriod
-> (EventStore (StateEvent Tx) m, m [StateEvent Tx])
-> Secret (SigningKey HydraKey)
-> [Party]
-> RunMonad m (TestHydraClient Tx m, Async m ())
startNode Tracer m (HydraLog Tx)
tr SimulatedChainNetwork Tx m
mockChain ContestationPeriod
seedCP (EventStore (StateEvent Tx) m, m [StateEvent Tx])
eventStore Secret (SigningKey HydraKey)
hsk [Party]
otherParties
      (Nodes m -> Nodes m) -> RunMonad m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Nodes m -> Nodes m) -> RunMonad m ())
-> (Nodes m -> Nodes m) -> RunMonad m ()
forall a b. (a -> b) -> a -> b
$ \Nodes m
n ->
        Nodes m
n
          { nodes = Map.insert party testClient (nodes n)
          , nodeThreads = Map.insert party newThread (nodeThreads n)
          , threads = newThread : threads n
          }
    (Maybe (EventStore (StateEvent Tx) m, m [StateEvent Tx]),
 Maybe (Async m ()), Maybe (Secret (SigningKey HydraKey)))
_ -> () -> RunMonad m ()
forall a. a -> RunMonad m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
 where
  WorldState{[(Secret (SigningKey HydraKey), CardanoSigningKey)]
$sel:hydraParties:WorldState :: WorldState -> [(Secret (SigningKey HydraKey), CardanoSigningKey)]
hydraParties :: [(Secret (SigningKey HydraKey), CardanoSigningKey)]
hydraParties} = WorldState
st
  allParties :: [Party]
allParties = Secret (SigningKey HydraKey) -> Party
deriveParty (Secret (SigningKey HydraKey) -> Party)
-> ((Secret (SigningKey HydraKey), CardanoSigningKey)
    -> Secret (SigningKey HydraKey))
-> (Secret (SigningKey HydraKey), CardanoSigningKey)
-> Party
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Secret (SigningKey HydraKey), CardanoSigningKey)
-> Secret (SigningKey HydraKey)
forall a b. (a, b) -> a
fst ((Secret (SigningKey HydraKey), CardanoSigningKey) -> Party)
-> [(Secret (SigningKey HydraKey), CardanoSigningKey)] -> [Party]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Secret (SigningKey HydraKey), CardanoSigningKey)]
hydraParties
  findHsk :: Maybe (Secret (SigningKey HydraKey))
findHsk = (Secret (SigningKey HydraKey), CardanoSigningKey)
-> Secret (SigningKey HydraKey)
forall a b. (a, b) -> a
fst ((Secret (SigningKey HydraKey), CardanoSigningKey)
 -> Secret (SigningKey HydraKey))
-> Maybe (Secret (SigningKey HydraKey), CardanoSigningKey)
-> Maybe (Secret (SigningKey HydraKey))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Secret (SigningKey HydraKey), CardanoSigningKey) -> Bool)
-> [(Secret (SigningKey HydraKey), CardanoSigningKey)]
-> Maybe (Secret (SigningKey HydraKey), CardanoSigningKey)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((Party -> Party -> Bool
forall a. Eq a => a -> a -> Bool
== Party
party) (Party -> Bool)
-> ((Secret (SigningKey HydraKey), CardanoSigningKey) -> Party)
-> (Secret (SigningKey HydraKey), CardanoSigningKey)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Secret (SigningKey HydraKey) -> Party
deriveParty (Secret (SigningKey HydraKey) -> Party)
-> ((Secret (SigningKey HydraKey), CardanoSigningKey)
    -> Secret (SigningKey HydraKey))
-> (Secret (SigningKey HydraKey), CardanoSigningKey)
-> Party
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Secret (SigningKey HydraKey), CardanoSigningKey)
-> Secret (SigningKey HydraKey)
forall a b. (a, b) -> a
fst) [(Secret (SigningKey HydraKey), CardanoSigningKey)]
hydraParties
  seedCP :: ContestationPeriod
seedCP = case WorldState -> GlobalState
hydraState WorldState
st of
    Open{$sel:headParameters:Start :: GlobalState -> HeadParameters
headParameters = HeadParameters{ContestationPeriod
$sel:contestationPeriod:HeadParameters :: HeadParameters -> ContestationPeriod
contestationPeriod :: ContestationPeriod
contestationPeriod}} -> ContestationPeriod
contestationPeriod
    GlobalState
_ -> ContestationPeriod
defaultContestationPeriod

stopTheWorld :: MonadAsync m => RunMonad m ()
stopTheWorld :: forall (m :: * -> *). MonadAsync m => RunMonad m ()
stopTheWorld =
  (Nodes m -> [Async m ()]) -> RunMonad m [Async m ()]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Nodes m -> [Async m ()]
forall (m :: * -> *). Nodes m -> [Async m ()]
threads RunMonad m [Async m ()]
-> ([Async m ()] -> RunMonad m ()) -> RunMonad m ()
forall a b. RunMonad m a -> (a -> RunMonad m b) -> RunMonad m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Async m () -> RunMonad m ()) -> [Async m ()] -> RunMonad m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (m () -> RunMonad m ()
forall (m :: * -> *) a. Monad m => m a -> RunMonad m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> RunMonad m ())
-> (Async m () -> m ()) -> Async m () -> RunMonad m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Async m () -> m ()
forall a. Async m a -> m ()
forall (m :: * -> *) a. MonadAsync m => Async m a -> m ()
cancel)

-- ** Utility functions

-- | Convert payment-style utxos into transaction outputs.
toTxOuts :: [(CardanoSigningKey, Value)] -> [TxOut CtxUTxO]
toTxOuts :: [(CardanoSigningKey, Value)] -> [TxOut CtxUTxO]
toTxOuts [(CardanoSigningKey, Value)]
payments =
  (CardanoSigningKey -> Value -> TxOut CtxUTxO)
-> (CardanoSigningKey, Value) -> TxOut CtxUTxO
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry CardanoSigningKey -> Value -> TxOut CtxUTxO
mkTxOut ((CardanoSigningKey, Value) -> TxOut CtxUTxO)
-> [(CardanoSigningKey, Value)] -> [TxOut CtxUTxO]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(CardanoSigningKey, Value)]
payments

-- | Convert payment-style utxos into real utxos. The 'Payment' tx domain is
-- smaller than UTxO and we map every unique signer + value entry to a mocked
-- 'TxIn' on the real cardano domain.
toRealUTxO :: UTxOType Payment -> UTxOType Tx
toRealUTxO :: UTxOType Payment -> UTxOType Tx
toRealUTxO UTxOType Payment
paymentUTxO =
  [(TxIn, TxOut CtxUTxO)] -> UTxO Era
forall era. [(TxIn, TxOut CtxUTxO era)] -> UTxO era
UTxO.fromList ([(TxIn, TxOut CtxUTxO)] -> UTxO Era)
-> [(TxIn, TxOut CtxUTxO)] -> UTxO Era
forall a b. (a -> b) -> a -> b
$
    [ (CardanoSigningKey -> Word -> TxIn
mkMockTxIn CardanoSigningKey
sk Word
ix, CardanoSigningKey -> Value -> TxOut CtxUTxO
mkTxOut CardanoSigningKey
sk Value
val)
    | (CardanoSigningKey
sk, [Value]
vals) <- Map CardanoSigningKey [Value] -> [(CardanoSigningKey, [Value])]
forall k a. Map k a -> [(k, a)]
Map.toList Map CardanoSigningKey [Value]
skMap
    , (Word
ix, Value
val) <- [Word] -> [Value] -> [(Word, Value)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Word
0 ..] [Value]
vals
    ]
 where
  skMap :: Map CardanoSigningKey [Value]
skMap = ([Value] -> [Value] -> [Value])
-> [(CardanoSigningKey, [Value])] -> Map CardanoSigningKey [Value]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [Value] -> [Value] -> [Value]
forall a. [a] -> [a] -> [a]
(++) ([(CardanoSigningKey, [Value])] -> Map CardanoSigningKey [Value])
-> [(CardanoSigningKey, [Value])] -> Map CardanoSigningKey [Value]
forall a b. (a -> b) -> a -> b
$ ((CardanoSigningKey, Value) -> (CardanoSigningKey, [Value]))
-> [(CardanoSigningKey, Value)] -> [(CardanoSigningKey, [Value])]
forall a b. (a -> b) -> [a] -> [b]
map (\(CardanoSigningKey
sk, Value
v) -> (CardanoSigningKey
sk, [Value
v])) [(CardanoSigningKey, Value)]
UTxOType Payment
paymentUTxO

mkTxOut :: CardanoSigningKey -> Value -> TxOut CtxUTxO
mkTxOut :: CardanoSigningKey -> Value -> TxOut CtxUTxO
mkTxOut (CardanoSigningKey Secret (SigningKey PaymentKey)
sk) Value
val =
  AddressInEra
-> Value -> TxOutDatum CtxUTxO -> ReferenceScript -> TxOut CtxUTxO
forall ctx.
AddressInEra
-> Value -> TxOutDatum ctx -> ReferenceScript -> TxOut ctx
TxOut (NetworkId -> VerificationKey PaymentKey -> AddressInEra
forall era.
IsShelleyBasedEra era =>
NetworkId -> VerificationKey PaymentKey -> AddressInEra era
mkVkAddress NetworkId
testNetworkId (Secret (SigningKey PaymentKey) -> VerificationKey PaymentKey
forall s k. HasVerificationKey s k => s -> VerificationKey k
getVerificationKey Secret (SigningKey PaymentKey)
sk)) Value
val TxOutDatum CtxUTxO
forall ctx. TxOutDatum ctx
TxOutDatumNone ReferenceScript
ReferenceScriptNone

mkMockTxIn :: CardanoSigningKey -> Word -> TxIn
mkMockTxIn :: CardanoSigningKey -> Word -> TxIn
mkMockTxIn (CardanoSigningKey Secret (SigningKey PaymentKey)
sk) Word
ix =
  TxId -> TxIx -> TxIn
TxIn (Hash HASH EraIndependentTxBody -> TxId
TxId Hash HASH EraIndependentTxBody
tid) (Word -> TxIx
TxIx Word
ix)
 where
  vk :: VerificationKey PaymentKey
vk = Secret (SigningKey PaymentKey) -> VerificationKey PaymentKey
forall s k. HasVerificationKey s k => s -> VerificationKey k
getVerificationKey Secret (SigningKey PaymentKey)
sk
  -- NOTE: Ugly, works because both binary representations are 32-byte long.
  tid :: Hash HASH EraIndependentTxBody
tid = ByteString -> Hash HASH EraIndependentTxBody
forall a. FromCBOR a => ByteString -> a
unsafeDeserialize' (VerificationKey PaymentKey -> ByteString
forall a. ToCBOR a => a -> ByteString
serialize' VerificationKey PaymentKey
vk)

waitForUTxOToSpend ::
  forall m.
  MonadDelay m =>
  UTxO ->
  CardanoSigningKey ->
  Value ->
  TestHydraClient Tx m ->
  m (Either UTxO (TxIn, TxOut CtxUTxO))
waitForUTxOToSpend :: forall (m :: * -> *).
MonadDelay m =>
UTxO Era
-> CardanoSigningKey
-> Value
-> TestHydraClient Tx m
-> m (Either (UTxO Era) (TxIn, TxOut CtxUTxO))
waitForUTxOToSpend UTxO Era
utxo CardanoSigningKey
key Value
value TestHydraClient Tx m
node = UTxO Era -> Int -> m (Either (UTxO Era) (TxIn, TxOut CtxUTxO))
go UTxO Era
utxo Int
100
 where
  -- Reports the head UTxO as last seen when giving up, not the caller's
  -- initial one, so a missing output can be told from an empty head.
  go :: UTxO -> Int -> m (Either UTxO (TxIn, TxOut CtxUTxO))
  go :: UTxO Era -> Int -> m (Either (UTxO Era) (TxIn, TxOut CtxUTxO))
go UTxO Era
lastSeen = \case
    Int
0 ->
      Either (UTxO Era) (TxIn, TxOut CtxUTxO)
-> m (Either (UTxO Era) (TxIn, TxOut CtxUTxO))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (UTxO Era) (TxIn, TxOut CtxUTxO)
 -> m (Either (UTxO Era) (TxIn, TxOut CtxUTxO)))
-> Either (UTxO Era) (TxIn, TxOut CtxUTxO)
-> m (Either (UTxO Era) (TxIn, TxOut CtxUTxO))
forall a b. (a -> b) -> a -> b
$ UTxO Era -> Either (UTxO Era) (TxIn, TxOut CtxUTxO)
forall a b. a -> Either a b
Left UTxO Era
lastSeen
    Int
n -> do
      UTxO Era
u <- TestHydraClient Tx m -> m (UTxOType Tx)
forall tx (m :: * -> *).
(IsTx tx, MonadDelay m) =>
TestHydraClient tx m -> m (UTxOType tx)
headUTxO TestHydraClient Tx m
node
      if UTxO Era
u UTxO Era -> UTxO Era -> Bool
forall a. Eq a => a -> a -> Bool
/= UTxO Era
forall a. Monoid a => a
mempty
        then case ((TxIn, TxOut CtxUTxO) -> Bool)
-> [(TxIn, TxOut CtxUTxO)] -> Maybe (TxIn, TxOut CtxUTxO)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (TxIn, TxOut CtxUTxO) -> Bool
matchPayment (UTxO Era -> [(TxIn, TxOut CtxUTxO)]
forall era. UTxO era -> [(TxIn, TxOut CtxUTxO era)]
UTxO.toList UTxO Era
u) of
          Maybe (TxIn, TxOut CtxUTxO)
Nothing -> UTxO Era -> Int -> m (Either (UTxO Era) (TxIn, TxOut CtxUTxO))
go UTxO Era
u (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
          Just (TxIn
txIn, TxOut CtxUTxO
txOut) -> Either (UTxO Era) (TxIn, TxOut CtxUTxO)
-> m (Either (UTxO Era) (TxIn, TxOut CtxUTxO))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (UTxO Era) (TxIn, TxOut CtxUTxO)
 -> m (Either (UTxO Era) (TxIn, TxOut CtxUTxO)))
-> Either (UTxO Era) (TxIn, TxOut CtxUTxO)
-> m (Either (UTxO Era) (TxIn, TxOut CtxUTxO))
forall a b. (a -> b) -> a -> b
$ (TxIn, TxOut CtxUTxO) -> Either (UTxO Era) (TxIn, TxOut CtxUTxO)
forall a b. b -> Either a b
Right (TxIn
txIn, TxOut CtxUTxO
txOut)
        else UTxO Era -> Int -> m (Either (UTxO Era) (TxIn, TxOut CtxUTxO))
go UTxO Era
u (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)

  matchPayment :: (TxIn, TxOut CtxUTxO) -> Bool
matchPayment p :: (TxIn, TxOut CtxUTxO)
p@(TxIn
_, TxOut CtxUTxO
txOut) =
    CardanoSigningKey -> (TxIn, TxOut CtxUTxO) -> Bool
forall ctx. CardanoSigningKey -> (TxIn, TxOut ctx) -> Bool
isOwned CardanoSigningKey
key (TxIn, TxOut CtxUTxO)
p Bool -> Bool -> Bool
&& Value
value Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== TxOut CtxUTxO -> Value
forall ctx. TxOut ctx -> Value
txOutValue TxOut CtxUTxO
txOut

headUTxO ::
  (IsTx tx, MonadDelay m) =>
  TestHydraClient tx m ->
  m (UTxOType tx)
headUTxO :: forall tx (m :: * -> *).
(IsTx tx, MonadDelay m) =>
TestHydraClient tx m -> m (UTxOType tx)
headUTxO TestHydraClient tx m
node = do
  UTxOType tx -> Maybe (UTxOType tx) -> UTxOType tx
forall a. a -> Maybe a -> a
fromMaybe UTxOType tx
forall a. Monoid a => a
mempty (Maybe (UTxOType tx) -> UTxOType tx)
-> (NodeState tx -> Maybe (UTxOType tx))
-> NodeState tx
-> UTxOType tx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeadState tx -> Maybe (UTxOType tx)
forall tx. HeadState tx -> Maybe (UTxOType tx)
getHeadUTxO (HeadState tx -> Maybe (UTxOType tx))
-> (NodeState tx -> HeadState tx)
-> NodeState tx
-> Maybe (UTxOType tx)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NodeState tx -> HeadState tx
forall tx. NodeState tx -> HeadState tx
headState (NodeState tx -> UTxOType tx)
-> m (NodeState tx) -> m (UTxOType tx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TestHydraClient tx m -> m (NodeState tx)
forall tx (m :: * -> *). TestHydraClient tx m -> m (NodeState tx)
queryState TestHydraClient tx m
node

isOwned :: CardanoSigningKey -> (TxIn, TxOut ctx) -> Bool
isOwned :: forall ctx. CardanoSigningKey -> (TxIn, TxOut ctx) -> Bool
isOwned (CardanoSigningKey Secret (SigningKey PaymentKey)
sk) (TxIn
_, TxOut{txOutAddress :: forall ctx. TxOut ctx -> AddressInEra
txOutAddress = ShelleyAddressInEra (ShelleyAddress Network
_ Credential Payment
cre StakeReference
_)}) =
  case Credential Payment -> PaymentCredential
fromShelleyPaymentCredential Credential Payment
cre of
    (PaymentCredentialByKey Hash PaymentKey
ha) -> VerificationKey PaymentKey -> Hash PaymentKey
forall keyrole.
Key keyrole =>
VerificationKey keyrole -> Hash keyrole
verificationKeyHash (Secret (SigningKey PaymentKey) -> VerificationKey PaymentKey
forall s k. HasVerificationKey s k => s -> VerificationKey k
getVerificationKey Secret (SigningKey PaymentKey)
sk) Hash PaymentKey -> Hash PaymentKey -> Bool
forall a. Eq a => a -> a -> Bool
== Hash PaymentKey
ha
    PaymentCredential
_ -> Bool
False
isOwned CardanoSigningKey
_ (TxIn, TxOut ctx)
_ = Bool
False

headIsOpen :: ServerOutput tx -> Bool
headIsOpen :: forall tx. ServerOutput tx -> Bool
headIsOpen = \case
  HeadIsOpen{} -> Bool
True
  ServerOutput tx
_otherwise -> Bool
False

headIsReadyToFanout :: ServerOutput tx -> Bool
headIsReadyToFanout :: forall tx. ServerOutput tx -> Bool
headIsReadyToFanout = \case
  ReadyToFanout{} -> Bool
True
  ServerOutput tx
_otherwise -> Bool
False