{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}

-- | 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 (utxoFromTx)
import Hydra.Prelude hiding (Any, label, lookup)

import Cardano.Api.UTxO (pairs)
import Cardano.Api.UTxO qualified as UTxO
import Cardano.Binary (serialize', unsafeDeserialize')
import Control.Concurrent.Class.MonadSTM (
  MonadLabelledSTM,
  labelTQueueIO,
  labelTVarIO,
  modifyTVar,
  newTQueue,
  newTVarIO,
  readTVarIO,
 )
import Control.Monad.Class.MonadAsync (Async, async, cancel, link)
import Control.Monad.Class.MonadFork (labelThisThread)
import Data.List (nub)
import Data.List qualified as List
import Data.Map ((!))
import Data.Map qualified as Map
import Data.Maybe (fromJust)
import Data.Set qualified as Set
import GHC.Natural (wordToNatural)
import Hydra.API.ClientInput (ClientInput)
import Hydra.API.ClientInput qualified as Input
import Hydra.API.ServerOutput (ServerOutput (..))
import Hydra.BehaviorSpec (
  SimulatedChainNetwork (..),
  TestHydraClient (..),
  createHydraNode,
  createTestHydraClient,
  shortLabel,
  waitMatch,
  waitUntilMatch,
 )
import Hydra.Cardano.Api.Prelude (fromShelleyPaymentCredential)
import Hydra.Chain (maximumNumberOfParties)
import Hydra.Chain.Direct.State (initialChainState)
import Hydra.HeadLogic (Committed ())
import Hydra.Ledger.Cardano (cardanoLedger, mkSimpleTx)
import Hydra.Logging (Tracer)
import Hydra.Logging.Messages (HydraLog (DirectChain, Node))
import Hydra.Model.MockChain (mockChainAndNetwork)
import Hydra.Model.Payment (CardanoSigningKey (..), Payment (..), applyTx, genAdaValue)
import Hydra.Node (runHydraNode)
import Hydra.Tx.ContestationPeriod (ContestationPeriod (UnsafeContestationPeriod))
import Hydra.Tx.Crypto (HydraKey)
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.Prelude (failure)
import Test.Hydra.Tx.Gen (genSigningKey)
import Test.QuickCheck (choose, elements, frequency, oneof, resize, sized, 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 -> [(SigningKey HydraKey, CardanoSigningKey)]
hydraParties :: [(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.
  }
  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
idleContestationPeriod :: ContestationPeriod
      , GlobalState -> Uncommitted
toCommit :: Uncommitted
      }
  | Initial
      { GlobalState -> HeadParameters
headParameters :: HeadParameters
      , GlobalState -> Uncommitted
commits :: Committed Payment
      , GlobalState -> Uncommitted
pendingCommits :: Uncommitted
      }
  | Open
      { headParameters :: HeadParameters
      , GlobalState -> OffChainState
offChainState :: OffChainState
      , GlobalState -> Uncommitted
committed :: Committed Payment
      }
  | Closed
      { headParameters :: HeadParameters
      , GlobalState -> UTxOType Payment
closedUTxO :: UTxOType Payment
      }
  | Final {GlobalState -> UTxOType Payment
finalUTxO :: UTxOType Payment}
  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)

isPendingCommitFrom :: Party -> GlobalState -> Bool
isPendingCommitFrom :: Party -> GlobalState -> Bool
isPendingCommitFrom Party
party Initial{Uncommitted
$sel:pendingCommits:Start :: GlobalState -> Uncommitted
pendingCommits :: Uncommitted
pendingCommits} =
  Party
party Party -> Map Party [(CardanoSigningKey, Value)] -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Map Party [(CardanoSigningKey, Value)]
Uncommitted
pendingCommits
isPendingCommitFrom Party
_ GlobalState
_ = Bool
False

type Uncommitted = Map.Map Party (UTxOType Payment)

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)

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

type ActualCommitted = UTxOType Payment

-- | 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 () -> [(SigningKey HydraKey, CardanoSigningKey)]
seedKeys :: [(SigningKey HydraKey, CardanoSigningKey)]
      , Action WorldState () -> ContestationPeriod
seedContestationPeriod :: ContestationPeriod
      , Action WorldState () -> Uncommitted
toCommit :: Uncommitted
      } ->
      Action WorldState ()
    -- NOTE: No records possible here as we would duplicate 'Party' fields with
    -- different return values.
    Init :: Party -> Action WorldState ()
    Commit :: Party -> UTxOType Payment -> Action WorldState ActualCommitted
    Decommit :: Party -> Payment -> Action WorldState ()
    Abort :: Party -> Action WorldState ()
    Close :: Party -> Action WorldState ()
    Fanout :: 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 ()
    CloseWithInitialSnapshot :: Party -> Action WorldState ()
    StopTheWorld :: Action WorldState ()

  initialState :: WorldState
initialState =
    WorldState
      { $sel:hydraParties:WorldState :: [(SigningKey HydraKey, CardanoSigningKey)]
hydraParties = [(SigningKey HydraKey, CardanoSigningKey)]
forall a. Monoid a => a
mempty
      , $sel:hydraState:WorldState :: GlobalState
hydraState = GlobalState
Start
      }

  arbitraryAction :: VarContext -> WorldState -> Gen (Any (Action WorldState))
  arbitraryAction :: VarContext -> WorldState -> Gen (Any (Action WorldState))
arbitraryAction VarContext
_ st :: WorldState
st@WorldState{[(SigningKey HydraKey, CardanoSigningKey)]
$sel:hydraParties:WorldState :: WorldState -> [(SigningKey HydraKey, CardanoSigningKey)]
hydraParties :: [(SigningKey HydraKey, CardanoSigningKey)]
hydraParties, GlobalState
$sel:hydraState:WorldState :: WorldState -> GlobalState
hydraState :: GlobalState
hydraState} =
    case GlobalState
hydraState of
      GlobalState
Start -> (Action WorldState () -> Any (Action WorldState))
-> Gen (Action WorldState ()) -> Gen (Any (Action WorldState))
forall a b. (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Action WorldState () -> Any (Action WorldState)
forall a (f :: * -> *). (Typeable a, Eq (f a)) => f a -> Any f
Some Gen (Action WorldState ())
genSeed
      Idle{} -> 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
<$> [(SigningKey HydraKey, CardanoSigningKey)]
-> Gen (Action WorldState ())
forall b. [(SigningKey HydraKey, b)] -> Gen (Action WorldState ())
genInit [(SigningKey HydraKey, CardanoSigningKey)]
hydraParties
      Initial{Uncommitted
$sel:pendingCommits:Start :: GlobalState -> Uncommitted
pendingCommits :: Uncommitted
pendingCommits} ->
        [(Int, Gen (Any (Action WorldState)))]
-> Gen (Any (Action WorldState))
forall a. [(Int, Gen a)] -> Gen a
frequency
          [ (Int
5, Uncommitted -> Gen (Any (Action WorldState))
genCommit Uncommitted
pendingCommits)
          , (Int
1, Gen (Any (Action WorldState))
genAbort)
          ]
      Open{$sel:offChainState:Start :: GlobalState -> OffChainState
offChainState = OffChainState{UTxOType Payment
$sel:confirmedUTxO:OffChainState :: OffChainState -> UTxOType Payment
confirmedUTxO :: UTxOType Payment
confirmedUTxO}} ->
        UTxOType Payment -> Gen (Any (Action WorldState))
genOpenActions UTxOType Payment
confirmedUTxO
      Closed{} ->
        [(Int, Gen (Any (Action WorldState)))]
-> Gen (Any (Action WorldState))
forall a. [(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))
-> Gen (Action WorldState ()) -> Gen (Any (Action WorldState))
forall a b. (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Action WorldState () -> Any (Action WorldState)
forall a (f :: * -> *). (Typeable a, Eq (f a)) => f a -> Any f
Some Gen (Action WorldState ())
genSeed
   where
    genCommit :: Uncommitted -> Gen (Any (Action WorldState))
    genCommit :: Uncommitted -> Gen (Any (Action WorldState))
genCommit Uncommitted
pending = do
      (Party
party, [(CardanoSigningKey, Value)]
commits) <- [(Party, [(CardanoSigningKey, Value)])]
-> Gen (Party, [(CardanoSigningKey, Value)])
forall a. [a] -> Gen a
elements ([(Party, [(CardanoSigningKey, Value)])]
 -> Gen (Party, [(CardanoSigningKey, Value)]))
-> [(Party, [(CardanoSigningKey, Value)])]
-> Gen (Party, [(CardanoSigningKey, Value)])
forall a b. (a -> b) -> a -> b
$ Map Party [(CardanoSigningKey, Value)]
-> [(Party, [(CardanoSigningKey, Value)])]
forall k a. Map k a -> [(k, a)]
Map.toList Map Party [(CardanoSigningKey, Value)]
Uncommitted
pending
      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 (UTxOType Payment)
    -> Any (Action WorldState))
-> Action WorldState (UTxOType Payment)
-> Gen (Any (Action WorldState))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Action WorldState [(CardanoSigningKey, Value)]
-> Any (Action WorldState)
Action WorldState (UTxOType Payment) -> Any (Action WorldState)
forall a (f :: * -> *). (Typeable a, Eq (f a)) => f a -> Any f
Some (Action WorldState (UTxOType Payment)
 -> Gen (Any (Action WorldState)))
-> Action WorldState (UTxOType Payment)
-> Gen (Any (Action WorldState))
forall a b. (a -> b) -> a -> b
$ Party -> UTxOType Payment -> Action WorldState (UTxOType Payment)
Commit Party
party [(CardanoSigningKey, Value)]
UTxOType Payment
commits

    -- 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 :: UTxOType Payment -> Gen (Any (Action WorldState))
    genOpenActions :: UTxOType Payment -> Gen (Any (Action WorldState))
genOpenActions UTxOType Payment
confirmedUTxO =
      if [(CardanoSigningKey, Value)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(CardanoSigningKey, Value)]
UTxOType Payment
confirmedUTxO
        then
          [Gen (Any (Action WorldState))] -> Gen (Any (Action WorldState))
forall a. [Gen a] -> Gen a
oneof
            [ Gen (Any (Action WorldState))
genClose
            , Gen (Any (Action WorldState))
genRollbackAndForward
            ]
        else
          [(Int, Gen (Any (Action WorldState)))]
-> Gen (Any (Action WorldState))
forall a. [(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
10, Gen (Any (Action WorldState))
genNewTx)
            , (Int
1, Gen (Any (Action WorldState))
genClose)
            , (Int
1, Gen (Any (Action WorldState))
genRollbackAndForward)
            ]
              [(Int, Gen (Any (Action WorldState)))]
-> [(Int, Gen (Any (Action WorldState)))]
-> [(Int, Gen (Any (Action WorldState)))]
forall a. Semigroup a => a -> a -> a
<> [(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)]
UTxOType Payment
confirmedUTxO Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1]

    genDecommit :: Gen (Any (Action WorldState))
    genDecommit :: Gen (Any (Action WorldState))
genDecommit = do
      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

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

    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))
-> ((SigningKey HydraKey, CardanoSigningKey)
    -> Action WorldState ())
-> (SigningKey HydraKey, CardanoSigningKey)
-> Any (Action WorldState)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Party -> Action WorldState ()
Close (Party -> Action WorldState ())
-> ((SigningKey HydraKey, CardanoSigningKey) -> Party)
-> (SigningKey HydraKey, CardanoSigningKey)
-> Action WorldState ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SigningKey HydraKey -> Party
deriveParty (SigningKey HydraKey -> Party)
-> ((SigningKey HydraKey, CardanoSigningKey)
    -> SigningKey HydraKey)
-> (SigningKey HydraKey, CardanoSigningKey)
-> Party
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SigningKey HydraKey, CardanoSigningKey) -> SigningKey HydraKey
forall a b. (a, b) -> a
fst ((SigningKey HydraKey, CardanoSigningKey)
 -> Any (Action WorldState))
-> Gen (SigningKey HydraKey, CardanoSigningKey)
-> Gen (Any (Action WorldState))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(SigningKey HydraKey, CardanoSigningKey)]
-> Gen (SigningKey HydraKey, CardanoSigningKey)
forall a. [a] -> Gen a
elements [(SigningKey HydraKey, CardanoSigningKey)]
hydraParties

    genFanout :: Gen (Any (Action WorldState))
genFanout =
      Action WorldState (UTxO' (TxOut CtxUTxO Era))
-> Any (Action WorldState)
forall a (f :: * -> *). (Typeable a, Eq (f a)) => f a -> Any f
Some (Action WorldState (UTxO' (TxOut CtxUTxO Era))
 -> Any (Action WorldState))
-> ((SigningKey HydraKey, CardanoSigningKey)
    -> Action WorldState (UTxO' (TxOut CtxUTxO Era)))
-> (SigningKey HydraKey, CardanoSigningKey)
-> Any (Action WorldState)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Party -> Action WorldState (UTxO' (TxOut CtxUTxO Era))
Fanout (Party -> Action WorldState (UTxO' (TxOut CtxUTxO Era)))
-> ((SigningKey HydraKey, CardanoSigningKey) -> Party)
-> (SigningKey HydraKey, CardanoSigningKey)
-> Action WorldState (UTxO' (TxOut CtxUTxO Era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SigningKey HydraKey -> Party
deriveParty (SigningKey HydraKey -> Party)
-> ((SigningKey HydraKey, CardanoSigningKey)
    -> SigningKey HydraKey)
-> (SigningKey HydraKey, CardanoSigningKey)
-> Party
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SigningKey HydraKey, CardanoSigningKey) -> SigningKey HydraKey
forall a b. (a, b) -> a
fst ((SigningKey HydraKey, CardanoSigningKey)
 -> Any (Action WorldState))
-> Gen (SigningKey HydraKey, CardanoSigningKey)
-> Gen (Any (Action WorldState))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(SigningKey HydraKey, CardanoSigningKey)]
-> Gen (SigningKey HydraKey, CardanoSigningKey)
forall a. [a] -> Gen a
elements [(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)

  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 = Initial{Uncommitted
$sel:pendingCommits:Start :: GlobalState -> Uncommitted
pendingCommits :: Uncommitted
pendingCommits}} (Commit Party
party UTxOType Payment
_) =
    Party
party Party -> Map Party [(CardanoSigningKey, Value)] -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Map Party [(CardanoSigningKey, Value)]
Uncommitted
pendingCommits
  precondition WorldState{$sel:hydraState:WorldState :: WorldState -> GlobalState
hydraState = Initial{Uncommitted
$sel:commits:Start :: GlobalState -> Uncommitted
commits :: Uncommitted
commits, Uncommitted
$sel:pendingCommits:Start :: GlobalState -> Uncommitted
pendingCommits :: Uncommitted
pendingCommits}} (Abort Party
party) =
    Party
party Party -> Set Party -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` (Map Party [(CardanoSigningKey, Value)] -> Set Party
forall k a. Map k a -> Set k
Map.keysSet Map Party [(CardanoSigningKey, Value)]
Uncommitted
pendingCommits Set Party -> Set Party -> Set Party
forall a. Semigroup a => a -> a -> a
<> Map Party [(CardanoSigningKey, Value)] -> Set Party
forall k a. Map k a -> Set k
Map.keysSet Map Party [(CardanoSigningKey, Value)]
Uncommitted
commits)
  precondition WorldState{$sel:hydraState:WorldState :: WorldState -> GlobalState
hydraState = Open{}} (Close Party
_) =
    Bool
True
  precondition WorldState{$sel:hydraState:WorldState :: WorldState -> GlobalState
hydraState = Open{OffChainState
$sel:offChainState:Start :: GlobalState -> OffChainState
offChainState :: OffChainState
offChainState}} (NewTx Party
_ Payment
tx) =
    (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{OffChainState
$sel:offChainState:Start :: GlobalState -> OffChainState
offChainState :: OffChainState
offChainState}} (Decommit Party
_ Payment
tx) =
    (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{$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{}} (Fanout Party
_) =
    Bool
True
  precondition WorldState{$sel:hydraState:WorldState :: WorldState -> GlobalState
hydraState = Open{}} (CloseWithInitialSnapshot Party
_) =
    Bool
True
  precondition WorldState{GlobalState
$sel:hydraState:WorldState :: WorldState -> GlobalState
hydraState :: GlobalState
hydraState} (RollbackAndForward Natural
_) =
    case GlobalState
hydraState of
      Start{} -> Bool
False
      Idle{} -> Bool
False
      Initial{} -> 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{[(SigningKey HydraKey, CardanoSigningKey)]
$sel:hydraParties:WorldState :: WorldState -> [(SigningKey HydraKey, CardanoSigningKey)]
hydraParties :: [(SigningKey HydraKey, CardanoSigningKey)]
hydraParties, GlobalState
$sel:hydraState:WorldState :: WorldState -> GlobalState
hydraState :: GlobalState
hydraState} Action WorldState a
a Var a
_var =
    case Action WorldState a
a of
      Seed{[(SigningKey HydraKey, CardanoSigningKey)]
$sel:seedKeys:Seed :: Action WorldState () -> [(SigningKey HydraKey, CardanoSigningKey)]
seedKeys :: [(SigningKey HydraKey, CardanoSigningKey)]
seedKeys, ContestationPeriod
$sel:seedContestationPeriod:Seed :: Action WorldState () -> ContestationPeriod
seedContestationPeriod :: ContestationPeriod
seedContestationPeriod, Uncommitted
$sel:toCommit:Seed :: Action WorldState () -> Uncommitted
toCommit :: Uncommitted
toCommit} ->
        WorldState{$sel:hydraParties:WorldState :: [(SigningKey HydraKey, CardanoSigningKey)]
hydraParties = [(SigningKey HydraKey, CardanoSigningKey)]
seedKeys, $sel:hydraState:WorldState :: GlobalState
hydraState = GlobalState
idleState}
       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:idleContestationPeriod:Start :: ContestationPeriod
idleContestationPeriod :: ContestationPeriod
idleContestationPeriod, Uncommitted
$sel:toCommit:Start :: Uncommitted
toCommit :: Uncommitted
toCommit}
        idleParties :: [Party]
idleParties = ((SigningKey HydraKey, CardanoSigningKey) -> Party)
-> [(SigningKey HydraKey, CardanoSigningKey)] -> [Party]
forall a b. (a -> b) -> [a] -> [b]
map (SigningKey HydraKey -> Party
deriveParty (SigningKey HydraKey -> Party)
-> ((SigningKey HydraKey, CardanoSigningKey)
    -> SigningKey HydraKey)
-> (SigningKey HydraKey, CardanoSigningKey)
-> Party
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SigningKey HydraKey, CardanoSigningKey) -> SigningKey HydraKey
forall a b. (a, b) -> a
fst) [(SigningKey HydraKey, CardanoSigningKey)]
seedKeys
        cardanoKeys :: [VerificationKey PaymentKey]
cardanoKeys = ((SigningKey HydraKey, CardanoSigningKey)
 -> VerificationKey PaymentKey)
-> [(SigningKey HydraKey, CardanoSigningKey)]
-> [VerificationKey PaymentKey]
forall a b. (a -> b) -> [a] -> [b]
map (SigningKey PaymentKey -> VerificationKey PaymentKey
forall keyrole.
(Key keyrole, HasTypeProxy keyrole) =>
SigningKey keyrole -> VerificationKey keyrole
getVerificationKey (SigningKey PaymentKey -> VerificationKey PaymentKey)
-> ((SigningKey HydraKey, CardanoSigningKey)
    -> SigningKey PaymentKey)
-> (SigningKey HydraKey, CardanoSigningKey)
-> VerificationKey PaymentKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CardanoSigningKey -> SigningKey PaymentKey
signingKey (CardanoSigningKey -> SigningKey PaymentKey)
-> ((SigningKey HydraKey, CardanoSigningKey) -> CardanoSigningKey)
-> (SigningKey HydraKey, CardanoSigningKey)
-> SigningKey PaymentKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SigningKey HydraKey, CardanoSigningKey) -> CardanoSigningKey
forall a b. (a, b) -> b
snd) [(SigningKey HydraKey, CardanoSigningKey)]
seedKeys
        idleContestationPeriod :: ContestationPeriod
idleContestationPeriod = ContestationPeriod
seedContestationPeriod
      --
      Init{} ->
        WorldState{[(SigningKey HydraKey, CardanoSigningKey)]
$sel:hydraParties:WorldState :: [(SigningKey HydraKey, CardanoSigningKey)]
hydraParties :: [(SigningKey HydraKey, CardanoSigningKey)]
hydraParties, $sel:hydraState:WorldState :: GlobalState
hydraState = GlobalState -> GlobalState
mkInitialState GlobalState
hydraState}
       where
        mkInitialState :: GlobalState -> GlobalState
mkInitialState = \case
          Idle{[Party]
$sel:idleParties:Start :: GlobalState -> [Party]
idleParties :: [Party]
idleParties, ContestationPeriod
$sel:idleContestationPeriod:Start :: GlobalState -> ContestationPeriod
idleContestationPeriod :: ContestationPeriod
idleContestationPeriod, Uncommitted
$sel:toCommit:Start :: GlobalState -> Uncommitted
toCommit :: Uncommitted
toCommit} ->
            Initial
              { $sel:headParameters:Start :: HeadParameters
headParameters =
                  HeadParameters
                    { $sel:parties:HeadParameters :: [Party]
parties = [Party]
idleParties
                    , $sel:contestationPeriod:HeadParameters :: ContestationPeriod
contestationPeriod = ContestationPeriod
idleContestationPeriod
                    }
              , $sel:commits:Start :: Uncommitted
commits = Map Party [(CardanoSigningKey, Value)]
Uncommitted
forall a. Monoid a => a
mempty
              , $sel:pendingCommits:Start :: Uncommitted
pendingCommits = Uncommitted
toCommit
              }
          GlobalState
_ -> Text -> GlobalState
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"unexpected state"
      Decommit Party
_party Payment
tx ->
        WorldState{[(SigningKey HydraKey, CardanoSigningKey)]
$sel:hydraParties:WorldState :: [(SigningKey HydraKey, CardanoSigningKey)]
hydraParties :: [(SigningKey HydraKey, CardanoSigningKey)]
hydraParties, $sel:hydraState:WorldState :: GlobalState
hydraState = GlobalState -> GlobalState
updateWithDecommit GlobalState
hydraState}
       where
        updateWithDecommit :: GlobalState -> GlobalState
updateWithDecommit = \case
          Open{HeadParameters
$sel:headParameters:Start :: GlobalState -> HeadParameters
headParameters :: HeadParameters
headParameters, Uncommitted
$sel:committed:Start :: GlobalState -> Uncommitted
committed :: Uncommitted
committed, $sel:offChainState:Start :: GlobalState -> OffChainState
offChainState = OffChainState{UTxOType Payment
$sel:confirmedUTxO:OffChainState :: OffChainState -> UTxOType Payment
confirmedUTxO :: UTxOType Payment
confirmedUTxO}} ->
            Open
              { HeadParameters
$sel:headParameters:Start :: HeadParameters
headParameters :: HeadParameters
headParameters
              , Uncommitted
$sel:committed:Start :: Uncommitted
committed :: Uncommitted
committed
              , $sel:offChainState:Start :: OffChainState
offChainState =
                  OffChainState
                    { $sel:confirmedUTxO:OffChainState :: UTxOType Payment
confirmedUTxO =
                        (CardanoSigningKey, Value)
-> [(CardanoSigningKey, Value)] -> [(CardanoSigningKey, Value)]
forall a. Eq a => a -> [a] -> [a]
List.delete (Payment -> CardanoSigningKey
from Payment
tx, Payment -> Value
value Payment
tx) [(CardanoSigningKey, Value)]
UTxOType Payment
confirmedUTxO
                    }
              }
          GlobalState
_ -> Text -> GlobalState
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"unexpected state"
      --
      Commit Party
party UTxOType Payment
utxo ->
        WorldState{[(SigningKey HydraKey, CardanoSigningKey)]
$sel:hydraParties:WorldState :: [(SigningKey HydraKey, CardanoSigningKey)]
hydraParties :: [(SigningKey HydraKey, CardanoSigningKey)]
hydraParties, $sel:hydraState:WorldState :: GlobalState
hydraState = GlobalState -> GlobalState
updateWithCommit GlobalState
hydraState}
       where
        updateWithCommit :: GlobalState -> GlobalState
updateWithCommit = \case
          Initial{HeadParameters
$sel:headParameters:Start :: GlobalState -> HeadParameters
headParameters :: HeadParameters
headParameters, Uncommitted
$sel:commits:Start :: GlobalState -> Uncommitted
commits :: Uncommitted
commits, Uncommitted
$sel:pendingCommits:Start :: GlobalState -> Uncommitted
pendingCommits :: Uncommitted
pendingCommits} -> GlobalState
updatedState
           where
            commits' :: Map Party [(CardanoSigningKey, Value)]
commits' = Party
-> [(CardanoSigningKey, Value)]
-> Map Party [(CardanoSigningKey, Value)]
-> Map Party [(CardanoSigningKey, Value)]
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Party
party [(CardanoSigningKey, Value)]
UTxOType Payment
utxo Map Party [(CardanoSigningKey, Value)]
Uncommitted
commits
            pendingCommits' :: Map Party [(CardanoSigningKey, Value)]
pendingCommits' = Party
party Party
-> Map Party [(CardanoSigningKey, Value)]
-> Map Party [(CardanoSigningKey, Value)]
forall k a. Ord k => k -> Map k a -> Map k a
`Map.delete` Map Party [(CardanoSigningKey, Value)]
Uncommitted
pendingCommits
            updatedState :: GlobalState
updatedState =
              if Map Party [(CardanoSigningKey, Value)] -> Bool
forall a. Map Party a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Map Party [(CardanoSigningKey, Value)]
pendingCommits'
                then
                  Open
                    { HeadParameters
$sel:headParameters:Start :: HeadParameters
headParameters :: HeadParameters
headParameters
                    , $sel:committed:Start :: Uncommitted
committed = Map Party [(CardanoSigningKey, Value)]
Uncommitted
commits'
                    , $sel:offChainState:Start :: OffChainState
offChainState =
                        OffChainState
                          { $sel:confirmedUTxO:OffChainState :: UTxOType Payment
confirmedUTxO = [[(CardanoSigningKey, Value)]] -> [(CardanoSigningKey, Value)]
forall a. Monoid a => [a] -> a
mconcat (Map Party [(CardanoSigningKey, Value)]
-> [[(CardanoSigningKey, Value)]]
forall k a. Map k a -> [a]
Map.elems Map Party [(CardanoSigningKey, Value)]
commits')
                          }
                    }
                else
                  Initial
                    { HeadParameters
$sel:headParameters:Start :: HeadParameters
headParameters :: HeadParameters
headParameters
                    , $sel:commits:Start :: Uncommitted
commits = Map Party [(CardanoSigningKey, Value)]
Uncommitted
commits'
                    , $sel:pendingCommits:Start :: Uncommitted
pendingCommits = Map Party [(CardanoSigningKey, Value)]
Uncommitted
pendingCommits'
                    }
          GlobalState
_ -> Text -> GlobalState
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"unexpected state"
      --
      Abort{} ->
        WorldState{[(SigningKey HydraKey, CardanoSigningKey)]
$sel:hydraParties:WorldState :: [(SigningKey HydraKey, CardanoSigningKey)]
hydraParties :: [(SigningKey HydraKey, CardanoSigningKey)]
hydraParties, $sel:hydraState:WorldState :: GlobalState
hydraState = GlobalState -> GlobalState
updateWithAbort GlobalState
hydraState}
       where
        updateWithAbort :: GlobalState -> GlobalState
updateWithAbort = \case
          Initial{Uncommitted
$sel:commits:Start :: GlobalState -> Uncommitted
commits :: Uncommitted
commits} -> UTxOType Payment -> GlobalState
Final [(CardanoSigningKey, Value)]
UTxOType Payment
committedUTxO
           where
            committedUTxO :: [(CardanoSigningKey, Value)]
committedUTxO = [[(CardanoSigningKey, Value)]] -> [(CardanoSigningKey, Value)]
forall a. Monoid a => [a] -> a
mconcat ([[(CardanoSigningKey, Value)]] -> [(CardanoSigningKey, Value)])
-> [[(CardanoSigningKey, Value)]] -> [(CardanoSigningKey, Value)]
forall a b. (a -> b) -> a -> b
$ Map Party [(CardanoSigningKey, Value)]
-> [[(CardanoSigningKey, Value)]]
forall k a. Map k a -> [a]
Map.elems Map Party [(CardanoSigningKey, Value)]
Uncommitted
commits
          GlobalState
_ -> UTxOType Payment -> GlobalState
Final [(CardanoSigningKey, Value)]
UTxOType Payment
forall a. Monoid a => a
mempty
      --
      Close{} ->
        WorldState{[(SigningKey HydraKey, CardanoSigningKey)]
$sel:hydraParties:WorldState :: [(SigningKey HydraKey, CardanoSigningKey)]
hydraParties :: [(SigningKey HydraKey, CardanoSigningKey)]
hydraParties, $sel:hydraState:WorldState :: GlobalState
hydraState = GlobalState -> GlobalState
updateWithClose GlobalState
hydraState}
       where
        updateWithClose :: GlobalState -> GlobalState
updateWithClose = \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} -> Closed{HeadParameters
$sel:headParameters:Start :: HeadParameters
headParameters :: HeadParameters
headParameters, $sel:closedUTxO:Start :: UTxOType Payment
closedUTxO = UTxOType Payment
confirmedUTxO}
          GlobalState
_ -> Text -> GlobalState
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"unexpected state"
      Fanout{} ->
        WorldState{[(SigningKey HydraKey, CardanoSigningKey)]
$sel:hydraParties:WorldState :: [(SigningKey HydraKey, CardanoSigningKey)]
hydraParties :: [(SigningKey HydraKey, CardanoSigningKey)]
hydraParties, $sel:hydraState:WorldState :: GlobalState
hydraState = GlobalState -> GlobalState
updateWithFanout GlobalState
hydraState}
       where
        updateWithFanout :: GlobalState -> GlobalState
updateWithFanout = \case
          Closed{UTxOType Payment
$sel:closedUTxO:Start :: GlobalState -> UTxOType Payment
closedUTxO :: UTxOType Payment
closedUTxO} -> UTxOType Payment -> GlobalState
Final UTxOType Payment
closedUTxO
          GlobalState
_ -> Text -> GlobalState
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"unexpected state"
      --
      (NewTx Party
_ Payment
tx) ->
        WorldState{[(SigningKey HydraKey, CardanoSigningKey)]
$sel:hydraParties:WorldState :: [(SigningKey HydraKey, CardanoSigningKey)]
hydraParties :: [(SigningKey HydraKey, CardanoSigningKey)]
hydraParties, $sel:hydraState:WorldState :: GlobalState
hydraState = GlobalState -> GlobalState
updateWithNewTx GlobalState
hydraState}
       where
        updateWithNewTx :: GlobalState -> GlobalState
updateWithNewTx = \case
          Open{HeadParameters
$sel:headParameters:Start :: GlobalState -> HeadParameters
headParameters :: HeadParameters
headParameters, Uncommitted
$sel:committed:Start :: GlobalState -> Uncommitted
committed :: Uncommitted
committed, $sel:offChainState:Start :: GlobalState -> OffChainState
offChainState = OffChainState{UTxOType Payment
$sel:confirmedUTxO:OffChainState :: OffChainState -> UTxOType Payment
confirmedUTxO :: UTxOType Payment
confirmedUTxO}} ->
            Open
              { HeadParameters
$sel:headParameters:Start :: HeadParameters
headParameters :: HeadParameters
headParameters
              , Uncommitted
$sel:committed:Start :: Uncommitted
committed :: Uncommitted
committed
              , $sel:offChainState:Start :: OffChainState
offChainState =
                  OffChainState
                    { $sel:confirmedUTxO:OffChainState :: UTxOType Payment
confirmedUTxO = UTxOType Payment
confirmedUTxO UTxOType Payment -> Payment -> UTxOType Payment
`applyTx` Payment
tx
                    }
              }
          GlobalState
_ -> Text -> GlobalState
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"unexpected state"
      CloseWithInitialSnapshot Party
_ ->
        WorldState{[(SigningKey HydraKey, CardanoSigningKey)]
$sel:hydraParties:WorldState :: [(SigningKey HydraKey, CardanoSigningKey)]
hydraParties :: [(SigningKey HydraKey, CardanoSigningKey)]
hydraParties, $sel:hydraState:WorldState :: GlobalState
hydraState = GlobalState -> GlobalState
updateWithClose GlobalState
hydraState}
       where
        updateWithClose :: GlobalState -> GlobalState
updateWithClose = \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} -> Closed{HeadParameters
$sel:headParameters:Start :: HeadParameters
headParameters :: HeadParameters
headParameters, $sel:closedUTxO:Start :: UTxOType Payment
closedUTxO = UTxOType Payment
confirmedUTxO}
          GlobalState
_ -> Text -> GlobalState
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"unexpected state"
      RollbackAndForward Natural
_numberOfBlocks -> 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

  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{[(SigningKey HydraKey, CardanoSigningKey)]
$sel:seedKeys:Seed :: Action WorldState () -> [(SigningKey HydraKey, CardanoSigningKey)]
seedKeys :: [(SigningKey HydraKey, CardanoSigningKey)]
seedKeys, Uncommitted
$sel:toCommit:Seed :: Action WorldState () -> Uncommitted
toCommit :: Uncommitted
toCommit} ->
      [ Action WorldState () -> Any (Action WorldState)
forall a (f :: * -> *). (Typeable a, Eq (f a)) => f a -> Any f
Some Action WorldState a
seed{seedKeys = seedKeys', toCommit = toCommit'}
      | [(SigningKey HydraKey, CardanoSigningKey)]
seedKeys' <- [(SigningKey HydraKey, CardanoSigningKey)]
-> [[(SigningKey HydraKey, CardanoSigningKey)]]
forall a. Arbitrary a => a -> [a]
shrink [(SigningKey HydraKey, CardanoSigningKey)]
seedKeys
      , let toCommit' :: Map Party [(CardanoSigningKey, Value)]
toCommit' = (Party -> [(CardanoSigningKey, Value)] -> Bool)
-> Map Party [(CardanoSigningKey, Value)]
-> Map Party [(CardanoSigningKey, Value)]
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey (\Party
p [(CardanoSigningKey, Value)]
_ -> Party
p Party -> [Party] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` (SigningKey HydraKey -> Party
deriveParty (SigningKey HydraKey -> Party)
-> ((SigningKey HydraKey, CardanoSigningKey)
    -> SigningKey HydraKey)
-> (SigningKey HydraKey, CardanoSigningKey)
-> Party
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SigningKey HydraKey, CardanoSigningKey) -> SigningKey HydraKey
forall a b. (a, b) -> a
fst ((SigningKey HydraKey, CardanoSigningKey) -> Party)
-> [(SigningKey HydraKey, CardanoSigningKey)] -> [Party]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(SigningKey HydraKey, CardanoSigningKey)]
seedKeys')) Map Party [(CardanoSigningKey, Value)]
Uncommitted
toCommit
      ]
    Action WorldState a
_other -> []

instance HasVariables WorldState where
  getAllVariables :: WorldState -> Set (Any Var)
getAllVariables WorldState
_ = Set (Any Var)
forall a. Monoid a => a
mempty

instance HasVariables (Action WorldState a) where
  getAllVariables :: Action WorldState a -> Set (Any Var)
getAllVariables = \case
    ObserveConfirmedTx Var Payment
tx -> Any Var -> Set (Any Var)
forall a. a -> Set a
Set.singleton (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

genSeed :: Gen (Action WorldState ())
genSeed :: Gen (Action WorldState ())
genSeed = do
  [(SigningKey HydraKey, CardanoSigningKey)]
seedKeys <- Int
-> Gen [(SigningKey HydraKey, CardanoSigningKey)]
-> Gen [(SigningKey HydraKey, CardanoSigningKey)]
forall a. Int -> Gen a -> Gen a
resize Int
maximumNumberOfParties Gen [(SigningKey HydraKey, CardanoSigningKey)]
partyKeys
  ContestationPeriod
seedContestationPeriod <- Gen ContestationPeriod
genContestationPeriod
  Map Party [(CardanoSigningKey, Value)]
toCommit <- [Map Party [(CardanoSigningKey, Value)]]
-> Map Party [(CardanoSigningKey, Value)]
forall a. Monoid a => [a] -> a
mconcat ([Map Party [(CardanoSigningKey, Value)]]
 -> Map Party [(CardanoSigningKey, Value)])
-> Gen [Map Party [(CardanoSigningKey, Value)]]
-> Gen (Map Party [(CardanoSigningKey, Value)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((SigningKey HydraKey, CardanoSigningKey)
 -> Gen (Map Party [(CardanoSigningKey, Value)]))
-> [(SigningKey HydraKey, CardanoSigningKey)]
-> Gen [Map Party [(CardanoSigningKey, Value)]]
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 (SigningKey HydraKey, CardanoSigningKey)
-> Gen (Map Party [(CardanoSigningKey, Value)])
genToCommit [(SigningKey HydraKey, CardanoSigningKey)]
seedKeys
  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{[(SigningKey HydraKey, CardanoSigningKey)]
$sel:seedKeys:Seed :: [(SigningKey HydraKey, CardanoSigningKey)]
seedKeys :: [(SigningKey HydraKey, CardanoSigningKey)]
seedKeys, ContestationPeriod
$sel:seedContestationPeriod:Seed :: ContestationPeriod
seedContestationPeriod :: ContestationPeriod
seedContestationPeriod, Map Party [(CardanoSigningKey, Value)]
Uncommitted
$sel:toCommit:Seed :: Uncommitted
toCommit :: Map Party [(CardanoSigningKey, Value)]
toCommit}

genToCommit :: (SigningKey HydraKey, CardanoSigningKey) -> Gen (Map Party [(CardanoSigningKey, Value)])
genToCommit :: (SigningKey HydraKey, CardanoSigningKey)
-> Gen (Map Party [(CardanoSigningKey, Value)])
genToCommit (SigningKey HydraKey
hk, CardanoSigningKey
ck) = do
  Value
value <- Gen Value
genAdaValue
  Map Party [(CardanoSigningKey, Value)]
-> Gen (Map Party [(CardanoSigningKey, Value)])
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map Party [(CardanoSigningKey, Value)]
 -> Gen (Map Party [(CardanoSigningKey, Value)]))
-> Map Party [(CardanoSigningKey, Value)]
-> Gen (Map Party [(CardanoSigningKey, Value)])
forall a b. (a -> b) -> a -> b
$ Party
-> [(CardanoSigningKey, Value)]
-> Map Party [(CardanoSigningKey, Value)]
forall k a. k -> a -> Map k a
Map.singleton (SigningKey HydraKey -> Party
deriveParty SigningKey HydraKey
hk) [(CardanoSigningKey
ck, Value
value)]

genContestationPeriod :: Gen ContestationPeriod
genContestationPeriod :: Gen ContestationPeriod
genContestationPeriod = do
  Word
n <- (Word, Word) -> Gen Word
forall a. Random a => (a, a) -> Gen a
choose (Word
1, Word
200)
  ContestationPeriod -> Gen ContestationPeriod
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ContestationPeriod -> Gen ContestationPeriod)
-> ContestationPeriod -> Gen ContestationPeriod
forall a b. (a -> b) -> a -> b
$ Natural -> ContestationPeriod
UnsafeContestationPeriod (Natural -> ContestationPeriod) -> Natural -> ContestationPeriod
forall a b. (a -> b) -> a -> b
$ Word -> Natural
wordToNatural Word
n

genInit :: [(SigningKey HydraKey, b)] -> Gen (Action WorldState ())
genInit :: forall b. [(SigningKey HydraKey, b)] -> Gen (Action WorldState ())
genInit [(SigningKey HydraKey, b)]
hydraParties = do
  SigningKey HydraKey
key <- (SigningKey HydraKey, b) -> SigningKey HydraKey
forall a b. (a, b) -> a
fst ((SigningKey HydraKey, b) -> SigningKey HydraKey)
-> Gen (SigningKey HydraKey, b) -> Gen (SigningKey HydraKey)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(SigningKey HydraKey, b)] -> Gen (SigningKey HydraKey, b)
forall a. [a] -> Gen a
elements [(SigningKey HydraKey, b)]
hydraParties
  let party :: Party
party = SigningKey HydraKey -> Party
deriveParty SigningKey HydraKey
key
  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
$ Party -> Action WorldState ()
Init Party
party

genPayment :: WorldState -> Gen (Party, Payment)
genPayment :: WorldState -> Gen (Party, Payment)
genPayment WorldState{[(SigningKey HydraKey, CardanoSigningKey)]
$sel:hydraParties:WorldState :: WorldState -> [(SigningKey HydraKey, CardanoSigningKey)]
hydraParties :: [(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
      (CardanoSigningKey
from, Value
value) <-
        [(CardanoSigningKey, Value)] -> Gen (CardanoSigningKey, Value)
forall a. [a] -> Gen a
elements (((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)]
valueToList (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)
      let party :: Party
party = SigningKey HydraKey -> Party
deriveParty (SigningKey HydraKey -> Party) -> SigningKey HydraKey -> Party
forall a b. (a -> b) -> a -> b
$ (SigningKey HydraKey, CardanoSigningKey) -> SigningKey HydraKey
forall a b. (a, b) -> a
fst ((SigningKey HydraKey, CardanoSigningKey) -> SigningKey HydraKey)
-> (SigningKey HydraKey, CardanoSigningKey) -> SigningKey HydraKey
forall a b. (a -> b) -> a -> b
$ Maybe (SigningKey HydraKey, CardanoSigningKey)
-> (SigningKey HydraKey, CardanoSigningKey)
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (SigningKey HydraKey, CardanoSigningKey)
 -> (SigningKey HydraKey, CardanoSigningKey))
-> Maybe (SigningKey HydraKey, CardanoSigningKey)
-> (SigningKey HydraKey, CardanoSigningKey)
forall a b. (a -> b) -> a -> b
$ ((SigningKey HydraKey, CardanoSigningKey) -> Bool)
-> [(SigningKey HydraKey, CardanoSigningKey)]
-> Maybe (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)
-> ((SigningKey HydraKey, CardanoSigningKey) -> CardanoSigningKey)
-> (SigningKey HydraKey, CardanoSigningKey)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SigningKey HydraKey, CardanoSigningKey) -> CardanoSigningKey
forall a b. (a, b) -> b
snd) [(SigningKey HydraKey, CardanoSigningKey)]
hydraParties
      -- NOTE: It's perfectly possible this yields a payment to self and it
      -- assumes hydraParties is not empty else `elements` will crash
      (SigningKey HydraKey
_, CardanoSigningKey
to) <- [(SigningKey HydraKey, CardanoSigningKey)]
-> Gen (SigningKey HydraKey, CardanoSigningKey)
forall a. [a] -> Gen a
elements [(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
to :: CardanoSigningKey
$sel:to:Payment :: 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 [(SigningKey HydraKey, CardanoSigningKey)]
partyKeys :: Gen [(SigningKey HydraKey, CardanoSigningKey)]
partyKeys =
  (Int -> Gen [(SigningKey HydraKey, CardanoSigningKey)])
-> Gen [(SigningKey HydraKey, CardanoSigningKey)]
forall a. (Int -> Gen a) -> Gen a
sized ((Int -> Gen [(SigningKey HydraKey, CardanoSigningKey)])
 -> Gen [(SigningKey HydraKey, CardanoSigningKey)])
-> (Int -> Gen [(SigningKey HydraKey, CardanoSigningKey)])
-> Gen [(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)
    [SigningKey HydraKey]
hks <- [SigningKey HydraKey] -> [SigningKey HydraKey]
forall a. Eq a => [a] -> [a]
nub ([SigningKey HydraKey] -> [SigningKey HydraKey])
-> Gen [SigningKey HydraKey] -> Gen [SigningKey HydraKey]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Gen (SigningKey HydraKey) -> Gen [SigningKey HydraKey]
forall a. Int -> Gen a -> Gen [a]
vectorOf Int
numParties Gen (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 SigningKey PaymentKey -> CardanoSigningKey
CardanoSigningKey ([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
    [(SigningKey HydraKey, CardanoSigningKey)]
-> Gen [(SigningKey HydraKey, CardanoSigningKey)]
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(SigningKey HydraKey, CardanoSigningKey)]
 -> Gen [(SigningKey HydraKey, CardanoSigningKey)])
-> [(SigningKey HydraKey, CardanoSigningKey)]
-> Gen [(SigningKey HydraKey, CardanoSigningKey)]
forall a b. (a -> b) -> a -> b
$ [SigningKey HydraKey]
-> [CardanoSigningKey]
-> [(SigningKey HydraKey, CardanoSigningKey)]
forall a b. [a] -> [b] -> [(a, b)]
zip [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
  }

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

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

instance
  ( MonadAsync m
  , MonadFork m
  , MonadMask m
  , MonadTimer m
  , MonadThrow (STM m)
  , MonadLabelledSTM m
  , MonadDelay 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
      (Commit Party
_party UTxOType Payment
expectedCommitted) ->
        [(CardanoSigningKey, Value)]
UTxOType Payment
expectedCommitted [(CardanoSigningKey, Value)]
-> [(CardanoSigningKey, Value)] -> PostconditionM (RunMonad m) Bool
forall a (m :: * -> *).
(Eq a, Show a, Monad m) =>
a -> a -> PostconditionM m Bool
=== [(CardanoSigningKey, Value)]
Realized (RunMonad m) a
result
      Fanout{} ->
        case WorldState -> GlobalState
hydraState WorldState
st of
          Final{UTxOType Payment
$sel:finalUTxO:Start :: GlobalState -> UTxOType Payment
finalUTxO :: UTxOType Payment
finalUTxO} -> do
            -- 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.
            let sorted :: [TxOut ctx] -> [TxOut ctx]
sorted = (TxOut ctx -> (AddressInEra, Coin)) -> [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 -> Coin
selectLovelace (TxOut ctx -> Value
forall ctx. TxOut ctx -> Value
txOutValue TxOut ctx
o)))
            [TxOut CtxUTxO Era] -> [TxOut CtxUTxO Era]
forall {ctx}. [TxOut ctx] -> [TxOut ctx]
sorted ([(CardanoSigningKey, Value)] -> [TxOut CtxUTxO Era]
toTxOuts [(CardanoSigningKey, Value)]
UTxOType Payment
finalUTxO) [TxOut CtxUTxO Era]
-> [TxOut CtxUTxO Era] -> PostconditionM (RunMonad m) Bool
forall a (m :: * -> *).
(Eq a, Show a, Monad m) =>
a -> a -> PostconditionM m Bool
=== [TxOut CtxUTxO Era] -> [TxOut CtxUTxO Era]
forall {ctx}. [TxOut ctx] -> [TxOut ctx]
sorted (UTxO' (TxOut CtxUTxO Era) -> [TxOut CtxUTxO Era]
forall a. UTxO' a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList UTxO' (TxOut CtxUTxO Era)
Realized (RunMonad m) a
result)
          GlobalState
_ -> Bool -> PostconditionM (RunMonad m) Bool
forall a. a -> PostconditionM (RunMonad m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
      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

  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{[(SigningKey HydraKey, CardanoSigningKey)]
$sel:seedKeys:Seed :: Action WorldState () -> [(SigningKey HydraKey, CardanoSigningKey)]
seedKeys :: [(SigningKey HydraKey, CardanoSigningKey)]
seedKeys, ContestationPeriod
$sel:seedContestationPeriod:Seed :: Action WorldState () -> ContestationPeriod
seedContestationPeriod :: ContestationPeriod
seedContestationPeriod, Uncommitted
$sel:toCommit:Seed :: Action WorldState () -> Uncommitted
toCommit :: Uncommitted
toCommit} ->
        [(SigningKey HydraKey, CardanoSigningKey)]
-> ContestationPeriod -> Uncommitted -> RunMonad m ()
forall (m :: * -> *).
(MonadAsync m, MonadTimer m, MonadThrow (STM m),
 MonadLabelledSTM m, MonadFork m, MonadMask m, MonadDelay m) =>
[(SigningKey HydraKey, CardanoSigningKey)]
-> ContestationPeriod -> Uncommitted -> RunMonad m ()
seedWorld [(SigningKey HydraKey, CardanoSigningKey)]
seedKeys ContestationPeriod
seedContestationPeriod Uncommitted
toCommit
      Commit Party
party UTxOType Payment
utxo ->
        [CardanoSigningKey]
-> Party
-> [(CardanoSigningKey, Value)]
-> RunMonad m (UTxOType Payment)
forall (m :: * -> *).
(MonadThrow m, MonadTimer m) =>
[CardanoSigningKey]
-> Party
-> [(CardanoSigningKey, Value)]
-> RunMonad m (UTxOType Payment)
performCommit ((SigningKey HydraKey, CardanoSigningKey) -> CardanoSigningKey
forall a b. (a, b) -> b
snd ((SigningKey HydraKey, CardanoSigningKey) -> CardanoSigningKey)
-> [(SigningKey HydraKey, CardanoSigningKey)]
-> [CardanoSigningKey]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WorldState -> [(SigningKey HydraKey, CardanoSigningKey)]
hydraParties WorldState
st) Party
party [(CardanoSigningKey, Value)]
UTxOType Payment
utxo
      Decommit Party
party Payment
tx ->
        Party -> Payment -> RunMonad m ()
forall (m :: * -> *).
(MonadThrow m, MonadTimer m, MonadAsync m, MonadDelay m) =>
Party -> Payment -> RunMonad m ()
performDecommit Party
party Payment
tx
      NewTx Party
party Payment
transaction ->
        Party -> Payment -> RunMonad m Payment
forall (m :: * -> *).
(MonadThrow m, MonadAsync m, MonadTimer m, MonadDelay m) =>
Party -> Payment -> RunMonad m Payment
performNewTx Party
party Payment
transaction
      Init Party
party ->
        Party -> RunMonad m ()
forall (m :: * -> *).
(MonadThrow m, MonadAsync m, MonadTimer m) =>
Party -> RunMonad m ()
performInit Party
party
      Abort Party
party -> do
        Party -> RunMonad m ()
forall (m :: * -> *).
(MonadThrow m, MonadAsync m, MonadTimer m) =>
Party -> RunMonad m ()
performAbort Party
party
      Close Party
party ->
        Party -> RunMonad m ()
forall (m :: * -> *).
(MonadThrow m, MonadAsync m, MonadTimer m, MonadDelay m) =>
Party -> RunMonad m ()
performClose Party
party
      Fanout Party
party ->
        Party -> RunMonad m (UTxO' (TxOut CtxUTxO Era))
forall (m :: * -> *).
(MonadThrow m, MonadAsync m, MonadDelay m) =>
Party -> RunMonad m (UTxO' (TxOut CtxUTxO Era))
performFanout Party
party
      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' (TxOut CtxUTxO Era)) (TxIn, TxOut CtxUTxO Era))
-> RunMonad
     m (Either (UTxO' (TxOut CtxUTxO Era)) (TxIn, TxOut CtxUTxO Era))
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' (TxOut CtxUTxO Era)
-> CardanoSigningKey
-> Value
-> TestHydraClient Tx m
-> m (Either (UTxO' (TxOut CtxUTxO Era)) (TxIn, TxOut CtxUTxO Era))
forall (m :: * -> *).
(MonadTimer m, MonadDelay m) =>
UTxO' (TxOut CtxUTxO Era)
-> CardanoSigningKey
-> Value
-> TestHydraClient Tx m
-> m (Either (UTxO' (TxOut CtxUTxO Era)) (TxIn, TxOut CtxUTxO Era))
waitForUTxOToSpend UTxO' (TxOut CtxUTxO Era)
forall a. Monoid a => a
mempty (Payment -> CardanoSigningKey
to Realized (RunMonad m) Payment
Payment
tx) (Payment -> Value
value Realized (RunMonad m) Payment
Payment
tx) TestHydraClient Tx m
node) RunMonad
  m (Either (UTxO' (TxOut CtxUTxO Era)) (TxIn, TxOut CtxUTxO Era))
-> (Either (UTxO' (TxOut CtxUTxO Era)) (TxIn, TxOut CtxUTxO Era)
    -> 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' (TxOut CtxUTxO 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' (TxOut CtxUTxO Era) -> RunException
TransactionNotObserved Realized (RunMonad m) Payment
Payment
tx UTxO' (TxOut CtxUTxO Era)
u
            Right (TxIn, TxOut CtxUTxO Era)
_ -> () -> 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) =>
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
      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

seedWorld ::
  ( MonadAsync m
  , MonadTimer m
  , MonadThrow (STM m)
  , MonadLabelledSTM m
  , MonadFork m
  , MonadMask m
  , MonadDelay m
  ) =>
  [(SigningKey HydraKey, CardanoSigningKey)] ->
  ContestationPeriod ->
  Uncommitted ->
  RunMonad m ()
seedWorld :: forall (m :: * -> *).
(MonadAsync m, MonadTimer m, MonadThrow (STM m),
 MonadLabelledSTM m, MonadFork m, MonadMask m, MonadDelay m) =>
[(SigningKey HydraKey, CardanoSigningKey)]
-> ContestationPeriod -> Uncommitted -> RunMonad m ()
seedWorld [(SigningKey HydraKey, CardanoSigningKey)]
seedKeys ContestationPeriod
seedCP Uncommitted
futureCommits = 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 DirectChainLog
-> [(SigningKey HydraKey, CardanoSigningKey)]
-> UTxO' (TxOut CtxUTxO Era)
-> m (SimulatedChainNetwork Tx m)
forall (m :: * -> *).
(MonadTimer m, MonadAsync m, MonadMask m, MonadThrow (STM m),
 MonadLabelledSTM m, MonadFork m, MonadDelay m) =>
Tracer m DirectChainLog
-> [(SigningKey HydraKey, CardanoSigningKey)]
-> UTxO' (TxOut CtxUTxO Era)
-> m (SimulatedChainNetwork Tx m)
mockChainAndNetwork ((DirectChainLog -> HydraLog Tx ())
-> Tracer m (HydraLog Tx ()) -> Tracer m DirectChainLog
forall a' a. (a' -> a) -> Tracer m a -> Tracer m a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap DirectChainLog -> HydraLog Tx ()
forall tx net. DirectChainLog -> HydraLog tx net
DirectChain Tracer m (HydraLog Tx ())
tr) [(SigningKey HydraKey, CardanoSigningKey)]
seedKeys (([(CardanoSigningKey, Value)] -> UTxO' (TxOut CtxUTxO Era))
-> [[(CardanoSigningKey, Value)]] -> UTxO' (TxOut CtxUTxO Era)
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap [(CardanoSigningKey, Value)] -> UTxO' (TxOut CtxUTxO Era)
UTxOType Payment -> UTxOType Tx
toRealUTxO ([[(CardanoSigningKey, Value)]] -> UTxO' (TxOut CtxUTxO Era))
-> [[(CardanoSigningKey, Value)]] -> UTxO' (TxOut CtxUTxO Era)
forall a b. (a -> b) -> a -> b
$ Map Party [(CardanoSigningKey, Value)]
-> [[(CardanoSigningKey, Value)]]
forall k a. Map k a -> [a]
Map.elems Map Party [(CardanoSigningKey, Value)]
Uncommitted
futureCommits)
  Async m () -> RunMonad m ()
forall {m :: * -> *} {m :: * -> *}.
MonadState (Nodes m) m =>
Async m () -> m ()
pushThread Async m ()
tickThread

  [(Party, TestHydraClient Tx m)]
clients <- [(SigningKey HydraKey, CardanoSigningKey)]
-> ((SigningKey HydraKey, CardanoSigningKey)
    -> RunMonad m (Party, TestHydraClient Tx m))
-> RunMonad m [(Party, TestHydraClient Tx m)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(SigningKey HydraKey, CardanoSigningKey)]
seedKeys (((SigningKey HydraKey, CardanoSigningKey)
  -> RunMonad m (Party, TestHydraClient Tx m))
 -> RunMonad m [(Party, TestHydraClient Tx m)])
-> ((SigningKey HydraKey, CardanoSigningKey)
    -> RunMonad m (Party, TestHydraClient Tx m))
-> RunMonad m [(Party, TestHydraClient Tx m)]
forall a b. (a -> b) -> a -> b
$ \(SigningKey HydraKey
hsk, CardanoSigningKey
_csk) -> do
    let party :: Party
party = SigningKey HydraKey -> Party
deriveParty 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
    (TestHydraClient Tx m
testClient, Async m ()
nodeThread) <- 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 <- STM m (TQueue m (ServerOutput Tx))
-> m (TQueue m (ServerOutput Tx))
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically STM m (TQueue m (ServerOutput Tx))
forall a. STM m (TQueue m a)
forall (m :: * -> *) a. MonadSTM m => STM m (TQueue m a)
newTQueue
      TQueue m (ServerOutput Tx) -> String -> m ()
forall a. TQueue m a -> String -> m ()
forall (m :: * -> *) a.
MonadLabelledSTM m =>
TQueue m a -> String -> m ()
labelTQueueIO TQueue m (ServerOutput Tx)
outputs (String
"outputs-" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> SigningKey HydraKey -> String
shortLabel SigningKey HydraKey
hsk)
      TVar m [ServerOutput Tx]
outputHistory <- [ServerOutput Tx] -> m (TVar m [ServerOutput Tx])
forall a. a -> m (TVar m a)
forall (m :: * -> *) a. MonadSTM m => a -> m (TVar m a)
newTVarIO []
      TVar m [ServerOutput Tx] -> String -> m ()
forall a. TVar m a -> String -> m ()
forall (m :: * -> *) a.
MonadLabelledSTM m =>
TVar m a -> String -> m ()
labelTVarIO TVar m [ServerOutput Tx]
outputHistory (String
"history-" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> SigningKey HydraKey -> String
shortLabel SigningKey HydraKey
hsk)
      HydraNode Tx m
node <- Tracer m (HydraNodeLog Tx)
-> Ledger Tx
-> ChainStateType Tx
-> SigningKey HydraKey
-> [Party]
-> TQueue m (ServerOutput Tx)
-> TVar m [ServerOutput Tx]
-> SimulatedChainNetwork Tx m
-> ContestationPeriod
-> m (HydraNode Tx m)
forall (m :: * -> *) tx.
(MonadDelay m, MonadAsync m, MonadLabelledSTM m, IsChainState tx,
 MonadThrow m) =>
Tracer m (HydraNodeLog tx)
-> Ledger tx
-> ChainStateType tx
-> SigningKey HydraKey
-> [Party]
-> TQueue m (ServerOutput tx)
-> TVar m [ServerOutput tx]
-> SimulatedChainNetwork tx m
-> ContestationPeriod
-> m (HydraNode tx m)
createHydraNode ((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 net. HydraNodeLog tx -> HydraLog tx net
Node Tracer m (HydraLog Tx ())
tr) Ledger Tx
ledger ChainStateType Tx
initialChainState SigningKey HydraKey
hsk [Party]
otherParties TQueue m (ServerOutput Tx)
outputs TVar m [ServerOutput Tx]
outputHistory SimulatedChainNetwork Tx m
mockChain ContestationPeriod
seedCP
      let testClient :: TestHydraClient Tx m
testClient = TQueue m (ServerOutput Tx)
-> TVar m [ServerOutput Tx]
-> HydraNode Tx m
-> TestHydraClient Tx m
forall (m :: * -> *) tx.
MonadSTM m =>
TQueue m (ServerOutput tx)
-> TVar m [ServerOutput tx]
-> HydraNode tx m
-> TestHydraClient tx m
createTestHydraClient TQueue m (ServerOutput Tx)
outputs TVar m [ServerOutput Tx]
outputHistory HydraNode Tx m
node
      Async m ()
nodeThread <- m () -> m (Async m ())
forall a. m a -> m (Async m a)
forall (m :: * -> *) a. MonadAsync m => m a -> m (Async m a)
async (m () -> m (Async m ())) -> m () -> m (Async m ())
forall a b. (a -> b) -> a -> b
$ String -> m ()
forall (m :: * -> *). MonadThread m => String -> m ()
labelThisThread (String
"node-" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> SigningKey HydraKey -> String
shortLabel SigningKey HydraKey
hsk) m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> HydraNode Tx m -> m ()
forall (m :: * -> *) tx.
(MonadCatch m, MonadAsync 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
      (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)
    Async m () -> RunMonad m ()
forall {m :: * -> *} {m :: * -> *}.
MonadState (Nodes m) m =>
Async m () -> m ()
pushThread Async m ()
nodeThread
    (Party, TestHydraClient Tx m)
-> RunMonad m (Party, TestHydraClient Tx m)
forall a. a -> RunMonad m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Party
party, TestHydraClient Tx m
testClient)

  (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 clients, chain = mockChain}
 where
  parties :: [Party]
parties = ((SigningKey HydraKey, CardanoSigningKey) -> Party)
-> [(SigningKey HydraKey, CardanoSigningKey)] -> [Party]
forall a b. (a -> b) -> [a] -> [b]
map (SigningKey HydraKey -> Party
deriveParty (SigningKey HydraKey -> Party)
-> ((SigningKey HydraKey, CardanoSigningKey)
    -> SigningKey HydraKey)
-> (SigningKey HydraKey, CardanoSigningKey)
-> Party
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SigningKey HydraKey, CardanoSigningKey) -> SigningKey HydraKey
forall a b. (a, b) -> a
fst) [(SigningKey HydraKey, CardanoSigningKey)]
seedKeys

  ledger :: Ledger Tx
ledger = Globals -> LedgerEnv LedgerEra -> Ledger Tx
cardanoLedger Globals
defaultGlobals LedgerEnv LedgerEra
defaultLedgerEnv

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

performCommit ::
  (MonadThrow m, MonadTimer m) =>
  [CardanoSigningKey] ->
  Party ->
  [(CardanoSigningKey, Value)] ->
  RunMonad m ActualCommitted
performCommit :: forall (m :: * -> *).
(MonadThrow m, MonadTimer m) =>
[CardanoSigningKey]
-> Party
-> [(CardanoSigningKey, Value)]
-> RunMonad m (UTxOType Payment)
performCommit [CardanoSigningKey]
parties Party
party [(CardanoSigningKey, Value)]
paymentUTxO = 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{(Party, UTxOType Tx) -> m ()
simulateCommit :: (Party, UTxOType Tx) -> m ()
$sel:simulateCommit:SimulatedChainNetwork :: forall tx (m :: * -> *).
SimulatedChainNetwork tx m -> (Party, UTxOType tx) -> m ()
simulateCommit} <- (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
  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 [(CardanoSigningKey, Value)]
forall e a. Exception e => e -> RunMonad m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (RunException -> RunMonad m [(CardanoSigningKey, Value)])
-> RunException -> RunMonad m [(CardanoSigningKey, Value)]
forall a b. (a -> b) -> a -> b
$ Party -> RunException
UnexpectedParty Party
party
    Just{} -> do
      let realUTxO :: UTxOType Tx
realUTxO = UTxOType Payment -> UTxOType Tx
toRealUTxO [(CardanoSigningKey, Value)]
UTxOType Payment
paymentUTxO
      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
$ (Party, UTxOType Tx) -> m ()
simulateCommit (Party
party, UTxOType Tx
realUTxO)
      Map Party (UTxO' (TxOut CtxUTxO Era))
observedUTxO <-
        m (Map Party (UTxO' (TxOut CtxUTxO Era)))
-> RunMonad m (Map Party (UTxO' (TxOut CtxUTxO Era)))
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 (Map Party (UTxO' (TxOut CtxUTxO Era)))
 -> RunMonad m (Map Party (UTxO' (TxOut CtxUTxO Era))))
-> m (Map Party (UTxO' (TxOut CtxUTxO Era)))
-> RunMonad m (Map Party (UTxO' (TxOut CtxUTxO Era)))
forall a b. (a -> b) -> a -> b
$
          Map Party (TestHydraClient Tx m)
-> (TestHydraClient Tx m -> m (UTxO' (TxOut CtxUTxO Era)))
-> m (Map Party (UTxO' (TxOut CtxUTxO Era)))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Map Party (TestHydraClient Tx m)
nodes ((TestHydraClient Tx m -> m (UTxO' (TxOut CtxUTxO Era)))
 -> m (Map Party (UTxO' (TxOut CtxUTxO Era))))
-> (TestHydraClient Tx m -> m (UTxO' (TxOut CtxUTxO Era)))
-> m (Map Party (UTxO' (TxOut CtxUTxO Era)))
forall a b. (a -> b) -> a -> b
$ \TestHydraClient Tx m
n ->
            TestHydraClient Tx m
-> (ServerOutput Tx -> Maybe (UTxO' (TxOut CtxUTxO Era)))
-> m (UTxO' (TxOut CtxUTxO Era))
forall (m :: * -> *) tx a.
MonadThrow m =>
TestHydraClient tx m -> (ServerOutput tx -> Maybe a) -> m a
waitMatch TestHydraClient Tx m
n ((ServerOutput Tx -> Maybe (UTxO' (TxOut CtxUTxO Era)))
 -> m (UTxO' (TxOut CtxUTxO Era)))
-> (ServerOutput Tx -> Maybe (UTxO' (TxOut CtxUTxO Era)))
-> m (UTxO' (TxOut CtxUTxO Era))
forall a b. (a -> b) -> a -> b
$ \case
              Committed{$sel:party:PeerConnected :: forall tx. ServerOutput tx -> Party
party = Party
cp, $sel:utxo:PeerConnected :: forall tx. ServerOutput tx -> UTxOType tx
utxo = UTxOType Tx
committedUTxO}
                | Party
cp Party -> Party -> Bool
forall a. Eq a => a -> a -> Bool
== Party
party, UTxO' (TxOut CtxUTxO Era)
UTxOType Tx
committedUTxO UTxO' (TxOut CtxUTxO Era) -> UTxO' (TxOut CtxUTxO Era) -> Bool
forall a. Eq a => a -> a -> Bool
== UTxO' (TxOut CtxUTxO Era)
UTxOType Tx
realUTxO -> UTxO' (TxOut CtxUTxO Era) -> Maybe (UTxO' (TxOut CtxUTxO Era))
forall a. a -> Maybe a
Just UTxO' (TxOut CtxUTxO Era)
UTxOType Tx
committedUTxO
              err :: ServerOutput Tx
err@CommandFailed{} -> Text -> Maybe (UTxO' (TxOut CtxUTxO Era))
forall a t. (HasCallStack, IsText t) => t -> a
error (Text -> Maybe (UTxO' (TxOut CtxUTxO Era)))
-> Text -> Maybe (UTxO' (TxOut CtxUTxO Era))
forall a b. (a -> b) -> a -> b
$ ServerOutput Tx -> Text
forall b a. (Show a, IsString b) => a -> b
show ServerOutput Tx
err
              ServerOutput Tx
_ -> Maybe (UTxO' (TxOut CtxUTxO Era))
forall a. Maybe a
Nothing
      [(CardanoSigningKey, Value)]
-> RunMonad m [(CardanoSigningKey, Value)]
forall a. a -> RunMonad m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(CardanoSigningKey, Value)]
 -> RunMonad m [(CardanoSigningKey, Value)])
-> [(CardanoSigningKey, Value)]
-> RunMonad m [(CardanoSigningKey, Value)]
forall a b. (a -> b) -> a -> b
$ UTxO' (TxOut CtxUTxO Era) -> [(CardanoSigningKey, Value)]
fromUtxo (UTxO' (TxOut CtxUTxO Era) -> [(CardanoSigningKey, Value)])
-> UTxO' (TxOut CtxUTxO Era) -> [(CardanoSigningKey, Value)]
forall a b. (a -> b) -> a -> b
$ [UTxO' (TxOut CtxUTxO Era)] -> UTxO' (TxOut CtxUTxO Era)
forall a. HasCallStack => [a] -> a
List.head ([UTxO' (TxOut CtxUTxO Era)] -> UTxO' (TxOut CtxUTxO Era))
-> [UTxO' (TxOut CtxUTxO Era)] -> UTxO' (TxOut CtxUTxO Era)
forall a b. (a -> b) -> a -> b
$ Map Party (UTxO' (TxOut CtxUTxO Era))
-> [UTxO' (TxOut CtxUTxO Era)]
forall a. Map Party a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Map Party (UTxO' (TxOut CtxUTxO Era))
observedUTxO
 where
  fromUtxo :: UTxO -> [(CardanoSigningKey, Value)]
  fromUtxo :: UTxO' (TxOut CtxUTxO Era) -> [(CardanoSigningKey, Value)]
fromUtxo UTxO' (TxOut CtxUTxO Era)
utxo = (AddressInEra, Value) -> (CardanoSigningKey, Value)
findSigningKey ((AddressInEra, Value) -> (CardanoSigningKey, Value))
-> ((TxIn, TxOut CtxUTxO Era) -> (AddressInEra, Value))
-> (TxIn, TxOut CtxUTxO Era)
-> (CardanoSigningKey, Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxOut CtxUTxO Era -> AddressInEra
forall ctx. TxOut ctx -> AddressInEra
txOutAddress (TxOut CtxUTxO Era -> AddressInEra)
-> (TxOut CtxUTxO Era -> Value)
-> TxOut CtxUTxO Era
-> (AddressInEra, Value)
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& TxOut CtxUTxO Era -> Value
forall ctx. TxOut ctx -> Value
txOutValue) (TxOut CtxUTxO Era -> (AddressInEra, Value))
-> ((TxIn, TxOut CtxUTxO Era) -> TxOut CtxUTxO Era)
-> (TxIn, TxOut CtxUTxO Era)
-> (AddressInEra, Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxIn, TxOut CtxUTxO Era) -> TxOut CtxUTxO Era
forall a b. (a, b) -> b
snd ((TxIn, TxOut CtxUTxO Era) -> (CardanoSigningKey, Value))
-> [(TxIn, TxOut CtxUTxO Era)] -> [(CardanoSigningKey, Value)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UTxO' (TxOut CtxUTxO Era) -> [(TxIn, TxOut CtxUTxO Era)]
forall out. UTxO' out -> [(TxIn, out)]
pairs UTxO' (TxOut CtxUTxO Era)
utxo

  knownAddresses :: [(AddressInEra, CardanoSigningKey)]
  knownAddresses :: [(AddressInEra, CardanoSigningKey)]
knownAddresses = [AddressInEra]
-> [CardanoSigningKey] -> [(AddressInEra, CardanoSigningKey)]
forall a b. [a] -> [b] -> [(a, b)]
zip (CardanoSigningKey -> AddressInEra
makeAddressFromSigningKey (CardanoSigningKey -> AddressInEra)
-> [CardanoSigningKey] -> [AddressInEra]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [CardanoSigningKey]
parties) [CardanoSigningKey]
parties

  findSigningKey :: (AddressInEra, Value) -> (CardanoSigningKey, Value)
  findSigningKey :: (AddressInEra, Value) -> (CardanoSigningKey, Value)
findSigningKey (AddressInEra
addr, Value
value) =
    case AddressInEra
-> [(AddressInEra, CardanoSigningKey)] -> Maybe CardanoSigningKey
forall a b. Eq a => a -> [(a, b)] -> Maybe b
List.lookup AddressInEra
addr [(AddressInEra, CardanoSigningKey)]
knownAddresses of
      Maybe CardanoSigningKey
Nothing -> Text -> (CardanoSigningKey, Value)
forall a t. (HasCallStack, IsText t) => t -> a
error (Text -> (CardanoSigningKey, Value))
-> Text -> (CardanoSigningKey, Value)
forall a b. (a -> b) -> a -> b
$ Text
"cannot invert address:  " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> AddressInEra -> Text
forall b a. (Show a, IsString b) => a -> b
show AddressInEra
addr
      Just CardanoSigningKey
sk -> (CardanoSigningKey
sk, Value
value)

  makeAddressFromSigningKey :: CardanoSigningKey -> AddressInEra
  makeAddressFromSigningKey :: CardanoSigningKey -> AddressInEra
makeAddressFromSigningKey = NetworkId -> VerificationKey PaymentKey -> AddressInEra
forall era.
IsShelleyBasedEra era =>
NetworkId -> VerificationKey PaymentKey -> AddressInEra era
mkVkAddress NetworkId
testNetworkId (VerificationKey PaymentKey -> AddressInEra)
-> (CardanoSigningKey -> VerificationKey PaymentKey)
-> CardanoSigningKey
-> AddressInEra
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SigningKey PaymentKey -> VerificationKey PaymentKey
forall keyrole.
(Key keyrole, HasTypeProxy keyrole) =>
SigningKey keyrole -> VerificationKey keyrole
getVerificationKey (SigningKey PaymentKey -> VerificationKey PaymentKey)
-> (CardanoSigningKey -> SigningKey PaymentKey)
-> CardanoSigningKey
-> VerificationKey PaymentKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CardanoSigningKey -> SigningKey PaymentKey
signingKey

performDecommit ::
  (MonadThrow m, MonadTimer m, MonadAsync m, MonadDelay m) =>
  Party ->
  Payment ->
  RunMonad m ()
performDecommit :: forall (m :: * -> *).
(MonadThrow m, MonadTimer m, MonadAsync m, MonadDelay m) =>
Party -> Payment -> RunMonad m ()
performDecommit Party
party Payment
tx = do
  let recipient :: AddressInEra
recipient = NetworkId -> VerificationKey PaymentKey -> AddressInEra
forall era.
IsShelleyBasedEra era =>
NetworkId -> VerificationKey PaymentKey -> AddressInEra era
mkVkAddress NetworkId
testNetworkId (VerificationKey PaymentKey -> AddressInEra)
-> (CardanoSigningKey -> VerificationKey PaymentKey)
-> CardanoSigningKey
-> AddressInEra
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SigningKey PaymentKey -> VerificationKey PaymentKey
forall keyrole.
(Key keyrole, HasTypeProxy keyrole) =>
SigningKey keyrole -> VerificationKey keyrole
getVerificationKey (SigningKey PaymentKey -> VerificationKey PaymentKey)
-> (CardanoSigningKey -> SigningKey PaymentKey)
-> CardanoSigningKey
-> VerificationKey PaymentKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CardanoSigningKey -> SigningKey PaymentKey
signingKey (CardanoSigningKey -> AddressInEra)
-> CardanoSigningKey -> AddressInEra
forall a b. (a -> b) -> a -> b
$ Payment -> CardanoSigningKey
to Payment
tx
  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 Era
o) <-
    m (Either (UTxO' (TxOut CtxUTxO Era)) (TxIn, TxOut CtxUTxO Era))
-> RunMonad
     m (Either (UTxO' (TxOut CtxUTxO Era)) (TxIn, TxOut CtxUTxO Era))
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' (TxOut CtxUTxO Era)
-> CardanoSigningKey
-> Value
-> TestHydraClient Tx m
-> m (Either (UTxO' (TxOut CtxUTxO Era)) (TxIn, TxOut CtxUTxO Era))
forall (m :: * -> *).
(MonadTimer m, MonadDelay m) =>
UTxO' (TxOut CtxUTxO Era)
-> CardanoSigningKey
-> Value
-> TestHydraClient Tx m
-> m (Either (UTxO' (TxOut CtxUTxO Era)) (TxIn, TxOut CtxUTxO Era))
waitForUTxOToSpend UTxO' (TxOut CtxUTxO 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' (TxOut CtxUTxO Era)) (TxIn, TxOut CtxUTxO Era))
-> (Either (UTxO' (TxOut CtxUTxO Era)) (TxIn, TxOut CtxUTxO Era)
    -> RunMonad m (TxIn, TxOut CtxUTxO Era))
-> RunMonad m (TxIn, TxOut CtxUTxO Era)
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' (TxOut CtxUTxO Era)
u -> Text -> RunMonad m (TxIn, TxOut CtxUTxO Era)
forall a t. (HasCallStack, IsText t) => t -> a
error (Text -> RunMonad m (TxIn, TxOut CtxUTxO Era))
-> Text -> RunMonad m (TxIn, TxOut CtxUTxO Era)
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' (TxOut CtxUTxO Era) -> Text
forall b a. (Show a, IsString b) => a -> b
show UTxO' (TxOut CtxUTxO Era)
u
      Right (TxIn, TxOut CtxUTxO Era)
ok -> (TxIn, TxOut CtxUTxO Era) -> RunMonad m (TxIn, TxOut CtxUTxO Era)
forall a. a -> RunMonad m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxIn, TxOut CtxUTxO Era)
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
          ((TxIn, TxOut CtxUTxO Era)
-> (AddressInEra, Value)
-> SigningKey PaymentKey
-> Either TxBodyError Tx
mkSimpleTx (TxIn
i, TxOut CtxUTxO Era
o) (AddressInEra
recipient, Payment -> Value
value Payment
tx) (CardanoSigningKey -> SigningKey PaymentKey
signingKey (CardanoSigningKey -> SigningKey PaymentKey)
-> CardanoSigningKey -> SigningKey PaymentKey
forall a b. (a -> b) -> a -> b
$ Payment -> CardanoSigningKey
from Payment
tx))

  Party
party Party -> ClientInput Tx -> RunMonad m ()
forall (m :: * -> *).
(MonadSTM m, MonadThrow 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 ()) -> m () -> RunMonad m ()
forall a b. (a -> b) -> a -> b
$ do
    [TestHydraClient Tx m] -> (ServerOutput Tx -> Bool) -> m ()
forall tx (m :: * -> *).
(Show (ServerOutput tx), HasCallStack, MonadThrow m, MonadAsync m,
 MonadTimer m) =>
[TestHydraClient tx m] -> (ServerOutput tx -> Bool) -> m ()
waitUntilMatch [TestHydraClient Tx m
thisNode] ((ServerOutput Tx -> Bool) -> m ())
-> (ServerOutput Tx -> Bool) -> m ()
forall a b. (a -> b) -> a -> b
$ \case
      DecommitFinalized{} -> Bool
True
      err :: ServerOutput Tx
err@CommandFailed{} -> Text -> Bool
forall a t. (HasCallStack, IsText t) => t -> a
error (Text -> Bool) -> Text -> Bool
forall a b. (a -> b) -> a -> b
$ ServerOutput Tx -> Text
forall b a. (Show a, IsString b) => a -> b
show ServerOutput Tx
err
      ServerOutput Tx
_ -> Bool
False

performNewTx ::
  (MonadThrow m, MonadAsync m, MonadTimer m, MonadDelay m) =>
  Party ->
  Payment ->
  RunMonad m Payment
performNewTx :: forall (m :: * -> *).
(MonadThrow m, MonadAsync m, MonadTimer m, MonadDelay m) =>
Party -> Payment -> RunMonad m Payment
performNewTx Party
party Payment
tx = do
  let recipient :: AddressInEra
recipient = NetworkId -> VerificationKey PaymentKey -> AddressInEra
forall era.
IsShelleyBasedEra era =>
NetworkId -> VerificationKey PaymentKey -> AddressInEra era
mkVkAddress NetworkId
testNetworkId (VerificationKey PaymentKey -> AddressInEra)
-> (CardanoSigningKey -> VerificationKey PaymentKey)
-> CardanoSigningKey
-> AddressInEra
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SigningKey PaymentKey -> VerificationKey PaymentKey
forall keyrole.
(Key keyrole, HasTypeProxy keyrole) =>
SigningKey keyrole -> VerificationKey keyrole
getVerificationKey (SigningKey PaymentKey -> VerificationKey PaymentKey)
-> (CardanoSigningKey -> SigningKey PaymentKey)
-> CardanoSigningKey
-> VerificationKey PaymentKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CardanoSigningKey -> SigningKey PaymentKey
signingKey (CardanoSigningKey -> AddressInEra)
-> CardanoSigningKey -> AddressInEra
forall a b. (a -> b) -> a -> b
$ Payment -> CardanoSigningKey
to Payment
tx
  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 Era
o) <-
    m (Either (UTxO' (TxOut CtxUTxO Era)) (TxIn, TxOut CtxUTxO Era))
-> RunMonad
     m (Either (UTxO' (TxOut CtxUTxO Era)) (TxIn, TxOut CtxUTxO Era))
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' (TxOut CtxUTxO Era)
-> CardanoSigningKey
-> Value
-> TestHydraClient Tx m
-> m (Either (UTxO' (TxOut CtxUTxO Era)) (TxIn, TxOut CtxUTxO Era))
forall (m :: * -> *).
(MonadTimer m, MonadDelay m) =>
UTxO' (TxOut CtxUTxO Era)
-> CardanoSigningKey
-> Value
-> TestHydraClient Tx m
-> m (Either (UTxO' (TxOut CtxUTxO Era)) (TxIn, TxOut CtxUTxO Era))
waitForUTxOToSpend UTxO' (TxOut CtxUTxO 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' (TxOut CtxUTxO Era)) (TxIn, TxOut CtxUTxO Era))
-> (Either (UTxO' (TxOut CtxUTxO Era)) (TxIn, TxOut CtxUTxO Era)
    -> RunMonad m (TxIn, TxOut CtxUTxO Era))
-> RunMonad m (TxIn, TxOut CtxUTxO Era)
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' (TxOut CtxUTxO Era)
u -> Text -> RunMonad m (TxIn, TxOut CtxUTxO Era)
forall a t. (HasCallStack, IsText t) => t -> a
error (Text -> RunMonad m (TxIn, TxOut CtxUTxO Era))
-> Text -> RunMonad m (TxIn, TxOut CtxUTxO Era)
forall a b. (a -> b) -> a -> b
$ Text
"Cannot execute NewTx 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' (TxOut CtxUTxO Era) -> Text
forall b a. (Show a, IsString b) => a -> b
show UTxO' (TxOut CtxUTxO Era)
u
      Right (TxIn, TxOut CtxUTxO Era)
ok -> (TxIn, TxOut CtxUTxO Era) -> RunMonad m (TxIn, TxOut CtxUTxO Era)
forall a. a -> RunMonad m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxIn, TxOut CtxUTxO Era)
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
          ((TxIn, TxOut CtxUTxO Era)
-> (AddressInEra, Value)
-> SigningKey PaymentKey
-> Either TxBodyError Tx
mkSimpleTx (TxIn
i, TxOut CtxUTxO Era
o) (AddressInEra
recipient, Payment -> Value
value Payment
tx) (CardanoSigningKey -> SigningKey PaymentKey
signingKey (CardanoSigningKey -> SigningKey PaymentKey)
-> CardanoSigningKey -> SigningKey PaymentKey
forall a b. (a -> b) -> a -> b
$ Payment -> CardanoSigningKey
from Payment
tx))

  Party
party Party -> ClientInput Tx -> RunMonad m ()
forall (m :: * -> *).
(MonadSTM m, MonadThrow m) =>
Party -> ClientInput Tx -> RunMonad m ()
`sendsInput` Tx -> ClientInput Tx
forall tx. tx -> ClientInput tx
Input.NewTx Tx
realTx
  m Payment -> RunMonad m Payment
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 Payment -> RunMonad m Payment)
-> m Payment -> RunMonad m Payment
forall a b. (a -> b) -> a -> b
$ do
    [TestHydraClient Tx m] -> (ServerOutput Tx -> Bool) -> m ()
forall tx (m :: * -> *).
(Show (ServerOutput tx), HasCallStack, MonadThrow m, MonadAsync m,
 MonadTimer m) =>
[TestHydraClient tx m] -> (ServerOutput tx -> Bool) -> m ()
waitUntilMatch (Map Party (TestHydraClient Tx m) -> [TestHydraClient Tx m]
forall a. Map Party a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Map Party (TestHydraClient Tx m)
nodes) ((ServerOutput Tx -> Bool) -> m ())
-> (ServerOutput Tx -> Bool) -> m ()
forall a b. (a -> b) -> a -> b
$ \case
      SnapshotConfirmed{$sel:snapshot:PeerConnected :: forall tx. ServerOutput tx -> Snapshot tx
snapshot = Snapshot Tx
snapshot} ->
        Tx -> TxIdType Tx
forall tx. IsTx tx => tx -> TxIdType tx
txId Tx
realTx TxId -> [TxId] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` Snapshot Tx -> [TxIdType Tx]
forall tx. Snapshot tx -> [TxIdType tx]
Snapshot.confirmed Snapshot Tx
snapshot
      err :: ServerOutput Tx
err@TxInvalid{} -> Text -> Bool
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
_ -> Bool
False
    Payment -> m Payment
forall a. a -> 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 :: (MonadSTM m, MonadThrow m) => Party -> ClientInput Tx -> RunMonad m ()
sendsInput :: forall (m :: * -> *).
(MonadSTM m, MonadThrow m) =>
Party -> ClientInput Tx -> RunMonad m ()
sendsInput Party
party ClientInput Tx
command = 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 ()
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
$ Party -> RunException
UnexpectedParty Party
party
    Just 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

performInit :: (MonadThrow m, MonadAsync m, MonadTimer m) => Party -> RunMonad m ()
performInit :: forall (m :: * -> *).
(MonadThrow m, MonadAsync m, MonadTimer m) =>
Party -> RunMonad m ()
performInit Party
party = do
  Party
party Party -> ClientInput Tx -> RunMonad m ()
forall (m :: * -> *).
(MonadSTM m, MonadThrow 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 () -> 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] -> (ServerOutput Tx -> Bool) -> m ()
forall tx (m :: * -> *).
(Show (ServerOutput tx), HasCallStack, MonadThrow m, MonadAsync m,
 MonadTimer m) =>
[TestHydraClient tx m] -> (ServerOutput tx -> Bool) -> m ()
waitUntilMatch (Map Party (TestHydraClient Tx m) -> [TestHydraClient Tx m]
forall a. Map Party a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Map Party (TestHydraClient Tx m)
nodes) ((ServerOutput Tx -> Bool) -> m ())
-> (ServerOutput Tx -> Bool) -> m ()
forall a b. (a -> b) -> a -> b
$ \case
      HeadIsInitializing{} -> Bool
True
      err :: ServerOutput Tx
err@CommandFailed{} -> Text -> Bool
forall a t. (HasCallStack, IsText t) => t -> a
error (Text -> Bool) -> Text -> Bool
forall a b. (a -> b) -> a -> b
$ ServerOutput Tx -> Text
forall b a. (Show a, IsString b) => a -> b
show ServerOutput Tx
err
      ServerOutput Tx
_ -> Bool
False

performAbort :: (MonadThrow m, MonadAsync m, MonadTimer m) => Party -> RunMonad m ()
performAbort :: forall (m :: * -> *).
(MonadThrow m, MonadAsync m, MonadTimer m) =>
Party -> RunMonad m ()
performAbort Party
party = do
  Party
party Party -> ClientInput Tx -> RunMonad m ()
forall (m :: * -> *).
(MonadSTM m, MonadThrow m) =>
Party -> ClientInput Tx -> RunMonad m ()
`sendsInput` ClientInput Tx
forall tx. ClientInput tx
Input.Abort

  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 ()) -> m () -> RunMonad m ()
forall a b. (a -> b) -> a -> b
$
    [TestHydraClient Tx m] -> (ServerOutput Tx -> Bool) -> m ()
forall tx (m :: * -> *).
(Show (ServerOutput tx), HasCallStack, MonadThrow m, MonadAsync m,
 MonadTimer m) =>
[TestHydraClient tx m] -> (ServerOutput tx -> Bool) -> m ()
waitUntilMatch (Map Party (TestHydraClient Tx m) -> [TestHydraClient Tx m]
forall a. Map Party a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Map Party (TestHydraClient Tx m)
nodes) ((ServerOutput Tx -> Bool) -> m ())
-> (ServerOutput Tx -> Bool) -> m ()
forall a b. (a -> b) -> a -> b
$ \case
      HeadIsAborted{} -> Bool
True
      err :: ServerOutput Tx
err@CommandFailed{} -> Text -> Bool
forall a t. (HasCallStack, IsText t) => t -> a
error (Text -> Bool) -> Text -> Bool
forall a b. (a -> b) -> a -> b
$ ServerOutput Tx -> Text
forall b a. (Show a, IsString b) => a -> b
show ServerOutput Tx
err
      ServerOutput Tx
_ -> Bool
False

performClose :: (MonadThrow m, MonadAsync m, MonadTimer m, MonadDelay m) => Party -> RunMonad m ()
performClose :: forall (m :: * -> *).
(MonadThrow m, MonadAsync m, MonadTimer m, MonadDelay 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
  Party
party Party -> ClientInput Tx -> RunMonad m ()
forall (m :: * -> *).
(MonadSTM m, MonadThrow m) =>
Party -> ClientInput Tx -> RunMonad m ()
`sendsInput` ClientInput Tx
forall tx. ClientInput tx
Input.Close

  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] -> (ServerOutput Tx -> Bool) -> m ()
forall tx (m :: * -> *).
(Show (ServerOutput tx), HasCallStack, MonadThrow m, MonadAsync m,
 MonadTimer m) =>
[TestHydraClient tx m] -> (ServerOutput tx -> Bool) -> m ()
waitUntilMatch (Map Party (TestHydraClient Tx m) -> [TestHydraClient Tx m]
forall a. Map Party a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Map Party (TestHydraClient Tx m)
nodes) ((ServerOutput Tx -> Bool) -> m ())
-> (ServerOutput Tx -> Bool) -> m ()
forall a b. (a -> b) -> a -> b
$ \case
      HeadIsClosed{} -> Bool
True
      err :: ServerOutput Tx
err@CommandFailed{} -> Text -> Bool
forall a t. (HasCallStack, IsText t) => t -> a
error (Text -> Bool) -> Text -> Bool
forall a b. (a -> b) -> a -> b
$ ServerOutput Tx -> Text
forall b a. (Show a, IsString b) => a -> b
show ServerOutput Tx
err
      ServerOutput 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' (TxOut CtxUTxO Era))
performFanout 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 ()
waitForReadyToFanout TestHydraClient Tx m
thisNode
  Party
party Party -> ClientInput Tx -> RunMonad m ()
forall (m :: * -> *).
(MonadSTM m, MonadThrow m) =>
Party -> ClientInput Tx -> RunMonad m ()
`sendsInput` ClientInput Tx
forall tx. ClientInput tx
Input.Fanout
  TestHydraClient Tx m -> Int -> RunMonad m (UTxOType Tx)
forall {t} {t :: (* -> *) -> * -> *} {m :: * -> *} {tx}.
(Eq t, Num t, MonadThrow (t m), MonadTrans t, MonadDelay m) =>
TestHydraClient tx m -> t -> t m (UTxOType tx)
findInOutput TestHydraClient Tx m
thisNode (Int
100 :: Int)
 where
  findInOutput :: TestHydraClient tx m -> t -> t m (UTxOType tx)
findInOutput TestHydraClient tx m
node t
n
    | t
n t -> t -> Bool
forall a. Eq a => a -> a -> Bool
== t
0 = String -> t m (UTxOType tx)
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure String
"Failed to perform Fanout"
    | Bool
otherwise = do
        [ServerOutput tx]
outputs <- m [ServerOutput tx] -> t m [ServerOutput tx]
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m [ServerOutput tx] -> t m [ServerOutput tx])
-> m [ServerOutput tx] -> t 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
headIsFinalized [ServerOutput tx]
outputs of
          Just HeadIsFinalized{UTxOType tx
$sel:utxo:PeerConnected :: forall tx. ServerOutput tx -> UTxOType tx
utxo :: UTxOType tx
utxo} -> UTxOType tx -> t m (UTxOType tx)
forall a. a -> t m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure UTxOType tx
utxo
          Maybe (ServerOutput tx)
_ -> m () -> t m ()
forall (m :: * -> *) a. Monad m => m a -> t 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) t m () -> t m (UTxOType tx) -> t m (UTxOType tx)
forall a b. t m a -> t m b -> t m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TestHydraClient tx m -> t -> t m (UTxOType tx)
findInOutput TestHydraClient tx m
node (t
n t -> t -> t
forall a. Num a => a -> a -> a
- t
1)
  headIsFinalized :: ServerOutput tx -> Bool
headIsFinalized = \case
    HeadIsFinalized{} -> Bool
True
    ServerOutput tx
_otherwise -> Bool
False

performCloseWithInitialSnapshot :: (MonadThrow m, MonadTimer m, MonadDelay m, MonadAsync m) => WorldState -> Party -> RunMonad m ()
performCloseWithInitialSnapshot :: forall (m :: * -> *).
(MonadThrow m, MonadTimer m, MonadDelay m, MonadAsync 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{Uncommitted
$sel:committed:Start :: GlobalState -> Uncommitted
committed :: Uncommitted
committed} -> do
      SimulatedChainNetwork{(Party, UTxOType Tx) -> m ()
closeWithInitialSnapshot :: (Party, UTxOType Tx) -> m ()
$sel:closeWithInitialSnapshot:SimulatedChainNetwork :: forall tx (m :: * -> *).
SimulatedChainNetwork tx m -> (Party, UTxOType tx) -> 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
$ (Party, UTxOType Tx) -> m ()
closeWithInitialSnapshot (Party
party, UTxOType Payment -> UTxOType Tx
toRealUTxO (UTxOType Payment -> UTxOType Tx)
-> UTxOType Payment -> UTxOType Tx
forall a b. (a -> b) -> a -> b
$ ((Party, [(CardanoSigningKey, Value)]) -> UTxOType Payment)
-> [(Party, [(CardanoSigningKey, Value)])] -> UTxOType Payment
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Party, [(CardanoSigningKey, Value)])
-> [(CardanoSigningKey, Value)]
(Party, [(CardanoSigningKey, Value)]) -> UTxOType Payment
forall a b. (a, b) -> b
snd ([(Party, [(CardanoSigningKey, Value)])] -> UTxOType Payment)
-> [(Party, [(CardanoSigningKey, Value)])] -> UTxOType Payment
forall a b. (a -> b) -> a -> b
$ Map Party [(CardanoSigningKey, Value)]
-> [(Party, [(CardanoSigningKey, Value)])]
forall k a. Map k a -> [(k, a)]
Map.toList Map Party [(CardanoSigningKey, Value)]
Uncommitted
committed)
      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] -> (ServerOutput Tx -> Bool) -> m ()
forall tx (m :: * -> *).
(Show (ServerOutput tx), HasCallStack, MonadThrow m, MonadAsync m,
 MonadTimer m) =>
[TestHydraClient tx m] -> (ServerOutput tx -> Bool) -> m ()
waitUntilMatch (Map Party (TestHydraClient Tx m) -> [TestHydraClient Tx m]
forall a. Map Party a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Map Party (TestHydraClient Tx m)
nodes) ((ServerOutput Tx -> Bool) -> m ())
-> (ServerOutput Tx -> Bool) -> m ()
forall a b. (a -> b) -> a -> b
$ \case
          HeadIsClosed{SnapshotNumber
snapshotNumber :: SnapshotNumber
$sel:snapshotNumber:PeerConnected :: 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
            SnapshotNumber
snapshotNumber SnapshotNumber -> SnapshotNumber -> Bool
forall a. Eq a => a -> a -> Bool
== Natural -> SnapshotNumber
Snapshot.UnsafeSnapshotNumber Natural
0
          err :: ServerOutput Tx
err@CommandFailed{} -> Text -> Bool
forall a t. (HasCallStack, IsText t) => t -> a
error (Text -> Bool) -> Text -> Bool
forall a b. (a -> b) -> a -> b
$ ServerOutput Tx -> Text
forall b a. (Show a, IsString b) => a -> b
show ServerOutput Tx
err
          ServerOutput Tx
_ -> Bool
False
    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

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 Era]
toTxOuts [(CardanoSigningKey, Value)]
payments =
  (CardanoSigningKey -> Value -> TxOut CtxUTxO Era)
-> (CardanoSigningKey, Value) -> TxOut CtxUTxO Era
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry CardanoSigningKey -> Value -> TxOut CtxUTxO Era
mkTxOut ((CardanoSigningKey, Value) -> TxOut CtxUTxO Era)
-> [(CardanoSigningKey, Value)] -> [TxOut CtxUTxO Era]
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 Era)] -> UTxO' (TxOut CtxUTxO Era)
forall out. [(TxIn, out)] -> UTxO' out
UTxO.fromPairs ([(TxIn, TxOut CtxUTxO Era)] -> UTxO' (TxOut CtxUTxO Era))
-> [(TxIn, TxOut CtxUTxO Era)] -> UTxO' (TxOut CtxUTxO Era)
forall a b. (a -> b) -> a -> b
$
    [ (CardanoSigningKey -> Word -> TxIn
mkMockTxIn CardanoSigningKey
sk Word
ix, CardanoSigningKey -> Value -> TxOut CtxUTxO Era
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 = ((CardanoSigningKey, Value) -> Map CardanoSigningKey [Value])
-> [(CardanoSigningKey, Value)] -> Map CardanoSigningKey [Value]
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\(CardanoSigningKey
sk, Value
v) -> CardanoSigningKey -> [Value] -> Map CardanoSigningKey [Value]
forall k a. k -> a -> Map k a
Map.singleton CardanoSigningKey
sk [Value
v]) [(CardanoSigningKey, Value)]
UTxOType Payment
paymentUTxO

mkTxOut :: CardanoSigningKey -> Value -> TxOut CtxUTxO
mkTxOut :: CardanoSigningKey -> Value -> TxOut CtxUTxO Era
mkTxOut (CardanoSigningKey SigningKey PaymentKey
sk) Value
val =
  AddressInEra
-> Value
-> TxOutDatum CtxUTxO
-> ReferenceScript
-> TxOut CtxUTxO Era
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 (SigningKey PaymentKey -> VerificationKey PaymentKey
forall keyrole.
(Key keyrole, HasTypeProxy keyrole) =>
SigningKey keyrole -> VerificationKey keyrole
getVerificationKey SigningKey PaymentKey
sk)) Value
val TxOutDatum CtxUTxO
forall ctx. TxOutDatum ctx
TxOutDatumNone ReferenceScript
ReferenceScriptNone

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

-- | Bring `Show` instance in scope drawing it from the `Action` type.
--
-- This is a neat trick to provide `show`able results from action in a context where
-- there's no explicit `Show a` instance, eg. in the `monitoring` and `postcondition`
-- functions. We don't have access to an `a` directly because its value depends on
-- type family `Realized`.
showFromAction :: (Show a => b) -> Action WorldState a -> b
showFromAction :: forall a b. (Show a => b) -> Action WorldState a -> b
showFromAction Show a => b
k = \case
  Seed{} -> b
Show a => b
k
  Init{} -> b
Show a => b
k
  Commit{} -> b
Show a => b
k
  Decommit{} -> b
Show a => b
k
  Abort{} -> b
Show a => b
k
  Close{} -> b
Show a => b
k
  Fanout{} -> b
Show a => b
k
  NewTx{} -> b
Show a => b
k
  Wait{} -> b
Show a => b
k
  ObserveConfirmedTx{} -> b
Show a => b
k
  CloseWithInitialSnapshot{} -> b
Show a => b
k
  RollbackAndForward{} -> b
Show a => b
k
  Action WorldState a
R:ActionWorldStatea a
StopTheWorld -> b
Show a => b
k
  Action WorldState a
R:ActionWorldStatea a
ObserveHeadIsOpen -> b
Show a => b
k

-- | Like '===', but works in PostconditionM.
(===) :: (Eq a, Show a, Monad m) => a -> a -> PostconditionM m Bool
a
x === :: forall a (m :: * -> *).
(Eq a, Show a, Monad m) =>
a -> a -> PostconditionM m Bool
=== a
y = do
  String -> PostconditionM m ()
forall (m :: * -> *). Monad m => String -> PostconditionM m ()
counterexamplePost (a -> String
forall b a. (Show a, IsString b) => a -> b
show a
x String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Bool -> String
forall {a}. IsString a => Bool -> a
interpret Bool
res String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> a -> String
forall b a. (Show a, IsString b) => a -> b
show a
y)
  Bool -> PostconditionM m Bool
forall a. a -> PostconditionM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
res
 where
  res :: Bool
res = a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
y
  interpret :: Bool -> a
interpret Bool
True = a
"=="
  interpret Bool
False = a
"/="

waitForUTxOToSpend ::
  forall m.
  (MonadTimer m, MonadDelay m) =>
  UTxO ->
  CardanoSigningKey ->
  Value ->
  TestHydraClient Tx m ->
  m (Either UTxO (TxIn, TxOut CtxUTxO))
waitForUTxOToSpend :: forall (m :: * -> *).
(MonadTimer m, MonadDelay m) =>
UTxO' (TxOut CtxUTxO Era)
-> CardanoSigningKey
-> Value
-> TestHydraClient Tx m
-> m (Either (UTxO' (TxOut CtxUTxO Era)) (TxIn, TxOut CtxUTxO Era))
waitForUTxOToSpend UTxO' (TxOut CtxUTxO Era)
utxo CardanoSigningKey
key Value
value TestHydraClient Tx m
node = Int
-> m (Either (UTxO' (TxOut CtxUTxO Era)) (TxIn, TxOut CtxUTxO Era))
go Int
100
 where
  go :: Int -> m (Either UTxO (TxIn, TxOut CtxUTxO))
  go :: Int
-> m (Either (UTxO' (TxOut CtxUTxO Era)) (TxIn, TxOut CtxUTxO Era))
go = \case
    Int
0 ->
      Either (UTxO' (TxOut CtxUTxO Era)) (TxIn, TxOut CtxUTxO Era)
-> m (Either (UTxO' (TxOut CtxUTxO Era)) (TxIn, TxOut CtxUTxO Era))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (UTxO' (TxOut CtxUTxO Era)) (TxIn, TxOut CtxUTxO Era)
 -> m (Either
         (UTxO' (TxOut CtxUTxO Era)) (TxIn, TxOut CtxUTxO Era)))
-> Either (UTxO' (TxOut CtxUTxO Era)) (TxIn, TxOut CtxUTxO Era)
-> m (Either (UTxO' (TxOut CtxUTxO Era)) (TxIn, TxOut CtxUTxO Era))
forall a b. (a -> b) -> a -> b
$ UTxO' (TxOut CtxUTxO Era)
-> Either (UTxO' (TxOut CtxUTxO Era)) (TxIn, TxOut CtxUTxO Era)
forall a b. a -> Either a b
Left UTxO' (TxOut CtxUTxO Era)
utxo
    Int
n -> do
      TestHydraClient Tx m
node TestHydraClient Tx m -> ClientInput Tx -> m ()
forall tx (m :: * -> *).
TestHydraClient tx m -> ClientInput tx -> m ()
`send` ClientInput Tx
forall tx. ClientInput tx
Input.GetUTxO
      DiffTime -> m ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
5
      DiffTime -> m (ServerOutput Tx) -> m (Maybe (ServerOutput Tx))
forall a. DiffTime -> m a -> m (Maybe a)
forall (m :: * -> *) a.
MonadTimer m =>
DiffTime -> m a -> m (Maybe a)
timeout DiffTime
10 (TestHydraClient Tx m -> m (ServerOutput Tx)
forall tx (m :: * -> *).
TestHydraClient tx m -> m (ServerOutput tx)
waitForNext TestHydraClient Tx m
node) m (Maybe (ServerOutput Tx))
-> (Maybe (ServerOutput Tx)
    -> m (Either
            (UTxO' (TxOut CtxUTxO Era)) (TxIn, TxOut CtxUTxO Era)))
-> m (Either (UTxO' (TxOut CtxUTxO Era)) (TxIn, TxOut CtxUTxO Era))
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 (GetUTxOResponse HeadId
_ UTxOType Tx
u)
          | UTxO' (TxOut CtxUTxO Era)
UTxOType Tx
u UTxO' (TxOut CtxUTxO Era) -> UTxO' (TxOut CtxUTxO Era) -> Bool
forall a. Eq a => a -> a -> Bool
/= UTxO' (TxOut CtxUTxO Era)
forall a. Monoid a => a
mempty ->
              m (Either (UTxO' (TxOut CtxUTxO Era)) (TxIn, TxOut CtxUTxO Era))
-> ((TxIn, TxOut CtxUTxO Era)
    -> m (Either
            (UTxO' (TxOut CtxUTxO Era)) (TxIn, TxOut CtxUTxO Era)))
-> Maybe (TxIn, TxOut CtxUTxO Era)
-> m (Either (UTxO' (TxOut CtxUTxO Era)) (TxIn, TxOut CtxUTxO Era))
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
                (Int
-> m (Either (UTxO' (TxOut CtxUTxO Era)) (TxIn, TxOut CtxUTxO Era))
go (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))
                (Either (UTxO' (TxOut CtxUTxO Era)) (TxIn, TxOut CtxUTxO Era)
-> m (Either (UTxO' (TxOut CtxUTxO Era)) (TxIn, TxOut CtxUTxO Era))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (UTxO' (TxOut CtxUTxO Era)) (TxIn, TxOut CtxUTxO Era)
 -> m (Either
         (UTxO' (TxOut CtxUTxO Era)) (TxIn, TxOut CtxUTxO Era)))
-> ((TxIn, TxOut CtxUTxO Era)
    -> Either (UTxO' (TxOut CtxUTxO Era)) (TxIn, TxOut CtxUTxO Era))
-> (TxIn, TxOut CtxUTxO Era)
-> m (Either (UTxO' (TxOut CtxUTxO Era)) (TxIn, TxOut CtxUTxO Era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxIn, TxOut CtxUTxO Era)
-> Either (UTxO' (TxOut CtxUTxO Era)) (TxIn, TxOut CtxUTxO Era)
forall a b. b -> Either a b
Right)
                (((TxIn, TxOut CtxUTxO Era) -> Bool)
-> [(TxIn, TxOut CtxUTxO Era)] -> Maybe (TxIn, TxOut CtxUTxO Era)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (TxIn, TxOut CtxUTxO Era) -> Bool
matchPayment (UTxO' (TxOut CtxUTxO Era) -> [(TxIn, TxOut CtxUTxO Era)]
forall out. UTxO' out -> [(TxIn, out)]
UTxO.pairs UTxO' (TxOut CtxUTxO Era)
UTxOType Tx
u))
        Maybe (ServerOutput Tx)
_ -> Int
-> m (Either (UTxO' (TxOut CtxUTxO Era)) (TxIn, TxOut CtxUTxO Era))
go (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)

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

isOwned :: CardanoSigningKey -> (TxIn, TxOut ctx) -> Bool
isOwned :: forall ctx. CardanoSigningKey -> (TxIn, TxOut ctx) -> Bool
isOwned (CardanoSigningKey SigningKey PaymentKey
sk) (TxIn
_, TxOut{txOutAddress :: forall ctx. TxOut ctx -> AddressInEra
txOutAddress = ShelleyAddressInEra (ShelleyAddress Network
_ PaymentCredential StandardCrypto
cre StakeReference StandardCrypto
_)}) =
  case PaymentCredential StandardCrypto -> PaymentCredential
fromShelleyPaymentCredential PaymentCredential StandardCrypto
cre of
    (PaymentCredentialByKey Hash PaymentKey
ha) -> VerificationKey PaymentKey -> Hash PaymentKey
forall keyrole.
Key keyrole =>
VerificationKey keyrole -> Hash keyrole
verificationKeyHash (SigningKey PaymentKey -> VerificationKey PaymentKey
forall keyrole.
(Key keyrole, HasTypeProxy keyrole) =>
SigningKey keyrole -> VerificationKey keyrole
getVerificationKey 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