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

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

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

import Cardano.Api.UTxO qualified as UTxO
import Cardano.Binary (serialize', unsafeDeserialize')
import Control.Concurrent.Class.MonadSTM (
  modifyTVar,
  readTVarIO,
  retry,
 )
import Control.Monad.Class.MonadAsync (cancel, link)
import Data.List (nub, (\\))
import Data.List qualified as List
import Data.Map.Strict ((!))
import Data.Map.Strict qualified as Map
import Data.Set qualified as Set
import GHC.IsList (IsList (..))
import GHC.Natural (wordToNatural)
import Hydra.API.ClientInput (ClientInput)
import Hydra.API.ClientInput qualified as Input
import Hydra.API.ServerOutput (ServerOutput (..))
import Hydra.BehaviorSpec (
  SimulatedChainNetwork (..),
  TestHydraClient (..),
  createHydraNode,
  createTestHydraClient,
  getHeadUTxO,
  shortLabel,
  waitUntilMatch,
 )
import Hydra.Chain (maximumNumberOfParties)
import Hydra.Chain.Direct.State (initialChainState)
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 (HydraNode (..), NodeStateHandler (..), runHydraNode)
import Hydra.Node.State (NodeState (..))
import Hydra.Options (defaultDepositPeriod)
import Hydra.Tx (HeadId)
import Hydra.Tx.ContestationPeriod (ContestationPeriod (..))
import Hydra.Tx.Crypto (HydraKey, getVerificationKey)
import Hydra.Tx.DepositPeriod (DepositPeriod (..))
import Hydra.Tx.HeadParameters (HeadParameters (..))
import Hydra.Tx.IsTx (IsTx (..))
import Hydra.Tx.Party (Party (..), deriveParty)
import Hydra.Tx.Secret (Secret, mkSecret)
import Hydra.Tx.Snapshot qualified as Snapshot
import Test.Hydra.Node.Fixture (defaultGlobals, defaultLedgerEnv, testNetworkId)
import Test.Hydra.Tx.Gen (genSigningKey)
import Test.QuickCheck (choose, chooseEnum, discard, elements, frequency, listOf, resize, sized, sublistOf, tabulate, vectorOf)
import Test.QuickCheck.DynamicLogic (DynLogicModel)
import Test.QuickCheck.StateModel (Any (..), HasVariables, PostconditionM, Realized, RunModel (..), StateModel (..), Var, VarContext, counterexamplePost)
import Test.QuickCheck.StateModel.Variables (HasVariables (..))
import Prelude qualified

-- * The Model

-- | State maintained by the model.
data WorldState = WorldState
  { WorldState -> [(Secret (SigningKey HydraKey), CardanoSigningKey)]
hydraParties :: [(Secret (SigningKey HydraKey), CardanoSigningKey)]
  -- ^ List of parties identified by both signing keys required to run protocol.
  -- This list must not contain any duplicated key.
  , WorldState -> GlobalState
hydraState :: GlobalState
  -- ^ Expected consensus state
  -- All nodes should be in the same state.
  , WorldState -> UTxOType Payment
availableToDeposit :: UTxOType Payment
  -- ^ UTxO available to be committed incrementally. NOTE: We must not add UTxO
  -- we decommitted to this as the 'Payment' transaction model results in
  -- non-unique transaction ids when running the model.
  -- NOTE: Deposits are not randomly generated in 'anyActions_' — they are only
  -- performed explicitly in scripted tests (e.g. 'propFanoutLimit'). Adding
  -- real support for random deposit actions is left for the future.
  }
  deriving stock (WorldState -> WorldState -> Bool
(WorldState -> WorldState -> Bool)
-> (WorldState -> WorldState -> Bool) -> Eq WorldState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: WorldState -> WorldState -> Bool
== :: WorldState -> WorldState -> Bool
$c/= :: WorldState -> WorldState -> Bool
/= :: WorldState -> WorldState -> Bool
Eq, Int -> WorldState -> ShowS
[WorldState] -> ShowS
WorldState -> String
(Int -> WorldState -> ShowS)
-> (WorldState -> String)
-> ([WorldState] -> ShowS)
-> Show WorldState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> WorldState -> ShowS
showsPrec :: Int -> WorldState -> ShowS
$cshow :: WorldState -> String
show :: WorldState -> String
$cshowList :: [WorldState] -> ShowS
showList :: [WorldState] -> ShowS
Show)

-- | Global state of the Head protocol.
-- While each participant in the Hydra Head protocol has its own private
-- view of the state, we model the expected global state whose properties
-- stem from the consensus built into the Head protocol. In other words, this
-- state is what each node's local state should be /eventually/.
data GlobalState
  = -- | Start of the "world".
    --  This state is left implicit in the node's logic as it
    --  represents that state where the node does not even
    --  exist.
    Start
  | Idle
      { GlobalState -> [Party]
idleParties :: [Party]
      , GlobalState -> [VerificationKey PaymentKey]
cardanoKeys :: [VerificationKey PaymentKey]
      , GlobalState -> ContestationPeriod
contestationPeriod :: ContestationPeriod
      }
  | Open
      { GlobalState -> Var HeadId
headIdVar :: Var HeadId
      , GlobalState -> HeadParameters
headParameters :: HeadParameters
      , GlobalState -> OffChainState
offChainState :: OffChainState
      , -- TODO: keep a single UTxOType Payment instead?
        GlobalState -> Map Party (UTxOType Payment)
committed :: Map Party (UTxOType Payment)
      }
  | 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)

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

-- | Basic instantiation of `StateModel` for our `WorldState` state.
instance StateModel WorldState where
  -- The list of possible "Actions" within our `Model`
  -- Not all of them need to actually represent an actual user `Action`, but they
  -- can represent _observations_ which are useful when defining properties in
  -- DL. Those observations would usually not be generated.
  data Action WorldState a where
    Seed ::
      { Action WorldState ()
-> [(Secret (SigningKey HydraKey), CardanoSigningKey)]
seedKeys :: [(Secret (SigningKey HydraKey), CardanoSigningKey)]
      , Action WorldState () -> ContestationPeriod
contestationPeriod :: ContestationPeriod
      , Action WorldState () -> UTxOType Payment
additionalUTxO :: UTxOType Payment
      } ->
      Action WorldState ()
    Init :: Party -> Action WorldState HeadId
    Deposit :: {Action WorldState () -> Var HeadId
headIdVar :: Var HeadId, Action WorldState () -> UTxOType Payment
utxoToDeposit :: UTxOType Payment} -> Action WorldState ()
    Decommit :: {Action WorldState () -> Party
party :: Party, Action WorldState () -> Payment
decommitTx :: Payment} -> Action WorldState ()
    Close :: {party :: Party} -> Action WorldState ()
    -- NOTE: No records possible here as we would duplicate 'Party' fields with
    -- different return values.
    Fanout :: Party -> Action WorldState UTxO
    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 :: [(Secret (SigningKey HydraKey), CardanoSigningKey)]
hydraParties = [(Secret (SigningKey HydraKey), CardanoSigningKey)]
forall a. Monoid a => a
mempty
      , $sel:hydraState:WorldState :: GlobalState
hydraState = GlobalState
Start
      , $sel:availableToDeposit:WorldState :: UTxOType Payment
availableToDeposit = [(CardanoSigningKey, Value)]
UTxOType Payment
forall a. Monoid a => a
mempty
      }

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

    genDeposit :: Var HeadId -> Gen (Any (Action WorldState))
genDeposit Var HeadId
headIdVar = do
      CardanoSigningKey
sk <- (Secret (SigningKey HydraKey), CardanoSigningKey)
-> CardanoSigningKey
forall a b. (a, b) -> b
snd ((Secret (SigningKey HydraKey), CardanoSigningKey)
 -> CardanoSigningKey)
-> Gen (Secret (SigningKey HydraKey), CardanoSigningKey)
-> Gen CardanoSigningKey
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Secret (SigningKey HydraKey), CardanoSigningKey)]
-> Gen (Secret (SigningKey HydraKey), CardanoSigningKey)
forall a. HasCallStack => [a] -> Gen a
elements [(Secret (SigningKey HydraKey), CardanoSigningKey)]
hydraParties
      [(CardanoSigningKey, Value)]
utxoToDeposit <- [(CardanoSigningKey, Value)] -> Gen [(CardanoSigningKey, Value)]
forall a. [a] -> Gen [a]
sublistOf ([(CardanoSigningKey, Value)] -> Gen [(CardanoSigningKey, Value)])
-> [(CardanoSigningKey, Value)] -> Gen [(CardanoSigningKey, Value)]
forall a b. (a -> b) -> a -> b
$ ((CardanoSigningKey, Value) -> Bool)
-> [(CardanoSigningKey, Value)] -> [(CardanoSigningKey, Value)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((CardanoSigningKey
sk ==) (CardanoSigningKey -> Bool)
-> ((CardanoSigningKey, Value) -> CardanoSigningKey)
-> (CardanoSigningKey, Value)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CardanoSigningKey, Value) -> CardanoSigningKey
forall a b. (a, b) -> a
fst) [(CardanoSigningKey, Value)]
UTxOType Payment
availableToDeposit
      Any (Action WorldState) -> Gen (Any (Action WorldState))
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Any (Action WorldState) -> Gen (Any (Action WorldState)))
-> Any (Action WorldState) -> Gen (Any (Action WorldState))
forall a b. (a -> b) -> a -> b
$ Action WorldState () -> Any (Action WorldState)
forall a (f :: * -> *). (Typeable a, Eq (f a)) => f a -> Any f
Some Deposit{Var HeadId
$sel:headIdVar:Seed :: Var HeadId
headIdVar :: Var HeadId
headIdVar, [(CardanoSigningKey, Value)]
UTxOType Payment
$sel:utxoToDeposit:Seed :: UTxOType Payment
utxoToDeposit :: [(CardanoSigningKey, Value)]
utxoToDeposit}

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

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

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

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

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

  precondition :: forall a. WorldState -> Action WorldState a -> Bool
precondition WorldState{$sel:hydraState:WorldState :: WorldState -> GlobalState
hydraState = GlobalState
Start} Seed{} =
    Bool
True
  precondition WorldState{$sel:hydraState:WorldState :: WorldState -> GlobalState
hydraState = Idle{[Party]
$sel:idleParties:Start :: GlobalState -> [Party]
idleParties :: [Party]
idleParties}} (Init Party
p) =
    Party
p Party -> [Party] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` [Party]
idleParties
  precondition WorldState{$sel:hydraState:WorldState :: WorldState -> GlobalState
hydraState = Open{HeadParameters
$sel:headParameters:Start :: GlobalState -> HeadParameters
headParameters :: HeadParameters
headParameters}} Close{Party
$sel:party:Seed :: Action WorldState () -> Party
party :: Party
party} =
    Party
party Party -> [Party] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` HeadParameters
headParameters.parties
  precondition WorldState{$sel:hydraState:WorldState :: WorldState -> GlobalState
hydraState = Open{HeadParameters
$sel:headParameters:Start :: GlobalState -> HeadParameters
headParameters :: HeadParameters
headParameters, OffChainState
$sel:offChainState:Start :: GlobalState -> OffChainState
offChainState :: OffChainState
offChainState}} (NewTx Party
party Payment
tx) =
    Party
party Party -> [Party] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` HeadParameters
headParameters.parties
      Bool -> Bool -> Bool
&& (Payment -> CardanoSigningKey
from Payment
tx, Payment -> Value
value Payment
tx) (CardanoSigningKey, Value) -> [(CardanoSigningKey, Value)] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`List.elem` OffChainState -> UTxOType Payment
confirmedUTxO OffChainState
offChainState
  precondition WorldState
_ Wait{} =
    Bool
True
  precondition WorldState{$sel:hydraState:WorldState :: WorldState -> GlobalState
hydraState = Open{Var HeadId
$sel:headIdVar:Start :: GlobalState -> Var HeadId
headIdVar :: Var HeadId
headIdVar}} Deposit{$sel:headIdVar:Seed :: Action WorldState () -> Var HeadId
headIdVar = Var HeadId
var} =
    Var HeadId
var Var HeadId -> Var HeadId -> Bool
forall a. Eq a => a -> a -> Bool
== Var HeadId
headIdVar
  precondition WorldState{$sel:hydraState:WorldState :: WorldState -> GlobalState
hydraState = Open{HeadParameters
$sel:headParameters:Start :: GlobalState -> HeadParameters
headParameters :: HeadParameters
headParameters, OffChainState
$sel:offChainState:Start :: GlobalState -> OffChainState
offChainState :: OffChainState
offChainState}} Decommit{Party
$sel:party:Seed :: Action WorldState () -> Party
party :: Party
party, Payment
$sel:decommitTx:Seed :: Action WorldState () -> Payment
decommitTx :: Payment
decommitTx} =
    Party
party Party -> [Party] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` HeadParameters
headParameters.parties
      Bool -> Bool -> Bool
&& (Payment -> CardanoSigningKey
from Payment
decommitTx, Payment -> Value
value Payment
decommitTx) (CardanoSigningKey, Value) -> [(CardanoSigningKey, Value)] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`List.elem` OffChainState -> UTxOType Payment
confirmedUTxO OffChainState
offChainState
  precondition WorldState{$sel:hydraState:WorldState :: WorldState -> GlobalState
hydraState = Open{}} (ObserveConfirmedTx Var Payment
_) =
    Bool
True
  precondition WorldState{$sel:hydraState:WorldState :: WorldState -> GlobalState
hydraState = Open{}} Action WorldState a
R:ActionWorldStatea a
ObserveHeadIsOpen =
    Bool
True
  precondition WorldState{$sel:hydraState:WorldState :: WorldState -> GlobalState
hydraState = Closed{HeadParameters
$sel:headParameters:Start :: GlobalState -> HeadParameters
headParameters :: HeadParameters
headParameters}} (Fanout Party
party) =
    Party
party Party -> [Party] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` HeadParameters
headParameters.parties
  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
      Open{} -> Bool
True
      Closed{} -> Bool
True
      Final{} -> Bool
False
  precondition WorldState
_ Action WorldState a
R:ActionWorldStatea a
StopTheWorld =
    Bool
True
  precondition WorldState
_ Action WorldState a
_ =
    Bool
False

  nextState :: forall a.
Typeable a =>
WorldState -> Action WorldState a -> Var a -> WorldState
nextState s :: WorldState
s@WorldState{GlobalState
$sel:hydraState:WorldState :: WorldState -> GlobalState
hydraState :: GlobalState
hydraState, UTxOType Payment
$sel:availableToDeposit:WorldState :: WorldState -> UTxOType Payment
availableToDeposit :: UTxOType Payment
availableToDeposit} Action WorldState a
a Var a
result =
    case Action WorldState a
a of
      Seed{[(Secret (SigningKey HydraKey), CardanoSigningKey)]
$sel:seedKeys:Seed :: Action WorldState ()
-> [(Secret (SigningKey HydraKey), CardanoSigningKey)]
seedKeys :: [(Secret (SigningKey HydraKey), CardanoSigningKey)]
seedKeys, ContestationPeriod
$sel:contestationPeriod:Seed :: Action WorldState () -> ContestationPeriod
contestationPeriod :: ContestationPeriod
contestationPeriod} ->
        WorldState
s{hydraParties = seedKeys, hydraState = 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:contestationPeriod:Start :: ContestationPeriod
contestationPeriod :: ContestationPeriod
contestationPeriod}
        idleParties :: [Party]
idleParties = ((Secret (SigningKey HydraKey), CardanoSigningKey) -> Party)
-> [(Secret (SigningKey HydraKey), CardanoSigningKey)] -> [Party]
forall a b. (a -> b) -> [a] -> [b]
map (Secret (SigningKey HydraKey) -> Party
deriveParty (Secret (SigningKey HydraKey) -> Party)
-> ((Secret (SigningKey HydraKey), CardanoSigningKey)
    -> Secret (SigningKey HydraKey))
-> (Secret (SigningKey HydraKey), CardanoSigningKey)
-> Party
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Secret (SigningKey HydraKey), CardanoSigningKey)
-> Secret (SigningKey HydraKey)
forall a b. (a, b) -> a
fst) [(Secret (SigningKey HydraKey), CardanoSigningKey)]
seedKeys
        cardanoKeys :: [VerificationKey PaymentKey]
cardanoKeys = ((Secret (SigningKey HydraKey), CardanoSigningKey)
 -> VerificationKey PaymentKey)
-> [(Secret (SigningKey HydraKey), CardanoSigningKey)]
-> [VerificationKey PaymentKey]
forall a b. (a -> b) -> [a] -> [b]
map (\(Secret (SigningKey HydraKey)
_, CardanoSigningKey Secret (SigningKey PaymentKey)
sk) -> Secret (SigningKey PaymentKey) -> VerificationKey PaymentKey
forall s k. HasVerificationKey s k => s -> VerificationKey k
getVerificationKey Secret (SigningKey PaymentKey)
sk) [(Secret (SigningKey HydraKey), CardanoSigningKey)]
seedKeys
      Init{} ->
        WorldState
s{hydraState = mkInitialState hydraState}
       where
        mkInitialState :: GlobalState -> GlobalState
mkInitialState = \case
          Idle{[Party]
$sel:idleParties:Start :: GlobalState -> [Party]
idleParties :: [Party]
idleParties, ContestationPeriod
$sel:contestationPeriod:Start :: GlobalState -> ContestationPeriod
contestationPeriod :: ContestationPeriod
contestationPeriod} ->
            Open
              { $sel:headIdVar:Start :: Var HeadId
headIdVar = Var a
Var HeadId
result
              , $sel:headParameters:Start :: HeadParameters
headParameters =
                  HeadParameters
                    { $sel:parties:HeadParameters :: [Party]
parties = [Party]
idleParties
                    , $sel:contestationPeriod:HeadParameters :: ContestationPeriod
contestationPeriod = ContestationPeriod
contestationPeriod
                    , $sel:depositPeriod:HeadParameters :: DepositPeriod
depositPeriod = DepositPeriod
defaultDepositPeriod
                    }
              , $sel:offChainState:Start :: OffChainState
offChainState = OffChainState{$sel:confirmedUTxO:OffChainState :: UTxOType Payment
confirmedUTxO = [(CardanoSigningKey, Value)]
UTxOType Payment
forall a. Monoid a => a
mempty}
              , $sel:committed:Start :: Map Party (UTxOType Payment)
committed = Map Party [(CardanoSigningKey, Value)]
Map Party (UTxOType Payment)
forall a. Monoid a => a
mempty
              }
          GlobalState
_ -> Text -> GlobalState
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"unexpected state"
      Deposit{UTxOType Payment
$sel:utxoToDeposit:Seed :: Action WorldState () -> UTxOType Payment
utxoToDeposit :: UTxOType Payment
utxoToDeposit} ->
        WorldState
s
          { hydraState = updateWithIncrementalCommit hydraState
          , availableToDeposit = availableToDeposit \\ utxoToDeposit
          }
       where
        updateWithIncrementalCommit :: GlobalState -> GlobalState
updateWithIncrementalCommit = \case
          hs :: GlobalState
hs@Open{$sel:offChainState:Start :: GlobalState -> OffChainState
offChainState = OffChainState{UTxOType Payment
$sel:confirmedUTxO:OffChainState :: OffChainState -> UTxOType Payment
confirmedUTxO :: UTxOType Payment
confirmedUTxO}} ->
            GlobalState
hs
              { offChainState =
                  OffChainState{confirmedUTxO = utxoToDeposit <> confirmedUTxO}
              }
          GlobalState
_ -> Text -> GlobalState
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"unexpected state"
      Decommit Party
_party Payment
tx ->
        WorldState
s{hydraState = updateWithDecommit hydraState}
       where
        decommitted :: (CardanoSigningKey, Value)
decommitted = (Payment -> CardanoSigningKey
from Payment
tx, Payment -> Value
value Payment
tx)

        updateWithDecommit :: GlobalState -> GlobalState
updateWithDecommit = \case
          hs :: GlobalState
hs@Open{$sel:offChainState:Start :: GlobalState -> OffChainState
offChainState = OffChainState{UTxOType Payment
$sel:confirmedUTxO:OffChainState :: OffChainState -> UTxOType Payment
confirmedUTxO :: UTxOType Payment
confirmedUTxO}} ->
            GlobalState
hs
              { offChainState =
                  OffChainState{confirmedUTxO = List.delete decommitted confirmedUTxO}
              }
          GlobalState
_ -> Text -> GlobalState
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"unexpected state"
      Close{} ->
        WorldState
s{hydraState = updateWithClose 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
s{hydraState = updateWithFanout 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
s{hydraState = updateWithNewTx hydraState}
       where
        updateWithNewTx :: GlobalState -> GlobalState
updateWithNewTx = \case
          hs :: GlobalState
hs@Open{$sel:offChainState:Start :: GlobalState -> OffChainState
offChainState = OffChainState{UTxOType Payment
$sel:confirmedUTxO:OffChainState :: OffChainState -> UTxOType Payment
confirmedUTxO :: UTxOType Payment
confirmedUTxO}} ->
            GlobalState
hs
              { offChainState =
                  OffChainState
                    { confirmedUTxO = confirmedUTxO `applyTx` tx
                    }
              }
          GlobalState
_ -> Text -> GlobalState
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"unexpected state"
      CloseWithInitialSnapshot Party
_ ->
        WorldState
s{hydraState = updateWithClose 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{[(Secret (SigningKey HydraKey), CardanoSigningKey)]
$sel:seedKeys:Seed :: Action WorldState ()
-> [(Secret (SigningKey HydraKey), CardanoSigningKey)]
seedKeys :: [(Secret (SigningKey HydraKey), CardanoSigningKey)]
seedKeys, UTxOType Payment
$sel:additionalUTxO:Seed :: Action WorldState () -> UTxOType Payment
additionalUTxO :: UTxOType Payment
additionalUTxO} -> do
      [(Secret (SigningKey HydraKey), CardanoSigningKey)]
seedKeys' <- [(Secret (SigningKey HydraKey), CardanoSigningKey)]
-> [[(Secret (SigningKey HydraKey), CardanoSigningKey)]]
forall a. Arbitrary a => a -> [a]
shrink [(Secret (SigningKey HydraKey), CardanoSigningKey)]
seedKeys
      Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> [()]) -> Bool -> [()]
forall a b. (a -> b) -> a -> b
$ [(Secret (SigningKey HydraKey), CardanoSigningKey)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Secret (SigningKey HydraKey), CardanoSigningKey)]
seedKeys' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< [(Secret (SigningKey HydraKey), CardanoSigningKey)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Secret (SigningKey HydraKey), CardanoSigningKey)]
seedKeys
      let cardanoKeys' :: [CardanoSigningKey]
cardanoKeys' = (Secret (SigningKey HydraKey), CardanoSigningKey)
-> CardanoSigningKey
forall a b. (a, b) -> b
snd ((Secret (SigningKey HydraKey), CardanoSigningKey)
 -> CardanoSigningKey)
-> [(Secret (SigningKey HydraKey), CardanoSigningKey)]
-> [CardanoSigningKey]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Secret (SigningKey HydraKey), CardanoSigningKey)]
seedKeys'
      Any (Action WorldState) -> [Any (Action WorldState)]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Any (Action WorldState) -> [Any (Action WorldState)])
-> Any (Action WorldState) -> [Any (Action WorldState)]
forall a b. (a -> b) -> a -> b
$ Action WorldState () -> Any (Action WorldState)
forall a (f :: * -> *). (Typeable a, Eq (f a)) => f a -> Any f
Some (Action WorldState () -> Any (Action WorldState))
-> Action WorldState () -> Any (Action WorldState)
forall a b. (a -> b) -> a -> b
$ Action WorldState a
seed{seedKeys = seedKeys', additionalUTxO = filter ((`elem` cardanoKeys') . fst) additionalUTxO}
    Action WorldState a
_other -> []

instance HasVariables WorldState where
  getAllVariables :: WorldState -> Set (Any Var)
getAllVariables WorldState{GlobalState
$sel:hydraState:WorldState :: WorldState -> GlobalState
hydraState :: GlobalState
hydraState} = case GlobalState
hydraState of
    Open{Var HeadId
$sel:headIdVar:Start :: GlobalState -> Var HeadId
headIdVar :: Var HeadId
headIdVar} -> Any Var -> Set (Any Var)
forall a. a -> Set a
Set.singleton (Any Var -> Set (Any Var)) -> Any Var -> Set (Any Var)
forall a b. (a -> b) -> a -> b
$ Var HeadId -> Any Var
forall a (f :: * -> *). (Typeable a, Eq (f a)) => f a -> Any f
Some Var HeadId
headIdVar
    GlobalState
_ -> Set (Any Var)
forall a. Monoid a => a
mempty

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

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

-- ** Generator Helper

genSeed :: Gen (Action WorldState ())
genSeed :: Gen (Action WorldState ())
genSeed = do
  [(Secret (SigningKey HydraKey), CardanoSigningKey)]
seedKeys <- Int
-> Gen [(Secret (SigningKey HydraKey), CardanoSigningKey)]
-> Gen [(Secret (SigningKey HydraKey), CardanoSigningKey)]
forall a. HasCallStack => Int -> Gen a -> Gen a
resize Int
maximumNumberOfParties Gen [(Secret (SigningKey HydraKey), CardanoSigningKey)]
partyKeys
  ContestationPeriod
contestationPeriod <- Gen ContestationPeriod
genContestationPeriod
  [(CardanoSigningKey, Value)]
additionalUTxO <- Gen (CardanoSigningKey, Value) -> Gen [(CardanoSigningKey, Value)]
forall a. Gen a -> Gen [a]
listOf (Gen (CardanoSigningKey, Value)
 -> Gen [(CardanoSigningKey, Value)])
-> Gen (CardanoSigningKey, Value)
-> Gen [(CardanoSigningKey, Value)]
forall a b. (a -> b) -> a -> b
$ do
    CardanoSigningKey
sk <- (Secret (SigningKey HydraKey), CardanoSigningKey)
-> CardanoSigningKey
forall a b. (a, b) -> b
snd ((Secret (SigningKey HydraKey), CardanoSigningKey)
 -> CardanoSigningKey)
-> Gen (Secret (SigningKey HydraKey), CardanoSigningKey)
-> Gen CardanoSigningKey
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Secret (SigningKey HydraKey), CardanoSigningKey)]
-> Gen (Secret (SigningKey HydraKey), CardanoSigningKey)
forall a. HasCallStack => [a] -> Gen a
elements [(Secret (SigningKey HydraKey), CardanoSigningKey)]
seedKeys
    Value
value <- Gen Value
genAdaValue
    (CardanoSigningKey, Value) -> Gen (CardanoSigningKey, Value)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CardanoSigningKey
sk, Value
value)
  Action WorldState () -> Gen (Action WorldState ())
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Action WorldState () -> Gen (Action WorldState ()))
-> Action WorldState () -> Gen (Action WorldState ())
forall a b. (a -> b) -> a -> b
$ Seed{[(Secret (SigningKey HydraKey), CardanoSigningKey)]
$sel:seedKeys:Seed :: [(Secret (SigningKey HydraKey), CardanoSigningKey)]
seedKeys :: [(Secret (SigningKey HydraKey), CardanoSigningKey)]
seedKeys, ContestationPeriod
$sel:contestationPeriod:Seed :: ContestationPeriod
contestationPeriod :: ContestationPeriod
contestationPeriod, [(CardanoSigningKey, Value)]
UTxOType Payment
$sel:additionalUTxO:Seed :: UTxOType Payment
additionalUTxO :: [(CardanoSigningKey, Value)]
additionalUTxO}

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

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

genPayment :: WorldState -> Gen (Party, Payment)
genPayment :: WorldState -> Gen (Party, Payment)
genPayment WorldState{[(Secret (SigningKey HydraKey), CardanoSigningKey)]
$sel:hydraParties:WorldState :: WorldState -> [(Secret (SigningKey HydraKey), CardanoSigningKey)]
hydraParties :: [(Secret (SigningKey HydraKey), CardanoSigningKey)]
hydraParties, GlobalState
$sel:hydraState:WorldState :: WorldState -> GlobalState
hydraState :: GlobalState
hydraState} =
  case GlobalState
hydraState of
    Open{$sel:offChainState:Start :: GlobalState -> OffChainState
offChainState = OffChainState{UTxOType Payment
$sel:confirmedUTxO:OffChainState :: OffChainState -> UTxOType Payment
confirmedUTxO :: UTxOType Payment
confirmedUTxO}} -> do
      let spendable :: [(CardanoSigningKey, Value, Party)]
spendable =
            ((CardanoSigningKey, Value)
 -> Maybe (CardanoSigningKey, Value, Party))
-> [(CardanoSigningKey, Value)]
-> [(CardanoSigningKey, Value, Party)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
              ( \(CardanoSigningKey
from, Value
value) ->
                  (CardanoSigningKey
from,Value
value,) (Party -> (CardanoSigningKey, Value, Party))
-> ((Secret (SigningKey HydraKey), CardanoSigningKey) -> Party)
-> (Secret (SigningKey HydraKey), CardanoSigningKey)
-> (CardanoSigningKey, Value, Party)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Secret (SigningKey HydraKey) -> Party
deriveParty (Secret (SigningKey HydraKey) -> Party)
-> ((Secret (SigningKey HydraKey), CardanoSigningKey)
    -> Secret (SigningKey HydraKey))
-> (Secret (SigningKey HydraKey), CardanoSigningKey)
-> Party
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Secret (SigningKey HydraKey), CardanoSigningKey)
-> Secret (SigningKey HydraKey)
forall a b. (a, b) -> a
fst ((Secret (SigningKey HydraKey), CardanoSigningKey)
 -> (CardanoSigningKey, Value, Party))
-> Maybe (Secret (SigningKey HydraKey), CardanoSigningKey)
-> Maybe (CardanoSigningKey, Value, Party)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Secret (SigningKey HydraKey), CardanoSigningKey) -> Bool)
-> [(Secret (SigningKey HydraKey), CardanoSigningKey)]
-> Maybe (Secret (SigningKey HydraKey), CardanoSigningKey)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find ((CardanoSigningKey -> CardanoSigningKey -> Bool
forall a. Eq a => a -> a -> Bool
== CardanoSigningKey
from) (CardanoSigningKey -> Bool)
-> ((Secret (SigningKey HydraKey), CardanoSigningKey)
    -> CardanoSigningKey)
-> (Secret (SigningKey HydraKey), CardanoSigningKey)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Secret (SigningKey HydraKey), CardanoSigningKey)
-> CardanoSigningKey
forall a b. (a, b) -> b
snd) [(Secret (SigningKey HydraKey), CardanoSigningKey)]
hydraParties
              )
              ([(CardanoSigningKey, Value)]
 -> [(CardanoSigningKey, Value, Party)])
-> [(CardanoSigningKey, Value)]
-> [(CardanoSigningKey, Value, Party)]
forall a b. (a -> b) -> a -> b
$ ((CardanoSigningKey, Value) -> Bool)
-> [(CardanoSigningKey, Value)] -> [(CardanoSigningKey, Value)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ((CardanoSigningKey, Value) -> Bool)
-> (CardanoSigningKey, Value)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(AssetId, Quantity)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([(AssetId, Quantity)] -> Bool)
-> ((CardanoSigningKey, Value) -> [(AssetId, Quantity)])
-> (CardanoSigningKey, Value)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> [(AssetId, Quantity)]
Value -> [Item Value]
forall l. IsList l => l -> [Item l]
toList (Value -> [(AssetId, Quantity)])
-> ((CardanoSigningKey, Value) -> Value)
-> (CardanoSigningKey, Value)
-> [(AssetId, Quantity)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CardanoSigningKey, Value) -> Value
forall a b. (a, b) -> b
snd) [(CardanoSigningKey, Value)]
UTxOType Payment
confirmedUTxO
      case [(CardanoSigningKey, Value, Party)]
spendable of
        [] -> Gen (Party, Payment)
forall a. a
discard
        [(CardanoSigningKey, Value, Party)]
_ -> do
          (CardanoSigningKey
from, Value
value, Party
party) <- [(CardanoSigningKey, Value, Party)]
-> Gen (CardanoSigningKey, Value, Party)
forall a. HasCallStack => [a] -> Gen a
elements [(CardanoSigningKey, Value, Party)]
spendable
          -- NOTE: It's perfectly possible this yields a payment to self and it
          -- assumes hydraParties is not empty else `elements` will crash
          (Secret (SigningKey HydraKey)
_, CardanoSigningKey
to) <- [(Secret (SigningKey HydraKey), CardanoSigningKey)]
-> Gen (Secret (SigningKey HydraKey), CardanoSigningKey)
forall a. HasCallStack => [a] -> Gen a
elements [(Secret (SigningKey HydraKey), CardanoSigningKey)]
hydraParties
          (Party, Payment) -> Gen (Party, Payment)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Party
party, Payment{CardanoSigningKey
$sel:from:Payment :: CardanoSigningKey
from :: CardanoSigningKey
from, CardanoSigningKey
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 [(Secret (SigningKey HydraKey), CardanoSigningKey)]
partyKeys :: Gen [(Secret (SigningKey HydraKey), CardanoSigningKey)]
partyKeys =
  (Int -> Gen [(Secret (SigningKey HydraKey), CardanoSigningKey)])
-> Gen [(Secret (SigningKey HydraKey), CardanoSigningKey)]
forall a. (Int -> Gen a) -> Gen a
sized ((Int -> Gen [(Secret (SigningKey HydraKey), CardanoSigningKey)])
 -> Gen [(Secret (SigningKey HydraKey), CardanoSigningKey)])
-> (Int -> Gen [(Secret (SigningKey HydraKey), CardanoSigningKey)])
-> Gen [(Secret (SigningKey HydraKey), CardanoSigningKey)]
forall a b. (a -> b) -> a -> b
$ \Int
len -> do
    Int
numParties <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
1, Int
len)
    [Secret (SigningKey HydraKey)]
hks <- [Secret (SigningKey HydraKey)] -> [Secret (SigningKey HydraKey)]
forall a. Eq a => [a] -> [a]
nub ([Secret (SigningKey HydraKey)] -> [Secret (SigningKey HydraKey)])
-> Gen [Secret (SigningKey HydraKey)]
-> Gen [Secret (SigningKey HydraKey)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int
-> Gen (Secret (SigningKey HydraKey))
-> Gen [Secret (SigningKey HydraKey)]
forall a. Int -> Gen a -> Gen [a]
vectorOf Int
numParties Gen (Secret (SigningKey HydraKey))
forall a. Arbitrary a => Gen a
arbitrary
    [CardanoSigningKey]
cks <- [CardanoSigningKey] -> [CardanoSigningKey]
forall a. Eq a => [a] -> [a]
nub ([CardanoSigningKey] -> [CardanoSigningKey])
-> ([SigningKey PaymentKey] -> [CardanoSigningKey])
-> [SigningKey PaymentKey]
-> [CardanoSigningKey]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SigningKey PaymentKey -> CardanoSigningKey)
-> [SigningKey PaymentKey] -> [CardanoSigningKey]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Secret (SigningKey PaymentKey) -> CardanoSigningKey
CardanoSigningKey (Secret (SigningKey PaymentKey) -> CardanoSigningKey)
-> (SigningKey PaymentKey -> Secret (SigningKey PaymentKey))
-> SigningKey PaymentKey
-> CardanoSigningKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SigningKey PaymentKey -> Secret (SigningKey PaymentKey)
forall a. a -> Secret a
mkSecret) ([SigningKey PaymentKey] -> [CardanoSigningKey])
-> Gen [SigningKey PaymentKey] -> Gen [CardanoSigningKey]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Gen (SigningKey PaymentKey) -> Gen [SigningKey PaymentKey]
forall a. Int -> Gen a -> Gen [a]
vectorOf Int
numParties Gen (SigningKey PaymentKey)
genSigningKey
    [(Secret (SigningKey HydraKey), CardanoSigningKey)]
-> Gen [(Secret (SigningKey HydraKey), CardanoSigningKey)]
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(Secret (SigningKey HydraKey), CardanoSigningKey)]
 -> Gen [(Secret (SigningKey HydraKey), CardanoSigningKey)])
-> [(Secret (SigningKey HydraKey), CardanoSigningKey)]
-> Gen [(Secret (SigningKey HydraKey), CardanoSigningKey)]
forall a b. (a -> b) -> a -> b
$ [Secret (SigningKey HydraKey)]
-> [CardanoSigningKey]
-> [(Secret (SigningKey HydraKey), CardanoSigningKey)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Secret (SigningKey HydraKey)]
hks [CardanoSigningKey]
cks

-- * 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, Monad (RunMonad m)
RunMonad m UTCTime
Monad (RunMonad m) => RunMonad m UTCTime -> MonadTime (RunMonad m)
forall (m :: * -> *). Monad m => m UTCTime -> MonadTime m
forall (m :: * -> *). MonadTime m => Monad (RunMonad m)
forall (m :: * -> *). MonadTime m => RunMonad m UTCTime
$cgetCurrentTime :: forall (m :: * -> *). MonadTime m => RunMonad m UTCTime
getCurrentTime :: RunMonad m UTCTime
MonadTime)

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

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

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

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

instance Exception RunException

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

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

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

    case Action WorldState a
action of
      Fanout{} ->
        case WorldState -> GlobalState
hydraState WorldState
st of
          Final{UTxOType Payment
$sel:finalUTxO:Start :: GlobalState -> UTxOType Payment
finalUTxO :: UTxOType Payment
finalUTxO} -> [TxOut CtxUTxO] -> [TxOut CtxUTxO]
forall ctx. [TxOut ctx] -> [TxOut ctx]
sortTxOuts ([(CardanoSigningKey, Value)] -> [TxOut CtxUTxO]
toTxOuts [(CardanoSigningKey, Value)]
UTxOType Payment
finalUTxO) [TxOut CtxUTxO]
-> [TxOut CtxUTxO] -> PostconditionM (RunMonad m) Bool
forall a (m :: * -> *).
(Eq a, Show a, Monad m) =>
a -> a -> PostconditionM m Bool
=== [TxOut CtxUTxO] -> [TxOut CtxUTxO]
forall ctx. [TxOut ctx] -> [TxOut ctx]
sortTxOuts ((TxIn, TxOut CtxUTxO) -> TxOut CtxUTxO
forall a b. (a, b) -> b
snd ((TxIn, TxOut CtxUTxO) -> TxOut CtxUTxO)
-> [(TxIn, TxOut CtxUTxO)] -> [TxOut CtxUTxO]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UTxO Era -> [(TxIn, TxOut CtxUTxO)]
forall era. UTxO era -> [(TxIn, TxOut CtxUTxO era)]
UTxO.toList UTxO Era
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{[(Secret (SigningKey HydraKey), CardanoSigningKey)]
$sel:seedKeys:Seed :: Action WorldState ()
-> [(Secret (SigningKey HydraKey), CardanoSigningKey)]
seedKeys :: [(Secret (SigningKey HydraKey), CardanoSigningKey)]
seedKeys, ContestationPeriod
$sel:contestationPeriod:Seed :: Action WorldState () -> ContestationPeriod
contestationPeriod :: ContestationPeriod
contestationPeriod} ->
        [(Secret (SigningKey HydraKey), CardanoSigningKey)]
-> ContestationPeriod -> RunMonad m ()
forall (m :: * -> *).
(MonadAsync m, MonadTimer m, MonadThrow (STM m),
 MonadLabelledSTM m, MonadFork m, MonadMask m, MonadDelay m,
 MonadTime m) =>
[(Secret (SigningKey HydraKey), CardanoSigningKey)]
-> ContestationPeriod -> RunMonad m ()
seedWorld [(Secret (SigningKey HydraKey), CardanoSigningKey)]
seedKeys ContestationPeriod
contestationPeriod
      Init Party
party ->
        Party -> RunMonad m HeadId
forall (m :: * -> *).
(MonadThrow m, MonadAsync m, MonadTimer m, MonadLabelledSTM m) =>
Party -> RunMonad m HeadId
performInit Party
party
      Deposit Var HeadId
headIdVar UTxOType Payment
utxo -> do
        let headId :: Realized (RunMonad m) HeadId
headId = Var HeadId -> Realized (RunMonad m) HeadId
LookUp (RunMonad m)
lookup Var HeadId
headIdVar
        HeadId -> [(CardanoSigningKey, Value)] -> RunMonad m ()
forall (m :: * -> *).
(MonadThrow m, MonadTimer m, MonadAsync m, MonadTime m,
 MonadLabelledSTM m) =>
HeadId -> [(CardanoSigningKey, Value)] -> RunMonad m ()
performDeposit HeadId
Realized (RunMonad m) HeadId
headId [(CardanoSigningKey, Value)]
UTxOType Payment
utxo
      Decommit Party
party Payment
tx ->
        Party -> Payment -> RunMonad m ()
forall (m :: * -> *).
(MonadThrow m, MonadTimer m, MonadAsync m, MonadDelay m,
 MonadLabelledSTM m) =>
Party -> Payment -> RunMonad m ()
performDecommit Party
party Payment
tx
      Close Party
party ->
        Party -> RunMonad m ()
forall (m :: * -> *).
(MonadThrow m, MonadAsync m, MonadTimer m, MonadDelay m,
 MonadLabelledSTM m) =>
Party -> RunMonad m ()
performClose Party
party
      Fanout Party
party ->
        Party -> RunMonad m (UTxO Era)
forall (m :: * -> *).
(MonadThrow m, MonadAsync m, MonadDelay m) =>
Party -> RunMonad m (UTxO Era)
performFanout Party
party
      NewTx Party
party Payment
transaction ->
        Party -> Payment -> RunMonad m Payment
forall (m :: * -> *).
(MonadThrow m, MonadAsync m, MonadTimer m, MonadDelay m,
 MonadLabelledSTM m) =>
Party -> Payment -> RunMonad m Payment
performNewTx Party
party Payment
transaction
      Wait DiffTime
delay ->
        m (PerformResult (Error WorldState) (Realized (RunMonad m) a))
-> RunMonad
     m (PerformResult (Error WorldState) (Realized (RunMonad m) a))
forall (m :: * -> *) a. Monad m => m a -> RunMonad m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (PerformResult (Error WorldState) (Realized (RunMonad m) a))
 -> RunMonad
      m (PerformResult (Error WorldState) (Realized (RunMonad m) a)))
-> m (PerformResult (Error WorldState) (Realized (RunMonad m) a))
-> RunMonad
     m (PerformResult (Error WorldState) (Realized (RunMonad m) a))
forall a b. (a -> b) -> a -> b
$ DiffTime -> m ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
delay
      ObserveConfirmedTx Var Payment
var -> do
        let tx :: Realized (RunMonad m) Payment
tx = Var Payment -> Realized (RunMonad m) Payment
LookUp (RunMonad m)
lookup Var Payment
var
        [(Party, TestHydraClient Tx m)]
nodes <- Map Party (TestHydraClient Tx m) -> [(Party, TestHydraClient Tx m)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map Party (TestHydraClient Tx m)
 -> [(Party, TestHydraClient Tx m)])
-> RunMonad m (Map Party (TestHydraClient Tx m))
-> RunMonad m [(Party, TestHydraClient Tx m)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Nodes m -> Map Party (TestHydraClient Tx m))
-> RunMonad m (Map Party (TestHydraClient Tx m))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Nodes m -> Map Party (TestHydraClient Tx m)
forall (m :: * -> *). Nodes m -> Map Party (TestHydraClient Tx m)
nodes
        [(Party, TestHydraClient Tx m)]
-> ((Party, TestHydraClient Tx m) -> RunMonad m ())
-> RunMonad m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Party, TestHydraClient Tx m)]
nodes (((Party, TestHydraClient Tx m) -> RunMonad m ()) -> RunMonad m ())
-> ((Party, TestHydraClient Tx m) -> RunMonad m ())
-> RunMonad m ()
forall a b. (a -> b) -> a -> b
$ \(Party
_, TestHydraClient Tx m
node) -> do
          m (Either (UTxO Era) (TxIn, TxOut CtxUTxO))
-> RunMonad m (Either (UTxO Era) (TxIn, TxOut CtxUTxO))
forall (m :: * -> *) a. Monad m => m a -> RunMonad m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (UTxO Era
-> CardanoSigningKey
-> Value
-> TestHydraClient Tx m
-> m (Either (UTxO Era) (TxIn, TxOut CtxUTxO))
forall (m :: * -> *).
MonadDelay m =>
UTxO Era
-> CardanoSigningKey
-> Value
-> TestHydraClient Tx m
-> m (Either (UTxO Era) (TxIn, TxOut CtxUTxO))
waitForUTxOToSpend UTxO Era
forall a. Monoid a => a
mempty (Payment -> CardanoSigningKey
to Payment
Realized (RunMonad m) Payment
tx) (Payment -> Value
value Payment
Realized (RunMonad m) Payment
tx) TestHydraClient Tx m
node) RunMonad m (Either (UTxO Era) (TxIn, TxOut CtxUTxO))
-> (Either (UTxO Era) (TxIn, TxOut CtxUTxO) -> RunMonad m ())
-> RunMonad m ()
forall a b. RunMonad m a -> (a -> RunMonad m b) -> RunMonad m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Left UTxO Era
u -> RunException -> RunMonad m ()
forall e a. Exception e => e -> RunMonad m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (RunException -> RunMonad m ()) -> RunException -> RunMonad m ()
forall a b. (a -> b) -> a -> b
$ Payment -> UTxO Era -> RunException
TransactionNotObserved Payment
Realized (RunMonad m) Payment
tx UTxO Era
u
            Right (TxIn, TxOut CtxUTxO)
_ -> () -> RunMonad m ()
forall a. a -> RunMonad m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Action WorldState a
R:ActionWorldStatea a
ObserveHeadIsOpen -> do
        [(Party, TestHydraClient Tx m)]
nodes' <- Map Party (TestHydraClient Tx m) -> [(Party, TestHydraClient Tx m)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map Party (TestHydraClient Tx m)
 -> [(Party, TestHydraClient Tx m)])
-> RunMonad m (Map Party (TestHydraClient Tx m))
-> RunMonad m [(Party, TestHydraClient Tx m)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Nodes m -> Map Party (TestHydraClient Tx m))
-> RunMonad m (Map Party (TestHydraClient Tx m))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Nodes m -> Map Party (TestHydraClient Tx m)
forall (m :: * -> *). Nodes m -> Map Party (TestHydraClient Tx m)
nodes
        [(Party, TestHydraClient Tx m)]
-> ((Party, TestHydraClient Tx m) -> RunMonad m ())
-> RunMonad m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Party, TestHydraClient Tx m)]
nodes' (((Party, TestHydraClient Tx m) -> RunMonad m ()) -> RunMonad m ())
-> ((Party, TestHydraClient Tx m) -> RunMonad m ())
-> RunMonad m ()
forall a b. (a -> b) -> a -> b
$ \(Party
_, TestHydraClient Tx m
node) -> do
          [ServerOutput Tx]
outputs <- m [ServerOutput Tx] -> RunMonad m [ServerOutput Tx]
forall (m :: * -> *) a. Monad m => m a -> RunMonad m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m [ServerOutput Tx] -> RunMonad m [ServerOutput Tx])
-> m [ServerOutput Tx] -> RunMonad m [ServerOutput Tx]
forall a b. (a -> b) -> a -> b
$ TestHydraClient Tx m -> m [ServerOutput Tx]
forall tx (m :: * -> *).
TestHydraClient tx m -> m [ServerOutput tx]
serverOutputs TestHydraClient Tx m
node
          case (ServerOutput Tx -> Bool)
-> [ServerOutput Tx] -> Maybe (ServerOutput Tx)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ServerOutput Tx -> Bool
forall tx. ServerOutput tx -> Bool
headIsOpen [ServerOutput Tx]
outputs of
            Just ServerOutput Tx
_ -> () -> RunMonad m ()
forall a. a -> RunMonad m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            Maybe (ServerOutput Tx)
Nothing -> Text -> RunMonad m ()
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"The head is not open for node"
      CloseWithInitialSnapshot Party
party ->
        WorldState -> Party -> RunMonad m ()
forall (m :: * -> *).
(MonadThrow m, MonadTimer m, MonadDelay m, MonadAsync m,
 MonadLabelledSTM m) =>
WorldState -> Party -> RunMonad m ()
performCloseWithInitialSnapshot WorldState
st Party
party
      RollbackAndForward Natural
numberOfBlocks ->
        Natural -> RunMonad m ()
forall (m :: * -> *).
(MonadThrow m, MonadTimer m) =>
Natural -> RunMonad m ()
performRollbackAndForward Natural
numberOfBlocks
      Action WorldState a
R:ActionWorldStatea a
StopTheWorld ->
        RunMonad m ()
RunMonad
  m (PerformResult (Error WorldState) (Realized (RunMonad m) a))
forall (m :: * -> *). MonadAsync m => RunMonad m ()
stopTheWorld

-- ** Performing actions

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

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

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

  [(Party, TestHydraClient Tx m)]
clients <- [(Secret (SigningKey HydraKey), CardanoSigningKey)]
-> ((Secret (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 [(Secret (SigningKey HydraKey), CardanoSigningKey)]
seedKeys (((Secret (SigningKey HydraKey), CardanoSigningKey)
  -> RunMonad m (Party, TestHydraClient Tx m))
 -> RunMonad m [(Party, TestHydraClient Tx m)])
-> ((Secret (SigningKey HydraKey), CardanoSigningKey)
    -> RunMonad m (Party, TestHydraClient Tx m))
-> RunMonad m [(Party, TestHydraClient Tx m)]
forall a b. (a -> b) -> a -> b
$ \(Secret (SigningKey HydraKey)
hsk, CardanoSigningKey
_csk) -> do
    let party :: Party
party = Secret (SigningKey HydraKey) -> Party
deriveParty Secret (SigningKey HydraKey)
hsk
        otherParties :: [Party]
otherParties = (Party -> Bool) -> [Party] -> [Party]
forall a. (a -> Bool) -> [a] -> [a]
filter (Party -> Party -> Bool
forall a. Eq a => a -> a -> Bool
/= Party
party) [Party]
parties
    (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 <- String -> m (TQueue m (ServerOutput Tx))
forall (m :: * -> *) a.
MonadLabelledSTM m =>
String -> m (TQueue m a)
newLabelledTQueueIO (String
"seed-world-outputs-" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Secret (SigningKey HydraKey) -> String
shortLabel Secret (SigningKey HydraKey)
hsk)
      TQueue m (ClientMessage Tx)
messages <- String -> m (TQueue m (ClientMessage Tx))
forall (m :: * -> *) a.
MonadLabelledSTM m =>
String -> m (TQueue m a)
newLabelledTQueueIO (String
"seed-world-messages-" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Secret (SigningKey HydraKey) -> String
shortLabel Secret (SigningKey HydraKey)
hsk)
      TVar m [ServerOutput Tx]
outputHistory <- String -> [ServerOutput Tx] -> m (TVar m [ServerOutput Tx])
forall (m :: * -> *) a.
MonadLabelledSTM m =>
String -> a -> m (TVar m a)
newLabelledTVarIO String
"seed-world-output-history" []
      node :: HydraNode Tx m
node@HydraNode{$sel:nodeStateHandler:HydraNode :: forall tx (m :: * -> *). HydraNode tx m -> NodeStateHandler tx m
nodeStateHandler = NodeStateHandler{STM m (NodeState Tx)
queryNodeState :: STM m (NodeState Tx)
$sel:queryNodeState:NodeStateHandler :: forall tx (m :: * -> *).
NodeStateHandler tx m -> STM m (NodeState tx)
queryNodeState}} <-
        Tracer m (HydraNodeLog Tx)
-> Ledger Tx
-> ChainStateType Tx
-> Secret (SigningKey HydraKey)
-> [Party]
-> TQueue m (ServerOutput Tx)
-> TQueue m (ClientMessage Tx)
-> TVar m [ServerOutput Tx]
-> SimulatedChainNetwork Tx m
-> ContestationPeriod
-> DepositPeriod
-> m (HydraNode Tx m)
forall tx (m :: * -> *).
(IsChainState tx, MonadDelay m, MonadAsync m, MonadLabelledSTM m,
 MonadThrow m) =>
Tracer m (HydraNodeLog tx)
-> Ledger tx
-> ChainStateType tx
-> Secret (SigningKey HydraKey)
-> [Party]
-> TQueue m (ServerOutput tx)
-> TQueue m (ClientMessage tx)
-> TVar m [ServerOutput tx]
-> SimulatedChainNetwork tx m
-> ContestationPeriod
-> DepositPeriod
-> m (HydraNode tx m)
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. HydraNodeLog tx -> HydraLog tx
Node Tracer m (HydraLog Tx)
tr)
          Ledger Tx
ledger
          ChainStateType Tx
initialChainState
          Secret (SigningKey HydraKey)
hsk
          [Party]
otherParties
          TQueue m (ServerOutput Tx)
outputs
          TQueue m (ClientMessage Tx)
messages
          TVar m [ServerOutput Tx]
outputHistory
          SimulatedChainNetwork Tx m
mockChain
          ContestationPeriod
seedCP
          DepositPeriod
testDepositPeriod
      Async m ()
nodeThread <- String -> m () -> m (Async m ())
forall (m :: * -> *) a.
MonadAsync m =>
String -> m a -> m (Async m a)
asyncLabelled (String
"seed-world-node-" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Secret (SigningKey HydraKey) -> String
shortLabel Secret (SigningKey HydraKey)
hsk) (m () -> m (Async m ())) -> m () -> m (Async m ())
forall a b. (a -> b) -> a -> b
$ HydraNode Tx m -> m ()
forall (m :: * -> *) tx.
(MonadCatch m, MonadAsync m, MonadTime m, IsChainState tx) =>
HydraNode tx m -> m ()
runHydraNode HydraNode Tx m
node
      Async m () -> m ()
forall (m :: * -> *) a.
(MonadAsync m, MonadFork m, MonadMask m) =>
Async m a -> m ()
link Async m ()
nodeThread
      -- await for the node to be in sync with the chain before returning the client
      STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
        NodeState Tx
st <- STM m (NodeState Tx)
queryNodeState
        case NodeState Tx
st of
          NodeInSync{} -> () -> STM m ()
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          NodeState Tx
_ -> STM m ()
forall a. STM m a
forall (m :: * -> *) a. MonadSTM m => STM m a
retry
      let testClient :: TestHydraClient Tx m
testClient = TQueue m (ServerOutput Tx)
-> TQueue m (ClientMessage Tx)
-> TVar m [ServerOutput Tx]
-> HydraNode Tx m
-> TestHydraClient Tx m
forall (m :: * -> *) tx.
MonadSTM m =>
TQueue m (ServerOutput tx)
-> TQueue m (ClientMessage tx)
-> TVar m [ServerOutput tx]
-> HydraNode tx m
-> TestHydraClient tx m
createTestHydraClient TQueue m (ServerOutput Tx)
outputs TQueue m (ClientMessage Tx)
messages TVar m [ServerOutput Tx]
outputHistory HydraNode Tx m
node
      (TestHydraClient Tx m, Async m ())
-> m (TestHydraClient Tx m, Async m ())
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TestHydraClient Tx m
testClient, Async m ()
nodeThread)
    Async m () -> RunMonad m ()
forall (m :: * -> *). MonadSTM m => Async m () -> RunMonad 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 = ((Secret (SigningKey HydraKey), CardanoSigningKey) -> Party)
-> [(Secret (SigningKey HydraKey), CardanoSigningKey)] -> [Party]
forall a b. (a -> b) -> [a] -> [b]
map (Secret (SigningKey HydraKey) -> Party
deriveParty (Secret (SigningKey HydraKey) -> Party)
-> ((Secret (SigningKey HydraKey), CardanoSigningKey)
    -> Secret (SigningKey HydraKey))
-> (Secret (SigningKey HydraKey), CardanoSigningKey)
-> Party
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Secret (SigningKey HydraKey), CardanoSigningKey)
-> Secret (SigningKey HydraKey)
forall a b. (a, b) -> a
fst) [(Secret (SigningKey HydraKey), CardanoSigningKey)]
seedKeys

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

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

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

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

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

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

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

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

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

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

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

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

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

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

sendsInput :: (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
  TestHydraClient Tx m
actorNode <- Party -> RunMonad m (TestHydraClient Tx m)
forall (m :: * -> *).
(MonadSTM m, MonadThrow m) =>
Party -> RunMonad m (TestHydraClient Tx m)
getActorNode Party
party
  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

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

performInit :: (MonadThrow m, MonadAsync m, MonadTimer m, MonadLabelledSTM m) => Party -> RunMonad m HeadId
performInit :: forall (m :: * -> *).
(MonadThrow m, MonadAsync m, MonadTimer m, MonadLabelledSTM m) =>
Party -> RunMonad m HeadId
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 HeadId -> RunMonad m HeadId
forall (m :: * -> *) a. Monad m => m a -> RunMonad m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m HeadId -> RunMonad m HeadId)
-> ((ServerOutput Tx -> Maybe HeadId) -> m HeadId)
-> (ServerOutput Tx -> Maybe HeadId)
-> RunMonad m HeadId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TestHydraClient Tx m]
-> (ServerOutput Tx -> Maybe HeadId) -> m HeadId
forall tx (m :: * -> *) a.
(Show (ServerOutput tx), HasCallStack, MonadThrow m, MonadAsync m,
 MonadTimer m, MonadLabelledSTM m, Eq a, Show a, IsChainState tx) =>
[TestHydraClient tx m] -> (ServerOutput tx -> Maybe a) -> m a
waitUntilMatch (Map Party (TestHydraClient Tx m) -> [TestHydraClient Tx m]
forall t a b. (IsList t, Item t ~ (a, b)) => t -> [b]
elems Map Party (TestHydraClient Tx m)
nodes) ((ServerOutput Tx -> Maybe HeadId) -> RunMonad m HeadId)
-> (ServerOutput Tx -> Maybe HeadId) -> RunMonad m HeadId
forall a b. (a -> b) -> a -> b
$ \case
    HeadIsOpen{HeadId
headId :: HeadId
$sel:headId:NetworkConnected :: forall tx. ServerOutput tx -> HeadId
headId} -> HeadId -> Maybe HeadId
forall a. a -> Maybe a
Just HeadId
headId
    ServerOutput Tx
_ -> Maybe HeadId
forall a. Maybe a
Nothing

performClose :: (MonadThrow m, MonadAsync m, MonadTimer m, MonadDelay m, MonadLabelledSTM m) => Party -> RunMonad m ()
performClose :: forall (m :: * -> *).
(MonadThrow m, MonadAsync m, MonadTimer m, MonadDelay m,
 MonadLabelledSTM m) =>
Party -> RunMonad m ()
performClose Party
party = do
  Map Party (TestHydraClient Tx m)
nodes <- (Nodes m -> Map Party (TestHydraClient Tx m))
-> RunMonad m (Map Party (TestHydraClient Tx m))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Nodes m -> Map Party (TestHydraClient Tx m)
forall (m :: * -> *). Nodes m -> Map Party (TestHydraClient Tx m)
nodes
  let thisNode :: TestHydraClient Tx m
thisNode = Map Party (TestHydraClient Tx m)
nodes Map Party (TestHydraClient Tx m) -> Party -> TestHydraClient Tx m
forall k a. Ord k => Map k a -> k -> a
! Party
party
  TestHydraClient Tx m -> RunMonad m ()
forall (m :: * -> *) tx.
MonadDelay m =>
TestHydraClient tx m -> RunMonad m ()
waitForOpen TestHydraClient Tx m
thisNode
  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 ())
-> ((ServerOutput Tx -> Maybe ()) -> m ())
-> (ServerOutput Tx -> Maybe ())
-> RunMonad m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TestHydraClient Tx m] -> (ServerOutput Tx -> Maybe ()) -> m ()
forall tx (m :: * -> *) a.
(Show (ServerOutput tx), HasCallStack, MonadThrow m, MonadAsync m,
 MonadTimer m, MonadLabelledSTM m, Eq a, Show a, IsChainState tx) =>
[TestHydraClient tx m] -> (ServerOutput tx -> Maybe a) -> m a
waitUntilMatch (Map Party (TestHydraClient Tx m) -> [TestHydraClient Tx m]
forall t a b. (IsList t, Item t ~ (a, b)) => t -> [b]
elems Map Party (TestHydraClient Tx m)
nodes) ((ServerOutput Tx -> Maybe ()) -> RunMonad m ())
-> (ServerOutput Tx -> Maybe ()) -> RunMonad m ()
forall a b. (a -> b) -> a -> b
$ \case
    HeadIsClosed{} -> () -> Maybe ()
forall a. a -> Maybe a
Just ()
    ServerOutput Tx
_ -> Maybe ()
forall a. Maybe a
Nothing

performFanout :: (MonadThrow m, MonadAsync m, MonadDelay m) => Party -> RunMonad m UTxO
performFanout :: forall (m :: * -> *).
(MonadThrow m, MonadAsync m, MonadDelay m) =>
Party -> RunMonad m (UTxO Era)
performFanout Party
party = do
  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 (UTxO Era)
forall (m :: * -> *).
(MonadDelay m, MonadThrow m) =>
TestHydraClient Tx m -> Int -> RunMonad m (UTxO Era)
findInOutput TestHydraClient Tx m
thisNode (Int
100 :: Int)
 where
  findInOutput :: (MonadDelay m, MonadThrow m) => TestHydraClient Tx m -> Int -> RunMonad m UTxO
  findInOutput :: forall (m :: * -> *).
(MonadDelay m, MonadThrow m) =>
TestHydraClient Tx m -> Int -> RunMonad m (UTxO Era)
findInOutput TestHydraClient Tx m
node Int
n
    | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = String -> RunMonad m (UTxO Era)
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure String
"Failed to perform Fanout"
    | Bool
otherwise = do
        [ServerOutput Tx]
outputs <- m [ServerOutput Tx] -> RunMonad m [ServerOutput Tx]
forall (m :: * -> *) a. Monad m => m a -> RunMonad m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m [ServerOutput Tx] -> RunMonad m [ServerOutput Tx])
-> m [ServerOutput Tx] -> RunMonad m [ServerOutput Tx]
forall a b. (a -> b) -> a -> b
$ TestHydraClient Tx m -> m [ServerOutput Tx]
forall tx (m :: * -> *).
TestHydraClient tx m -> m [ServerOutput tx]
serverOutputs TestHydraClient Tx m
node
        case (ServerOutput Tx -> Bool)
-> [ServerOutput Tx] -> Maybe (ServerOutput Tx)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ServerOutput Tx -> Bool
headIsFinalized [ServerOutput Tx]
outputs of
          Just (HeadIsFinalized{UTxOType Tx
finalizedUTxO :: UTxOType Tx
$sel:finalizedUTxO:NetworkConnected :: forall tx. ServerOutput tx -> UTxOType tx
finalizedUTxO}) -> UTxO Era -> RunMonad m (UTxO Era)
forall a. a -> RunMonad m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure UTxOType Tx
UTxO Era
finalizedUTxO
          Maybe (ServerOutput Tx)
_ -> m () -> RunMonad m ()
forall (m :: * -> *) a. Monad m => m a -> RunMonad m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (DiffTime -> m ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
1) RunMonad m () -> RunMonad m (UTxO Era) -> RunMonad m (UTxO Era)
forall a b. RunMonad m a -> RunMonad m b -> RunMonad m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TestHydraClient Tx m -> Int -> RunMonad m (UTxO Era)
forall (m :: * -> *).
(MonadDelay m, MonadThrow m) =>
TestHydraClient Tx m -> Int -> RunMonad m (UTxO Era)
findInOutput TestHydraClient Tx m
node (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)

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

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

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

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

-- ** Utility functions

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

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

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

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

-- | 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
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 -> String
  interpret :: Bool -> String
interpret Bool
True = String
"=="
  interpret Bool
False = String
"/="

waitForUTxOToSpend ::
  forall m.
  MonadDelay m =>
  UTxO ->
  CardanoSigningKey ->
  Value ->
  TestHydraClient Tx m ->
  m (Either UTxO (TxIn, TxOut CtxUTxO))
waitForUTxOToSpend :: forall (m :: * -> *).
MonadDelay m =>
UTxO Era
-> CardanoSigningKey
-> Value
-> TestHydraClient Tx m
-> m (Either (UTxO Era) (TxIn, TxOut CtxUTxO))
waitForUTxOToSpend UTxO Era
utxo CardanoSigningKey
key Value
value TestHydraClient Tx m
node = Int -> m (Either (UTxO Era) (TxIn, TxOut CtxUTxO))
go Int
100
 where
  go :: Int -> m (Either UTxO (TxIn, TxOut CtxUTxO))
  go :: Int -> m (Either (UTxO Era) (TxIn, TxOut CtxUTxO))
go = \case
    Int
0 ->
      Either (UTxO Era) (TxIn, TxOut CtxUTxO)
-> m (Either (UTxO Era) (TxIn, TxOut CtxUTxO))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (UTxO Era) (TxIn, TxOut CtxUTxO)
 -> m (Either (UTxO Era) (TxIn, TxOut CtxUTxO)))
-> Either (UTxO Era) (TxIn, TxOut CtxUTxO)
-> m (Either (UTxO Era) (TxIn, TxOut CtxUTxO))
forall a b. (a -> b) -> a -> b
$ UTxO Era -> Either (UTxO Era) (TxIn, TxOut CtxUTxO)
forall a b. a -> Either a b
Left UTxO Era
utxo
    Int
n -> do
      UTxO Era
u <- TestHydraClient Tx m -> m (UTxOType Tx)
forall tx (m :: * -> *).
(IsTx tx, MonadDelay m) =>
TestHydraClient tx m -> m (UTxOType tx)
headUTxO TestHydraClient Tx m
node
      if UTxO Era
u UTxO Era -> UTxO Era -> Bool
forall a. Eq a => a -> a -> Bool
/= UTxO Era
forall a. Monoid a => a
mempty
        then case ((TxIn, TxOut CtxUTxO) -> Bool)
-> [(TxIn, TxOut CtxUTxO)] -> Maybe (TxIn, TxOut CtxUTxO)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (TxIn, TxOut CtxUTxO) -> Bool
matchPayment (UTxO Era -> [(TxIn, TxOut CtxUTxO)]
forall era. UTxO era -> [(TxIn, TxOut CtxUTxO era)]
UTxO.toList UTxO Era
u) of
          Maybe (TxIn, TxOut CtxUTxO)
Nothing -> Int -> m (Either (UTxO Era) (TxIn, TxOut CtxUTxO))
go (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
          Just (TxIn
txIn, TxOut CtxUTxO
txOut) -> Either (UTxO Era) (TxIn, TxOut CtxUTxO)
-> m (Either (UTxO Era) (TxIn, TxOut CtxUTxO))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (UTxO Era) (TxIn, TxOut CtxUTxO)
 -> m (Either (UTxO Era) (TxIn, TxOut CtxUTxO)))
-> Either (UTxO Era) (TxIn, TxOut CtxUTxO)
-> m (Either (UTxO Era) (TxIn, TxOut CtxUTxO))
forall a b. (a -> b) -> a -> b
$ (TxIn, TxOut CtxUTxO) -> Either (UTxO Era) (TxIn, TxOut CtxUTxO)
forall a b. b -> Either a b
Right (TxIn
txIn, TxOut CtxUTxO
txOut)
        else Int -> m (Either (UTxO Era) (TxIn, TxOut CtxUTxO))
go (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)

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

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

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

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

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