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

import Cardano.Api.UTxO qualified as UTxO
import Cardano.Binary (serialize', unsafeDeserialize')
import Control.Concurrent.Class.MonadSTM (
  MonadLabelledSTM,
  labelTQueueIO,
  labelTVarIO,
  modifyTVar,
  newTQueue,
  newTVarIO,
  readTVarIO,
 )
import Control.Monad.Class.MonadAsync (Async, async, cancel, link)
import Control.Monad.Class.MonadFork (labelThisThread)
import Data.Foldable qualified as Foldable
import Data.List (nub, (\\))
import Data.List qualified as List
import Data.Map ((!))
import Data.Map qualified as Map
import Data.Maybe (fromJust)
import Data.Set qualified as Set
import GHC.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.Cardano.Api.Prelude (fromShelleyPaymentCredential)
import Hydra.Chain (maximumNumberOfParties)
import Hydra.Chain.Direct.State (initialChainState)
import Hydra.HeadLogic (Committed ())
import Hydra.Ledger.Cardano (cardanoLedger, mkSimpleTx)
import Hydra.Logging (Tracer)
import Hydra.Logging.Messages (HydraLog (DirectChain, Node))
import Hydra.Model.MockChain (mockChainAndNetwork)
import Hydra.Model.Payment (CardanoSigningKey (..), Payment (..), applyTx, genAdaValue)
import Hydra.Node (runHydraNode)
import Hydra.Node.DepositPeriod (DepositPeriod (..))
import Hydra.Tx (HeadId)
import Hydra.Tx.ContestationPeriod (ContestationPeriod (..))
import Hydra.Tx.Crypto (HydraKey)
import Hydra.Tx.HeadParameters (HeadParameters (..))
import Hydra.Tx.IsTx (IsTx (..))
import Hydra.Tx.Party (Party (..), deriveParty)
import Hydra.Tx.Snapshot qualified as Snapshot
import Test.Hydra.Node.Fixture (defaultGlobals, defaultLedgerEnv, testNetworkId)
import Test.Hydra.Prelude (failure)
import Test.Hydra.Tx.Gen (genSigningKey)
import Test.QuickCheck (choose, chooseEnum, 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 -> [(SigningKey HydraKey, CardanoSigningKey)]
hydraParties :: [(SigningKey HydraKey, CardanoSigningKey)]
  -- ^ List of parties identified by both signing keys required to run protocol.
  -- This list must not contain any duplicated key.
  , WorldState -> GlobalState
hydraState :: GlobalState
  -- ^ Expected consensus state
  -- All nodes should be in the same state.
  , 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.
  }
  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
      , GlobalState -> Uncommitted
toCommit :: Uncommitted
      }
  | Initial
      { GlobalState -> Var HeadId
headIdVar :: Var HeadId
      , GlobalState -> HeadParameters
headParameters :: HeadParameters
      , GlobalState -> Uncommitted
commits :: Committed Payment
      , GlobalState -> Uncommitted
pendingCommits :: Uncommitted
      }
  | Open
      { headIdVar :: Var HeadId
      , headParameters :: HeadParameters
      , GlobalState -> OffChainState
offChainState :: OffChainState
      , GlobalState -> Uncommitted
committed :: Committed Payment
      }
  | Closed
      { headParameters :: HeadParameters
      , GlobalState -> UTxOType Payment
closedUTxO :: UTxOType Payment
      }
  | Final {GlobalState -> UTxOType Payment
finalUTxO :: UTxOType Payment}
  deriving stock (GlobalState -> GlobalState -> Bool
(GlobalState -> GlobalState -> Bool)
-> (GlobalState -> GlobalState -> Bool) -> Eq GlobalState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: GlobalState -> GlobalState -> Bool
== :: GlobalState -> GlobalState -> Bool
$c/= :: GlobalState -> GlobalState -> Bool
/= :: GlobalState -> GlobalState -> Bool
Eq, Int -> GlobalState -> ShowS
[GlobalState] -> ShowS
GlobalState -> String
(Int -> GlobalState -> ShowS)
-> (GlobalState -> String)
-> ([GlobalState] -> ShowS)
-> Show GlobalState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> GlobalState -> ShowS
showsPrec :: Int -> GlobalState -> ShowS
$cshow :: GlobalState -> String
show :: GlobalState -> String
$cshowList :: [GlobalState] -> ShowS
showList :: [GlobalState] -> ShowS
Show)

type Uncommitted = Map.Map Party (UTxOType Payment)

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

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

type ActualCommitted = UTxOType Payment

-- | Basic instantiation of `StateModel` for our `WorldState` state.
instance StateModel WorldState where
  -- The list of possible "Actions" within our `Model`
  -- Not all of them need to actually represent an actual user `Action`, but they
  -- can represent _observations_ which are useful when defining properties in
  -- DL. Those observations would usually not be generated.
  data Action WorldState a where
    Seed ::
      { Action WorldState () -> [(SigningKey HydraKey, CardanoSigningKey)]
seedKeys :: [(SigningKey HydraKey, CardanoSigningKey)]
      , Action WorldState () -> ContestationPeriod
contestationPeriod :: ContestationPeriod
      , Action WorldState () -> Uncommitted
toCommit :: Uncommitted
      , Action WorldState () -> UTxOType Payment
additionalUTxO :: UTxOType Payment
      } ->
      Action WorldState ()
    Init :: Party -> Action WorldState HeadId
    Commit :: {Action WorldState () -> Var HeadId
headIdVar :: Var HeadId, Action WorldState () -> Party
party :: Party, Action WorldState () -> UTxOType Payment
utxoToCommit :: UTxOType Payment} -> Action WorldState ()
    Abort :: {party :: Party} -> Action WorldState ()
    Deposit :: {headIdVar :: Var HeadId, Action WorldState () -> UTxOType Payment
utxoToDeposit :: UTxOType Payment} -> Action WorldState ()
    Decommit :: {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 :: [(SigningKey HydraKey, CardanoSigningKey)]
hydraParties = [(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{[(SigningKey HydraKey, CardanoSigningKey)]
$sel:hydraParties:WorldState :: WorldState -> [(SigningKey HydraKey, CardanoSigningKey)]
hydraParties :: [(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
<$> [(SigningKey HydraKey, CardanoSigningKey)]
-> Gen (Action WorldState HeadId)
forall b.
[(SigningKey HydraKey, b)] -> Gen (Action WorldState HeadId)
genInit [(SigningKey HydraKey, CardanoSigningKey)]
hydraParties
      Initial{Var HeadId
$sel:headIdVar:Start :: GlobalState -> Var HeadId
headIdVar :: Var HeadId
headIdVar, Uncommitted
$sel:pendingCommits:Start :: GlobalState -> Uncommitted
pendingCommits :: Uncommitted
pendingCommits} ->
        [(Int, Gen (Any (Action WorldState)))]
-> Gen (Any (Action WorldState))
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency
          [ (Int
5, Var HeadId
-> Map Party [(CardanoSigningKey, Value)]
-> Gen (Any (Action WorldState))
genCommit Var HeadId
headIdVar Map Party [(CardanoSigningKey, Value)]
Uncommitted
pendingCommits)
          , (Int
1, Gen (Any (Action WorldState))
genAbort)
          ]
      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
    genCommit :: Var HeadId
-> Map Party [(CardanoSigningKey, Value)]
-> Gen (Any (Action WorldState))
genCommit Var HeadId
headIdVar Map Party [(CardanoSigningKey, Value)]
pending = do
      (Party
party, [(CardanoSigningKey, Value)]
commits) <- [(Party, [(CardanoSigningKey, Value)])]
-> Gen (Party, [(CardanoSigningKey, Value)])
forall a. HasCallStack => [a] -> Gen a
elements ([(Party, [(CardanoSigningKey, Value)])]
 -> Gen (Party, [(CardanoSigningKey, Value)]))
-> [(Party, [(CardanoSigningKey, Value)])]
-> Gen (Party, [(CardanoSigningKey, Value)])
forall a b. (a -> b) -> a -> b
$ Map Party [(CardanoSigningKey, Value)]
-> [(Party, [(CardanoSigningKey, Value)])]
forall k a. Map k a -> [(k, a)]
Map.toList Map Party [(CardanoSigningKey, Value)]
pending
      Any (Action WorldState) -> Gen (Any (Action WorldState))
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Any (Action WorldState) -> Gen (Any (Action WorldState)))
-> (Action WorldState () -> 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
$ Var HeadId -> Party -> UTxOType Payment -> Action WorldState ()
Commit Var HeadId
headIdVar Party
party [(CardanoSigningKey, Value)]
UTxOType Payment
commits

    -- NOTE: Some actions depend on confirmed 'UTxO' in the head so
    -- we need to make sure there are funds to spend when generating a
    -- `NewTx` action for example but also want to make sure that after
    -- a 'Decommit' we are not left without any funds so further actions
    -- can be generated.
    genOpenActions :: 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 <- (SigningKey HydraKey, CardanoSigningKey) -> CardanoSigningKey
forall a b. (a, b) -> b
snd ((SigningKey HydraKey, CardanoSigningKey) -> CardanoSigningKey)
-> Gen (SigningKey HydraKey, CardanoSigningKey)
-> Gen CardanoSigningKey
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(SigningKey HydraKey, CardanoSigningKey)]
-> Gen (SigningKey HydraKey, CardanoSigningKey)
forall a. HasCallStack => [a] -> Gen a
elements [(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

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

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

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

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

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

  precondition :: forall a. WorldState -> Action WorldState a -> Bool
precondition WorldState{$sel:hydraState:WorldState :: WorldState -> GlobalState
hydraState = GlobalState
Start} Seed{} =
    Bool
True
  precondition WorldState{$sel:hydraState:WorldState :: WorldState -> GlobalState
hydraState = Idle{[Party]
$sel:idleParties:Start :: GlobalState -> [Party]
idleParties :: [Party]
idleParties}} (Init Party
p) =
    Party
p Party -> [Party] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` [Party]
idleParties
  precondition WorldState{$sel:hydraState:WorldState :: WorldState -> GlobalState
hydraState = Initial{Uncommitted
$sel:pendingCommits:Start :: GlobalState -> Uncommitted
pendingCommits :: Uncommitted
pendingCommits}} Commit{Party
$sel:party:Seed :: Action WorldState () -> Party
party :: Party
party} =
    Party
party Party -> Map Party [(CardanoSigningKey, Value)] -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Map Party [(CardanoSigningKey, Value)]
Uncommitted
pendingCommits
  precondition WorldState{$sel:hydraState:WorldState :: WorldState -> GlobalState
hydraState = Initial{Uncommitted
$sel:commits:Start :: GlobalState -> Uncommitted
commits :: Uncommitted
commits, Uncommitted
$sel:pendingCommits:Start :: GlobalState -> Uncommitted
pendingCommits :: Uncommitted
pendingCommits}} Abort{Party
$sel:party:Seed :: Action WorldState () -> Party
party :: Party
party} =
    Party
party Party -> Set Party -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` (Map Party [(CardanoSigningKey, Value)] -> Set Party
forall k a. Map k a -> Set k
Map.keysSet Map Party [(CardanoSigningKey, Value)]
Uncommitted
pendingCommits Set Party -> Set Party -> Set Party
forall a. Semigroup a => a -> a -> a
<> Map Party [(CardanoSigningKey, Value)] -> Set Party
forall k a. Map k a -> Set k
Map.keysSet Map Party [(CardanoSigningKey, Value)]
Uncommitted
commits)
  precondition WorldState{$sel:hydraState:WorldState :: WorldState -> GlobalState
hydraState = Open{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{HeadParameters
$sel:headParameters:Start :: GlobalState -> HeadParameters
headParameters :: HeadParameters
headParameters}} Commit{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{Var HeadId
$sel:headIdVar:Start :: GlobalState -> Var HeadId
headIdVar :: Var HeadId
headIdVar}, UTxOType Payment
$sel:availableToDeposit:WorldState :: WorldState -> UTxOType Payment
availableToDeposit :: UTxOType Payment
availableToDeposit} Deposit{$sel:headIdVar:Seed :: Action WorldState () -> Var HeadId
headIdVar = Var HeadId
var, UTxOType Payment
$sel:utxoToDeposit:Seed :: Action WorldState () -> UTxOType Payment
utxoToDeposit :: UTxOType Payment
utxoToDeposit} =
    Var HeadId
var Var HeadId -> Var HeadId -> Bool
forall a. Eq a => a -> a -> Bool
== Var HeadId
headIdVar
      Bool -> Bool -> Bool
&& ((CardanoSigningKey, Value) -> Bool)
-> [(CardanoSigningKey, Value)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((CardanoSigningKey, Value) -> [(CardanoSigningKey, Value)] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` [(CardanoSigningKey, Value)]
UTxOType Payment
availableToDeposit) [(CardanoSigningKey, Value)]
UTxOType Payment
utxoToDeposit
  precondition WorldState{$sel:hydraState:WorldState :: WorldState -> GlobalState
hydraState = Open{HeadParameters
$sel:headParameters:Start :: GlobalState -> HeadParameters
headParameters :: HeadParameters
headParameters, OffChainState
$sel:offChainState:Start :: GlobalState -> OffChainState
offChainState :: OffChainState
offChainState}} Decommit{Party
$sel:party:Seed :: Action WorldState () -> Party
party :: Party
party, Payment
$sel:decommitTx:Seed :: Action WorldState () -> Payment
decommitTx :: Payment
decommitTx} =
    Party
party Party -> [Party] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` HeadParameters
headParameters.parties
      Bool -> Bool -> Bool
&& (Payment -> CardanoSigningKey
from Payment
decommitTx, Payment -> Value
value Payment
decommitTx) (CardanoSigningKey, Value) -> [(CardanoSigningKey, Value)] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`List.elem` OffChainState -> UTxOType Payment
confirmedUTxO OffChainState
offChainState
  precondition WorldState{$sel:hydraState:WorldState :: WorldState -> GlobalState
hydraState = Open{}} (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
      Initial{} -> Bool
False
      Open{} -> Bool
True
      Closed{} -> Bool
True
      Final{} -> Bool
False
  precondition WorldState
_ Action WorldState a
R:ActionWorldStatea a
StopTheWorld =
    Bool
True
  precondition WorldState
_ Action WorldState a
_ =
    Bool
False

  nextState :: forall a.
Typeable a =>
WorldState -> Action WorldState a -> Var a -> WorldState
nextState s :: WorldState
s@WorldState{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{[(SigningKey HydraKey, CardanoSigningKey)]
$sel:seedKeys:Seed :: Action WorldState () -> [(SigningKey HydraKey, CardanoSigningKey)]
seedKeys :: [(SigningKey HydraKey, CardanoSigningKey)]
seedKeys, ContestationPeriod
$sel:contestationPeriod:Seed :: Action WorldState () -> ContestationPeriod
contestationPeriod :: ContestationPeriod
contestationPeriod, Uncommitted
$sel:toCommit:Seed :: Action WorldState () -> Uncommitted
toCommit :: Uncommitted
toCommit} ->
        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, Uncommitted
$sel:toCommit:Start :: Uncommitted
toCommit :: Uncommitted
toCommit}
        idleParties :: [Party]
idleParties = ((SigningKey HydraKey, CardanoSigningKey) -> Party)
-> [(SigningKey HydraKey, CardanoSigningKey)] -> [Party]
forall a b. (a -> b) -> [a] -> [b]
map (SigningKey HydraKey -> Party
deriveParty (SigningKey HydraKey -> Party)
-> ((SigningKey HydraKey, CardanoSigningKey)
    -> SigningKey HydraKey)
-> (SigningKey HydraKey, CardanoSigningKey)
-> Party
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SigningKey HydraKey, CardanoSigningKey) -> SigningKey HydraKey
forall a b. (a, b) -> a
fst) [(SigningKey HydraKey, CardanoSigningKey)]
seedKeys
        cardanoKeys :: [VerificationKey PaymentKey]
cardanoKeys = ((SigningKey HydraKey, CardanoSigningKey)
 -> VerificationKey PaymentKey)
-> [(SigningKey HydraKey, CardanoSigningKey)]
-> [VerificationKey PaymentKey]
forall a b. (a -> b) -> [a] -> [b]
map (SigningKey PaymentKey -> VerificationKey PaymentKey
forall keyrole.
(Key keyrole, HasTypeProxy keyrole) =>
SigningKey keyrole -> VerificationKey keyrole
getVerificationKey (SigningKey PaymentKey -> VerificationKey PaymentKey)
-> ((SigningKey HydraKey, CardanoSigningKey)
    -> SigningKey PaymentKey)
-> (SigningKey HydraKey, CardanoSigningKey)
-> VerificationKey PaymentKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CardanoSigningKey -> SigningKey PaymentKey
signingKey (CardanoSigningKey -> SigningKey PaymentKey)
-> ((SigningKey HydraKey, CardanoSigningKey) -> CardanoSigningKey)
-> (SigningKey HydraKey, CardanoSigningKey)
-> SigningKey PaymentKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SigningKey HydraKey, CardanoSigningKey) -> CardanoSigningKey
forall a b. (a, b) -> b
snd) [(SigningKey HydraKey, CardanoSigningKey)]
seedKeys
      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, Uncommitted
$sel:toCommit:Start :: GlobalState -> Uncommitted
toCommit :: Uncommitted
toCommit} ->
            Initial
              { $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:commits:Start :: Uncommitted
commits = Map Party [(CardanoSigningKey, Value)]
Uncommitted
forall a. Monoid a => a
mempty
              , $sel:pendingCommits:Start :: Uncommitted
pendingCommits = Uncommitted
toCommit
              }
          GlobalState
_ -> Text -> GlobalState
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"unexpected state"
      Commit Var HeadId
_ Party
party UTxOType Payment
utxo ->
        WorldState
s{hydraState = updateWithCommit hydraState}
       where
        updateWithCommit :: GlobalState -> GlobalState
updateWithCommit = \case
          Initial{Var HeadId
$sel:headIdVar:Start :: GlobalState -> Var HeadId
headIdVar :: Var HeadId
headIdVar, HeadParameters
$sel:headParameters:Start :: GlobalState -> HeadParameters
headParameters :: HeadParameters
headParameters, Uncommitted
$sel:commits:Start :: GlobalState -> Uncommitted
commits :: Uncommitted
commits, Uncommitted
$sel:pendingCommits:Start :: GlobalState -> Uncommitted
pendingCommits :: Uncommitted
pendingCommits} -> GlobalState
updatedState
           where
            commits' :: Map Party [(CardanoSigningKey, Value)]
commits' = Party
-> [(CardanoSigningKey, Value)]
-> Map Party [(CardanoSigningKey, Value)]
-> Map Party [(CardanoSigningKey, Value)]
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Party
party [(CardanoSigningKey, Value)]
UTxOType Payment
utxo Map Party [(CardanoSigningKey, Value)]
Uncommitted
commits
            pendingCommits' :: Map Party [(CardanoSigningKey, Value)]
pendingCommits' = Party
party Party
-> Map Party [(CardanoSigningKey, Value)]
-> Map Party [(CardanoSigningKey, Value)]
forall k a. Ord k => k -> Map k a -> Map k a
`Map.delete` Map Party [(CardanoSigningKey, Value)]
Uncommitted
pendingCommits
            updatedState :: GlobalState
updatedState =
              if Map Party [(CardanoSigningKey, Value)] -> Bool
forall a. Map Party a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Map Party [(CardanoSigningKey, Value)]
pendingCommits'
                then
                  Open
                    { Var HeadId
$sel:headIdVar:Start :: Var HeadId
headIdVar :: Var HeadId
headIdVar
                    , HeadParameters
$sel:headParameters:Start :: HeadParameters
headParameters :: HeadParameters
headParameters
                    , $sel:committed:Start :: Uncommitted
committed = Map Party [(CardanoSigningKey, Value)]
Uncommitted
commits'
                    , $sel:offChainState:Start :: OffChainState
offChainState =
                        OffChainState
                          { $sel:confirmedUTxO:OffChainState :: UTxOType Payment
confirmedUTxO = [[(CardanoSigningKey, Value)]] -> [(CardanoSigningKey, Value)]
forall a. Monoid a => [a] -> a
mconcat (Map Party [(CardanoSigningKey, Value)]
-> [[(CardanoSigningKey, Value)]]
forall k a. Map k a -> [a]
Map.elems Map Party [(CardanoSigningKey, Value)]
commits')
                          }
                    }
                else
                  Initial
                    { Var HeadId
$sel:headIdVar:Start :: Var HeadId
headIdVar :: Var HeadId
headIdVar
                    , HeadParameters
$sel:headParameters:Start :: HeadParameters
headParameters :: HeadParameters
headParameters
                    , $sel:commits:Start :: Uncommitted
commits = Map Party [(CardanoSigningKey, Value)]
Uncommitted
commits'
                    , $sel:pendingCommits:Start :: Uncommitted
pendingCommits = Map Party [(CardanoSigningKey, Value)]
Uncommitted
pendingCommits'
                    }
          GlobalState
_ -> Text -> GlobalState
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"unexpected state"
      Abort{} ->
        WorldState
s{hydraState = updateWithAbort hydraState}
       where
        updateWithAbort :: GlobalState -> GlobalState
updateWithAbort = \case
          Initial{Uncommitted
$sel:commits:Start :: GlobalState -> Uncommitted
commits :: Uncommitted
commits} -> UTxOType Payment -> GlobalState
Final [(CardanoSigningKey, Value)]
UTxOType Payment
committedUTxO
           where
            committedUTxO :: [(CardanoSigningKey, Value)]
committedUTxO = [[(CardanoSigningKey, Value)]] -> [(CardanoSigningKey, Value)]
forall a. Monoid a => [a] -> a
mconcat ([[(CardanoSigningKey, Value)]] -> [(CardanoSigningKey, Value)])
-> [[(CardanoSigningKey, Value)]] -> [(CardanoSigningKey, Value)]
forall a b. (a -> b) -> a -> b
$ Map Party [(CardanoSigningKey, Value)]
-> [[(CardanoSigningKey, Value)]]
forall k a. Map k a -> [a]
Map.elems Map Party [(CardanoSigningKey, Value)]
Uncommitted
commits
          GlobalState
_ -> UTxOType Payment -> GlobalState
Final [(CardanoSigningKey, Value)]
UTxOType Payment
forall a. Monoid a => a
mempty
      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{[(SigningKey HydraKey, CardanoSigningKey)]
$sel:seedKeys:Seed :: Action WorldState () -> [(SigningKey HydraKey, CardanoSigningKey)]
seedKeys :: [(SigningKey HydraKey, CardanoSigningKey)]
seedKeys, Uncommitted
$sel:toCommit:Seed :: Action WorldState () -> Uncommitted
toCommit :: Uncommitted
toCommit} -> do
      [(SigningKey HydraKey, CardanoSigningKey)]
seedKeys' <- [(SigningKey HydraKey, CardanoSigningKey)]
-> [[(SigningKey HydraKey, CardanoSigningKey)]]
forall a. Arbitrary a => a -> [a]
shrink [(SigningKey HydraKey, CardanoSigningKey)]
seedKeys
      Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> [()]) -> Bool -> [()]
forall a b. (a -> b) -> a -> b
$ [(SigningKey HydraKey, CardanoSigningKey)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(SigningKey HydraKey, CardanoSigningKey)]
seedKeys' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< [(SigningKey HydraKey, CardanoSigningKey)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(SigningKey HydraKey, CardanoSigningKey)]
seedKeys
      let toCommit' :: Map Party [(CardanoSigningKey, Value)]
toCommit' = (Party -> [(CardanoSigningKey, Value)] -> Bool)
-> Map Party [(CardanoSigningKey, Value)]
-> Map Party [(CardanoSigningKey, Value)]
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey (\Party
p [(CardanoSigningKey, Value)]
_ -> Party
p Party -> [Party] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` (SigningKey HydraKey -> Party
deriveParty (SigningKey HydraKey -> Party)
-> ((SigningKey HydraKey, CardanoSigningKey)
    -> SigningKey HydraKey)
-> (SigningKey HydraKey, CardanoSigningKey)
-> Party
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SigningKey HydraKey, CardanoSigningKey) -> SigningKey HydraKey
forall a b. (a, b) -> a
fst ((SigningKey HydraKey, CardanoSigningKey) -> Party)
-> [(SigningKey HydraKey, CardanoSigningKey)] -> [Party]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(SigningKey HydraKey, CardanoSigningKey)]
seedKeys')) Map Party [(CardanoSigningKey, Value)]
Uncommitted
toCommit
      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', toCommit = toCommit'}
    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
    Initial{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
    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
    Commit{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
    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
  [(SigningKey HydraKey, CardanoSigningKey)]
seedKeys <- Int
-> Gen [(SigningKey HydraKey, CardanoSigningKey)]
-> Gen [(SigningKey HydraKey, CardanoSigningKey)]
forall a. HasCallStack => Int -> Gen a -> Gen a
resize Int
maximumNumberOfParties Gen [(SigningKey HydraKey, CardanoSigningKey)]
partyKeys
  ContestationPeriod
contestationPeriod <- Gen ContestationPeriod
genContestationPeriod
  Map Party [(CardanoSigningKey, Value)]
toCommit <- [Map Party [(CardanoSigningKey, Value)]]
-> Map Party [(CardanoSigningKey, Value)]
forall a. Monoid a => [a] -> a
mconcat ([Map Party [(CardanoSigningKey, Value)]]
 -> Map Party [(CardanoSigningKey, Value)])
-> Gen [Map Party [(CardanoSigningKey, Value)]]
-> Gen (Map Party [(CardanoSigningKey, Value)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((SigningKey HydraKey, CardanoSigningKey)
 -> Gen (Map Party [(CardanoSigningKey, Value)]))
-> [(SigningKey HydraKey, CardanoSigningKey)]
-> Gen [Map Party [(CardanoSigningKey, Value)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (SigningKey HydraKey, CardanoSigningKey)
-> Gen (Map Party [(CardanoSigningKey, Value)])
genToCommit [(SigningKey HydraKey, CardanoSigningKey)]
seedKeys
  [(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 <- (SigningKey HydraKey, CardanoSigningKey) -> CardanoSigningKey
forall a b. (a, b) -> b
snd ((SigningKey HydraKey, CardanoSigningKey) -> CardanoSigningKey)
-> Gen (SigningKey HydraKey, CardanoSigningKey)
-> Gen CardanoSigningKey
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(SigningKey HydraKey, CardanoSigningKey)]
-> Gen (SigningKey HydraKey, CardanoSigningKey)
forall a. HasCallStack => [a] -> Gen a
elements [(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{[(SigningKey HydraKey, CardanoSigningKey)]
$sel:seedKeys:Seed :: [(SigningKey HydraKey, CardanoSigningKey)]
seedKeys :: [(SigningKey HydraKey, CardanoSigningKey)]
seedKeys, ContestationPeriod
$sel:contestationPeriod:Seed :: ContestationPeriod
contestationPeriod :: ContestationPeriod
contestationPeriod, Map Party [(CardanoSigningKey, Value)]
Uncommitted
$sel:toCommit:Seed :: Uncommitted
toCommit :: Map Party [(CardanoSigningKey, Value)]
toCommit, [(CardanoSigningKey, Value)]
UTxOType Payment
$sel:additionalUTxO:Seed :: UTxOType Payment
additionalUTxO :: [(CardanoSigningKey, Value)]
additionalUTxO}

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

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

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

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

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

-- * Running the model

-- | Concrete state needed to run actions against the implementation.
-- This state is used and might be updated when actually `perform`ing actions generated from the `StateModel`.
data Nodes m = Nodes
  { forall (m :: * -> *). Nodes m -> Map Party (TestHydraClient Tx m)
nodes :: Map.Map Party (TestHydraClient Tx m)
  -- ^ Map from party identifiers to a /handle/ for interacting with a node.
  , forall (m :: * -> *). Nodes m -> Tracer m (HydraLog Tx)
logger :: Tracer m (HydraLog Tx)
  -- ^ Logger used by each node.
  -- The reason we put this here is because the concrete value needs to be
  -- instantiated upon the test run initialisation, outiside of the model.
  , forall (m :: * -> *). Nodes m -> [Async m ()]
threads :: [Async m ()]
  -- ^ List of threads spawned when executing `RunMonad`
  , forall (m :: * -> *). Nodes m -> SimulatedChainNetwork Tx m
chain :: SimulatedChainNetwork Tx m
  }

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

-- | Our execution `MonadTrans`former.
--
-- This type is needed in order to keep the execution monad `m` abstract  and thus
-- simplify the definition of the `RunModel` instance which requires a proper definition
-- of `Realized`  type family. See [this issue](https://github.com/input-output-hk/quickcheck-dynamic/issues/29)
-- for a discussion on why this monad is needed.
--
-- We could perhaps getaway with it and just have a type based on `IOSim` monad
-- but this is cumbersome to write.
newtype RunMonad m a = RunMonad {forall (m :: * -> *) a. RunMonad m a -> ReaderT (RunState m) m a
runMonad :: ReaderT (RunState m) m a}
  deriving newtype ((forall a b. (a -> b) -> RunMonad m a -> RunMonad m b)
-> (forall a b. a -> RunMonad m b -> RunMonad m a)
-> Functor (RunMonad m)
forall a b. a -> RunMonad m b -> RunMonad m a
forall a b. (a -> b) -> RunMonad m a -> RunMonad m b
forall (m :: * -> *) a b.
Functor m =>
a -> RunMonad m b -> RunMonad m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> RunMonad m a -> RunMonad m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> RunMonad m a -> RunMonad m b
fmap :: forall a b. (a -> b) -> RunMonad m a -> RunMonad m b
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> RunMonad m b -> RunMonad m a
<$ :: forall a b. a -> RunMonad m b -> RunMonad m a
Functor, Functor (RunMonad m)
Functor (RunMonad m) =>
(forall a. a -> RunMonad m a)
-> (forall a b.
    RunMonad m (a -> b) -> RunMonad m a -> RunMonad m b)
-> (forall a b c.
    (a -> b -> c) -> RunMonad m a -> RunMonad m b -> RunMonad m c)
-> (forall a b. RunMonad m a -> RunMonad m b -> RunMonad m b)
-> (forall a b. RunMonad m a -> RunMonad m b -> RunMonad m a)
-> Applicative (RunMonad m)
forall a. a -> RunMonad m a
forall a b. RunMonad m a -> RunMonad m b -> RunMonad m a
forall a b. RunMonad m a -> RunMonad m b -> RunMonad m b
forall a b. RunMonad m (a -> b) -> RunMonad m a -> RunMonad m b
forall a b c.
(a -> b -> c) -> RunMonad m a -> RunMonad m b -> RunMonad m c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
forall (m :: * -> *). Applicative m => Functor (RunMonad m)
forall (m :: * -> *) a. Applicative m => a -> RunMonad m a
forall (m :: * -> *) a b.
Applicative m =>
RunMonad m a -> RunMonad m b -> RunMonad m a
forall (m :: * -> *) a b.
Applicative m =>
RunMonad m a -> RunMonad m b -> RunMonad m b
forall (m :: * -> *) a b.
Applicative m =>
RunMonad m (a -> b) -> RunMonad m a -> RunMonad m b
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> RunMonad m a -> RunMonad m b -> RunMonad m c
$cpure :: forall (m :: * -> *) a. Applicative m => a -> RunMonad m a
pure :: forall a. a -> RunMonad m a
$c<*> :: forall (m :: * -> *) a b.
Applicative m =>
RunMonad m (a -> b) -> RunMonad m a -> RunMonad m b
<*> :: forall a b. RunMonad m (a -> b) -> RunMonad m a -> RunMonad m b
$cliftA2 :: forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> RunMonad m a -> RunMonad m b -> RunMonad m c
liftA2 :: forall a b c.
(a -> b -> c) -> RunMonad m a -> RunMonad m b -> RunMonad m c
$c*> :: forall (m :: * -> *) a b.
Applicative m =>
RunMonad m a -> RunMonad m b -> RunMonad m b
*> :: forall a b. RunMonad m a -> RunMonad m b -> RunMonad m b
$c<* :: forall (m :: * -> *) a b.
Applicative m =>
RunMonad m a -> RunMonad m b -> RunMonad m a
<* :: forall a b. RunMonad m a -> RunMonad m b -> RunMonad m a
Applicative, Applicative (RunMonad m)
Applicative (RunMonad m) =>
(forall a b. RunMonad m a -> (a -> RunMonad m b) -> RunMonad m b)
-> (forall a b. RunMonad m a -> RunMonad m b -> RunMonad m b)
-> (forall a. a -> RunMonad m a)
-> Monad (RunMonad m)
forall a. a -> RunMonad m a
forall a b. RunMonad m a -> RunMonad m b -> RunMonad m b
forall a b. RunMonad m a -> (a -> RunMonad m b) -> RunMonad m b
forall (m :: * -> *). Monad m => Applicative (RunMonad m)
forall (m :: * -> *) a. Monad m => a -> RunMonad m a
forall (m :: * -> *) a b.
Monad m =>
RunMonad m a -> RunMonad m b -> RunMonad m b
forall (m :: * -> *) a b.
Monad m =>
RunMonad m a -> (a -> RunMonad m b) -> RunMonad m b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
RunMonad m a -> (a -> RunMonad m b) -> RunMonad m b
>>= :: forall a b. RunMonad m a -> (a -> RunMonad m b) -> RunMonad m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
RunMonad m a -> RunMonad m b -> RunMonad m b
>> :: forall a b. RunMonad m a -> RunMonad m b -> RunMonad m b
$creturn :: forall (m :: * -> *) a. Monad m => a -> RunMonad m a
return :: forall a. a -> RunMonad m a
Monad, MonadReader (RunState m), Monad (RunMonad m)
Monad (RunMonad m) =>
(forall e a. Exception e => e -> RunMonad m a)
-> (forall a b c.
    RunMonad m a
    -> (a -> RunMonad m b) -> (a -> RunMonad m c) -> RunMonad m c)
-> (forall a b c.
    RunMonad m a -> RunMonad m b -> RunMonad m c -> RunMonad m c)
-> (forall a b. RunMonad m a -> RunMonad m b -> RunMonad m a)
-> MonadThrow (RunMonad m)
forall e a. Exception e => e -> RunMonad m a
forall a b. RunMonad m a -> RunMonad m b -> RunMonad m a
forall a b c.
RunMonad m a -> RunMonad m b -> RunMonad m c -> RunMonad m c
forall a b c.
RunMonad m a
-> (a -> RunMonad m b) -> (a -> RunMonad m c) -> RunMonad m c
forall (m :: * -> *).
Monad m =>
(forall e a. Exception e => e -> m a)
-> (forall a b c. m a -> (a -> m b) -> (a -> m c) -> m c)
-> (forall a b c. m a -> m b -> m c -> m c)
-> (forall a b. m a -> m b -> m a)
-> MonadThrow m
forall (m :: * -> *). MonadThrow m => Monad (RunMonad m)
forall (m :: * -> *) e a.
(MonadThrow m, Exception e) =>
e -> RunMonad m a
forall (m :: * -> *) a b.
MonadThrow m =>
RunMonad m a -> RunMonad m b -> RunMonad m a
forall (m :: * -> *) a b c.
MonadThrow m =>
RunMonad m a -> RunMonad m b -> RunMonad m c -> RunMonad m c
forall (m :: * -> *) a b c.
MonadThrow m =>
RunMonad m a
-> (a -> RunMonad m b) -> (a -> RunMonad m c) -> RunMonad m c
$cthrowIO :: forall (m :: * -> *) e a.
(MonadThrow m, Exception e) =>
e -> RunMonad m a
throwIO :: forall e a. Exception e => e -> RunMonad m a
$cbracket :: forall (m :: * -> *) a b c.
MonadThrow m =>
RunMonad m a
-> (a -> RunMonad m b) -> (a -> RunMonad m c) -> RunMonad m c
bracket :: forall a b c.
RunMonad m a
-> (a -> RunMonad m b) -> (a -> RunMonad m c) -> RunMonad m c
$cbracket_ :: forall (m :: * -> *) a b c.
MonadThrow m =>
RunMonad m a -> RunMonad m b -> RunMonad m c -> RunMonad m c
bracket_ :: forall a b c.
RunMonad m a -> RunMonad m b -> RunMonad m c -> RunMonad m c
$cfinally :: forall (m :: * -> *) a b.
MonadThrow m =>
RunMonad m a -> RunMonad m b -> RunMonad m a
finally :: forall a b. RunMonad m a -> RunMonad m b -> RunMonad m a
MonadThrow, 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 Era] -> [TxOut CtxUTxO Era]
forall ctx. [TxOut ctx] -> [TxOut ctx]
sortTxOuts ([(CardanoSigningKey, Value)] -> [TxOut CtxUTxO Era]
toTxOuts [(CardanoSigningKey, Value)]
UTxOType Payment
finalUTxO) [TxOut CtxUTxO Era]
-> [TxOut CtxUTxO Era] -> PostconditionM (RunMonad m) Bool
forall a (m :: * -> *).
(Eq a, Show a, Monad m) =>
a -> a -> PostconditionM m Bool
=== [TxOut CtxUTxO Era] -> [TxOut CtxUTxO Era]
forall ctx. [TxOut ctx] -> [TxOut ctx]
sortTxOuts (UTxO' (TxOut CtxUTxO Era) -> [TxOut CtxUTxO Era]
forall a. UTxO' a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Foldable.toList UTxO' (TxOut CtxUTxO Era)
Realized (RunMonad m) a
result)
          GlobalState
_ -> Bool -> PostconditionM (RunMonad m) Bool
forall a. a -> PostconditionM (RunMonad m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
      Action WorldState a
_ -> Bool -> PostconditionM (RunMonad m) Bool
forall a. a -> PostconditionM (RunMonad m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True

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

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

-- ** Performing actions

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

  mockChain :: SimulatedChainNetwork Tx m
mockChain@SimulatedChainNetwork{Async m ()
tickThread :: Async m ()
$sel:tickThread:SimulatedChainNetwork :: forall tx (m :: * -> *). SimulatedChainNetwork tx m -> Async m ()
tickThread} <-
    m (SimulatedChainNetwork Tx m)
-> RunMonad m (SimulatedChainNetwork Tx m)
forall (m :: * -> *) a. Monad m => m a -> RunMonad m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (SimulatedChainNetwork Tx m)
 -> RunMonad m (SimulatedChainNetwork Tx m))
-> m (SimulatedChainNetwork Tx m)
-> RunMonad m (SimulatedChainNetwork Tx m)
forall a b. (a -> b) -> a -> b
$
      Tracer m CardanoChainLog
-> [(SigningKey HydraKey, CardanoSigningKey)]
-> UTxO' (TxOut CtxUTxO Era)
-> m (SimulatedChainNetwork Tx m)
forall (m :: * -> *).
(MonadTimer m, MonadAsync m, MonadMask m, MonadThrow (STM m),
 MonadLabelledSTM m, MonadFork m, MonadDelay m) =>
Tracer m CardanoChainLog
-> [(SigningKey HydraKey, CardanoSigningKey)]
-> UTxO' (TxOut CtxUTxO Era)
-> 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) [(SigningKey HydraKey, CardanoSigningKey)]
seedKeys (([(CardanoSigningKey, Value)] -> UTxO' (TxOut CtxUTxO Era))
-> [[(CardanoSigningKey, Value)]] -> UTxO' (TxOut CtxUTxO Era)
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap [(CardanoSigningKey, Value)] -> UTxO' (TxOut CtxUTxO Era)
UTxOType Payment -> UTxOType Tx
toRealUTxO ([[(CardanoSigningKey, Value)]] -> UTxO' (TxOut CtxUTxO Era))
-> [[(CardanoSigningKey, Value)]] -> UTxO' (TxOut CtxUTxO Era)
forall a b. (a -> b) -> a -> b
$ Map Party [(CardanoSigningKey, Value)]
-> [[(CardanoSigningKey, Value)]]
forall k a. Map k a -> [a]
Map.elems Map Party [(CardanoSigningKey, Value)]
Uncommitted
futureCommits)
  Async m () -> RunMonad m ()
forall {m :: * -> *} {m :: * -> *}.
MonadState (Nodes m) m =>
Async m () -> m ()
pushThread Async m ()
tickThread

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

  (Nodes m -> Nodes m) -> RunMonad m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Nodes m -> Nodes m) -> RunMonad m ())
-> (Nodes m -> Nodes m) -> RunMonad m ()
forall a b. (a -> b) -> a -> b
$ \Nodes m
n ->
    Nodes m
n{nodes = Map.fromList clients, chain = mockChain}
 where
  parties :: [Party]
parties = ((SigningKey HydraKey, CardanoSigningKey) -> Party)
-> [(SigningKey HydraKey, CardanoSigningKey)] -> [Party]
forall a b. (a -> b) -> [a] -> [b]
map (SigningKey HydraKey -> Party
deriveParty (SigningKey HydraKey -> Party)
-> ((SigningKey HydraKey, CardanoSigningKey)
    -> SigningKey HydraKey)
-> (SigningKey HydraKey, CardanoSigningKey)
-> Party
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SigningKey HydraKey, CardanoSigningKey) -> SigningKey HydraKey
forall a b. (a, b) -> a
fst) [(SigningKey HydraKey, CardanoSigningKey)]
seedKeys

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

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

performCommit ::
  (MonadThrow m, MonadTimer m, MonadAsync m) =>
  HeadId ->
  Party ->
  [(CardanoSigningKey, Value)] ->
  RunMonad m ()
performCommit :: forall (m :: * -> *).
(MonadThrow m, MonadTimer m, MonadAsync m) =>
HeadId -> Party -> [(CardanoSigningKey, Value)] -> RunMonad m ()
performCommit HeadId
headId Party
party [(CardanoSigningKey, Value)]
paymentUTxO = do
  SimulatedChainNetwork{HeadId -> Party -> UTxOType Tx -> m ()
simulateCommit :: HeadId -> Party -> UTxOType Tx -> m ()
$sel:simulateCommit:SimulatedChainNetwork :: forall tx (m :: * -> *).
SimulatedChainNetwork tx m
-> HeadId -> Party -> UTxOType tx -> m ()
simulateCommit} <- (Nodes m -> SimulatedChainNetwork Tx m)
-> RunMonad m (SimulatedChainNetwork Tx m)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Nodes m -> SimulatedChainNetwork Tx m
forall (m :: * -> *). Nodes m -> SimulatedChainNetwork Tx m
chain
  Map Party (TestHydraClient Tx m)
nodes <- (Nodes m -> Map Party (TestHydraClient Tx m))
-> RunMonad m (Map Party (TestHydraClient Tx m))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Nodes m -> Map Party (TestHydraClient Tx m)
forall (m :: * -> *). Nodes m -> Map Party (TestHydraClient Tx m)
nodes
  m () -> RunMonad m ()
forall (m :: * -> *) a. Monad m => m a -> RunMonad m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> RunMonad m ()) -> m () -> RunMonad m ()
forall a b. (a -> b) -> a -> b
$ do
    HeadId -> Party -> UTxOType Tx -> m ()
simulateCommit HeadId
headId Party
party (UTxOType Payment -> UTxOType Tx
toRealUTxO [(CardanoSigningKey, Value)]
UTxOType Payment
paymentUTxO)
    [TestHydraClient Tx m] -> (ServerOutput Tx -> Maybe ()) -> m ()
forall tx (m :: * -> *) a.
(Show (ServerOutput tx), HasCallStack, MonadThrow m, MonadAsync m,
 MonadTimer 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
      Committed{} -> () -> Maybe ()
forall a. a -> Maybe a
Just ()
      ServerOutput Tx
_ -> Maybe ()
forall a. Maybe a
Nothing

performDeposit ::
  (MonadThrow m, MonadTimer m, MonadAsync m, MonadTime m) =>
  HeadId ->
  [(CardanoSigningKey, Value)] ->
  RunMonad m ()
performDeposit :: forall (m :: * -> *).
(MonadThrow m, MonadTimer m, MonadAsync m, MonadTime 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, 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) =>
  Party ->
  Payment ->
  RunMonad m ()
performDecommit :: forall (m :: * -> *).
(MonadThrow m, MonadTimer m, MonadAsync m, MonadDelay m) =>
Party -> Payment -> RunMonad m ()
performDecommit Party
party Payment
tx = do
  let recipient :: AddressInEra
recipient = NetworkId -> VerificationKey PaymentKey -> AddressInEra
forall era.
IsShelleyBasedEra era =>
NetworkId -> VerificationKey PaymentKey -> AddressInEra era
mkVkAddress NetworkId
testNetworkId (VerificationKey PaymentKey -> AddressInEra)
-> (CardanoSigningKey -> VerificationKey PaymentKey)
-> CardanoSigningKey
-> AddressInEra
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SigningKey PaymentKey -> VerificationKey PaymentKey
forall keyrole.
(Key keyrole, HasTypeProxy keyrole) =>
SigningKey keyrole -> VerificationKey keyrole
getVerificationKey (SigningKey PaymentKey -> VerificationKey PaymentKey)
-> (CardanoSigningKey -> SigningKey PaymentKey)
-> CardanoSigningKey
-> VerificationKey PaymentKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CardanoSigningKey -> SigningKey PaymentKey
signingKey (CardanoSigningKey -> AddressInEra)
-> CardanoSigningKey -> AddressInEra
forall a b. (a -> b) -> a -> b
$ Payment -> CardanoSigningKey
to Payment
tx
  Map Party (TestHydraClient Tx m)
nodes <- (Nodes m -> Map Party (TestHydraClient Tx m))
-> RunMonad m (Map Party (TestHydraClient Tx m))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Nodes m -> Map Party (TestHydraClient Tx m)
forall (m :: * -> *). Nodes m -> Map Party (TestHydraClient Tx m)
nodes
  let thisNode :: TestHydraClient Tx m
thisNode = Map Party (TestHydraClient Tx m)
nodes Map Party (TestHydraClient Tx m) -> Party -> TestHydraClient Tx m
forall k a. Ord k => Map k a -> k -> a
! Party
party
  TestHydraClient Tx m -> RunMonad m ()
forall (m :: * -> *) tx.
MonadDelay m =>
TestHydraClient tx m -> RunMonad m ()
waitForOpen TestHydraClient Tx m
thisNode

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

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

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

  m () -> RunMonad m ()
forall (m :: * -> *) a. Monad m => m a -> RunMonad m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> RunMonad m ())
-> ((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, 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 Era] -> [TxOut CtxUTxO Era]
forall ctx. [TxOut ctx] -> [TxOut ctx]
sortTxOuts (UTxO' (TxOut CtxUTxO Era) -> [TxOut CtxUTxO Era]
forall a. UTxO' a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Foldable.toList UTxOType Tx
UTxO' (TxOut CtxUTxO Era)
distributedUTxO) [TxOut CtxUTxO Era] -> [TxOut CtxUTxO Era] -> Bool
forall a. Eq a => a -> a -> Bool
== [TxOut CtxUTxO Era] -> [TxOut CtxUTxO Era]
forall ctx. [TxOut ctx] -> [TxOut ctx]
sortTxOuts (UTxO' (TxOut CtxUTxO Era) -> [TxOut CtxUTxO Era]
forall a. UTxO' a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Foldable.toList (UTxO' (TxOut CtxUTxO Era) -> [TxOut CtxUTxO Era])
-> UTxO' (TxOut CtxUTxO Era) -> [TxOut CtxUTxO Era]
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) =>
  Party ->
  Payment ->
  RunMonad m Payment
performNewTx :: forall (m :: * -> *).
(MonadThrow m, MonadAsync m, MonadTimer m, MonadDelay m) =>
Party -> Payment -> RunMonad m Payment
performNewTx Party
party Payment
tx = do
  let recipient :: AddressInEra
recipient = NetworkId -> VerificationKey PaymentKey -> AddressInEra
forall era.
IsShelleyBasedEra era =>
NetworkId -> VerificationKey PaymentKey -> AddressInEra era
mkVkAddress NetworkId
testNetworkId (VerificationKey PaymentKey -> AddressInEra)
-> (CardanoSigningKey -> VerificationKey PaymentKey)
-> CardanoSigningKey
-> AddressInEra
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SigningKey PaymentKey -> VerificationKey PaymentKey
forall keyrole.
(Key keyrole, HasTypeProxy keyrole) =>
SigningKey keyrole -> VerificationKey keyrole
getVerificationKey (SigningKey PaymentKey -> VerificationKey PaymentKey)
-> (CardanoSigningKey -> SigningKey PaymentKey)
-> CardanoSigningKey
-> VerificationKey PaymentKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CardanoSigningKey -> SigningKey PaymentKey
signingKey (CardanoSigningKey -> AddressInEra)
-> CardanoSigningKey -> AddressInEra
forall a b. (a -> b) -> a -> b
$ Payment -> CardanoSigningKey
to Payment
tx
  Map Party (TestHydraClient Tx m)
nodes <- (Nodes m -> Map Party (TestHydraClient Tx m))
-> RunMonad m (Map Party (TestHydraClient Tx m))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Nodes m -> Map Party (TestHydraClient Tx m)
forall (m :: * -> *). Nodes m -> Map Party (TestHydraClient Tx m)
nodes
  let thisNode :: TestHydraClient Tx m
thisNode = Map Party (TestHydraClient Tx m)
nodes Map Party (TestHydraClient Tx m) -> Party -> TestHydraClient Tx m
forall k a. Ord k => Map k a -> k -> a
! Party
party
  TestHydraClient Tx m -> RunMonad m ()
forall (m :: * -> *) tx.
MonadDelay m =>
TestHydraClient tx m -> RunMonad m ()
waitForOpen TestHydraClient Tx m
thisNode

  (TxIn
i, TxOut CtxUTxO Era
o) <-
    m (Either (UTxO' (TxOut CtxUTxO Era)) (TxIn, TxOut CtxUTxO Era))
-> RunMonad
     m (Either (UTxO' (TxOut CtxUTxO Era)) (TxIn, TxOut CtxUTxO Era))
forall (m :: * -> *) a. Monad m => m a -> RunMonad m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (UTxO' (TxOut CtxUTxO Era)
-> CardanoSigningKey
-> Value
-> TestHydraClient Tx m
-> m (Either (UTxO' (TxOut CtxUTxO Era)) (TxIn, TxOut CtxUTxO Era))
forall (m :: * -> *).
MonadDelay m =>
UTxO' (TxOut CtxUTxO Era)
-> CardanoSigningKey
-> Value
-> TestHydraClient Tx m
-> m (Either (UTxO' (TxOut CtxUTxO Era)) (TxIn, TxOut CtxUTxO Era))
waitForUTxOToSpend UTxO' (TxOut CtxUTxO Era)
forall a. Monoid a => a
mempty (Payment -> CardanoSigningKey
from Payment
tx) (Payment -> Value
value Payment
tx) TestHydraClient Tx m
thisNode) RunMonad
  m (Either (UTxO' (TxOut CtxUTxO Era)) (TxIn, TxOut CtxUTxO Era))
-> (Either (UTxO' (TxOut CtxUTxO Era)) (TxIn, TxOut CtxUTxO Era)
    -> RunMonad m (TxIn, TxOut CtxUTxO Era))
-> RunMonad m (TxIn, TxOut CtxUTxO Era)
forall a b. RunMonad m a -> (a -> RunMonad m b) -> RunMonad m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Left UTxO' (TxOut CtxUTxO Era)
u -> String -> RunMonad m (TxIn, TxOut CtxUTxO Era)
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure (String -> RunMonad m (TxIn, TxOut CtxUTxO Era))
-> String -> RunMonad m (TxIn, TxOut CtxUTxO Era)
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' (TxOut CtxUTxO Era) -> String
forall b a. (Show a, IsString b) => a -> b
show UTxO' (TxOut CtxUTxO Era)
u
      Right (TxIn, TxOut CtxUTxO Era)
ok -> (TxIn, TxOut CtxUTxO Era) -> RunMonad m (TxIn, TxOut CtxUTxO Era)
forall a. a -> RunMonad m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxIn, TxOut CtxUTxO Era)
ok

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

  Party
party Party -> ClientInput Tx -> RunMonad m ()
forall (m :: * -> *).
(MonadSTM m, MonadThrow m) =>
Party -> ClientInput Tx -> RunMonad m ()
`sendsInput` Tx -> ClientInput Tx
forall tx. tx -> ClientInput tx
Input.NewTx Tx
realTx
  m () -> 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, 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) => Party -> RunMonad m HeadId
performInit :: forall (m :: * -> *).
(MonadThrow m, MonadAsync m, MonadTimer 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, 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
    HeadIsInitializing{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

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

  Map Party (TestHydraClient Tx m)
nodes <- (Nodes m -> Map Party (TestHydraClient Tx m))
-> RunMonad m (Map Party (TestHydraClient Tx m))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Nodes m -> Map Party (TestHydraClient Tx m)
forall (m :: * -> *). Nodes m -> Map Party (TestHydraClient Tx m)
nodes
  m () -> RunMonad m ()
forall (m :: * -> *) a. Monad m => m a -> RunMonad m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> RunMonad m ())
-> ((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, 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
    HeadIsAborted{} -> () -> Maybe ()
forall a. a -> Maybe a
Just ()
    ServerOutput Tx
_ -> Maybe ()
forall a. Maybe a
Nothing

performClose :: (MonadThrow m, MonadAsync m, MonadTimer m, MonadDelay m) => Party -> RunMonad m ()
performClose :: forall (m :: * -> *).
(MonadThrow m, MonadAsync m, MonadTimer m, MonadDelay m) =>
Party -> RunMonad m ()
performClose Party
party = do
  Map Party (TestHydraClient Tx m)
nodes <- (Nodes m -> Map Party (TestHydraClient Tx m))
-> RunMonad m (Map Party (TestHydraClient Tx m))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Nodes m -> Map Party (TestHydraClient Tx m)
forall (m :: * -> *). Nodes m -> Map Party (TestHydraClient Tx m)
nodes
  let thisNode :: TestHydraClient Tx m
thisNode = Map Party (TestHydraClient Tx m)
nodes Map Party (TestHydraClient Tx m) -> Party -> TestHydraClient Tx m
forall k a. Ord k => Map k a -> k -> a
! Party
party
  TestHydraClient Tx m -> RunMonad m ()
forall (m :: * -> *) tx.
MonadDelay m =>
TestHydraClient tx m -> RunMonad m ()
waitForOpen TestHydraClient Tx m
thisNode
  Party
party Party -> ClientInput Tx -> RunMonad m ()
forall (m :: * -> *).
(MonadSTM m, MonadThrow m) =>
Party -> ClientInput Tx -> RunMonad m ()
`sendsInput` ClientInput Tx
forall tx. ClientInput tx
Input.Close

  m () -> RunMonad m ()
forall (m :: * -> *) a. Monad m => m a -> RunMonad m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> RunMonad m ())
-> ((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, 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' (TxOut CtxUTxO Era))
performFanout Party
party = do
  Map Party (TestHydraClient Tx m)
nodes <- (Nodes m -> Map Party (TestHydraClient Tx m))
-> RunMonad m (Map Party (TestHydraClient Tx m))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Nodes m -> Map Party (TestHydraClient Tx m)
forall (m :: * -> *). Nodes m -> Map Party (TestHydraClient Tx m)
nodes
  let thisNode :: TestHydraClient Tx m
thisNode = Map Party (TestHydraClient Tx m)
nodes Map Party (TestHydraClient Tx m) -> Party -> TestHydraClient Tx m
forall k a. Ord k => Map k a -> k -> a
! Party
party
  TestHydraClient Tx m -> RunMonad m ()
forall (m :: * -> *) tx.
MonadDelay m =>
TestHydraClient tx m -> RunMonad m ()
waitForReadyToFanout TestHydraClient Tx m
thisNode
  Party
party Party -> ClientInput Tx -> RunMonad m ()
forall (m :: * -> *).
(MonadSTM m, MonadThrow m) =>
Party -> ClientInput Tx -> RunMonad m ()
`sendsInput` ClientInput Tx
forall tx. ClientInput tx
Input.Fanout
  TestHydraClient Tx m -> Int -> RunMonad m (UTxOType Tx)
forall {t} {t :: (* -> *) -> * -> *} {m :: * -> *} {tx}.
(Eq t, Num t, MonadThrow (t m), MonadTrans t, MonadDelay m) =>
TestHydraClient tx m -> t -> t m (UTxOType tx)
findInOutput TestHydraClient Tx m
thisNode (Int
100 :: Int)
 where
  findInOutput :: TestHydraClient tx m -> t -> t m (UTxOType tx)
findInOutput TestHydraClient tx m
node t
n
    | t
n t -> t -> Bool
forall a. Eq a => a -> a -> Bool
== t
0 = String -> t m (UTxOType tx)
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure String
"Failed to perform Fanout"
    | Bool
otherwise = do
        [ServerOutput tx]
outputs <- m [ServerOutput tx] -> t m [ServerOutput tx]
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m [ServerOutput tx] -> t m [ServerOutput tx])
-> m [ServerOutput tx] -> t m [ServerOutput tx]
forall a b. (a -> b) -> a -> b
$ TestHydraClient tx m -> m [ServerOutput tx]
forall tx (m :: * -> *).
TestHydraClient tx m -> m [ServerOutput tx]
serverOutputs TestHydraClient tx m
node
        case (ServerOutput tx -> Bool)
-> [ServerOutput tx] -> Maybe (ServerOutput tx)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ServerOutput tx -> Bool
forall tx. ServerOutput tx -> Bool
headIsFinalized [ServerOutput tx]
outputs of
          Just (HeadIsFinalized{UTxOType tx
utxo :: UTxOType tx
$sel:utxo:NetworkConnected :: forall tx. ServerOutput tx -> UTxOType tx
utxo}) -> UTxOType tx -> t m (UTxOType tx)
forall a. a -> t m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure UTxOType tx
utxo
          Maybe (ServerOutput tx)
_ -> m () -> t m ()
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (DiffTime -> m ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
1) t m () -> t m (UTxOType tx) -> t m (UTxOType tx)
forall a b. t m a -> t m b -> t m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TestHydraClient tx m -> t -> t m (UTxOType tx)
findInOutput TestHydraClient tx m
node (t
n t -> t -> t
forall a. Num a => a -> a -> a
- t
1)
  headIsFinalized :: ServerOutput tx -> Bool
headIsFinalized = \case
    HeadIsFinalized{} -> Bool
True
    ServerOutput tx
_otherwise -> Bool
False

performCloseWithInitialSnapshot :: (MonadThrow m, MonadTimer m, MonadDelay m, MonadAsync m) => WorldState -> Party -> RunMonad m ()
performCloseWithInitialSnapshot :: forall (m :: * -> *).
(MonadThrow m, MonadTimer m, MonadDelay m, MonadAsync m) =>
WorldState -> Party -> RunMonad m ()
performCloseWithInitialSnapshot WorldState
st Party
party = do
  Map Party (TestHydraClient Tx m)
nodes <- (Nodes m -> Map Party (TestHydraClient Tx m))
-> RunMonad m (Map Party (TestHydraClient Tx m))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Nodes m -> Map Party (TestHydraClient Tx m)
forall (m :: * -> *). Nodes m -> Map Party (TestHydraClient Tx m)
nodes
  let thisNode :: TestHydraClient Tx m
thisNode = Map Party (TestHydraClient Tx m)
nodes Map Party (TestHydraClient Tx m) -> Party -> TestHydraClient Tx m
forall k a. Ord k => Map k a -> k -> a
! Party
party
  TestHydraClient Tx m -> RunMonad m ()
forall (m :: * -> *) tx.
MonadDelay m =>
TestHydraClient tx m -> RunMonad m ()
waitForOpen TestHydraClient Tx m
thisNode
  case WorldState -> GlobalState
hydraState WorldState
st of
    Open{Uncommitted
$sel:committed:Start :: GlobalState -> Uncommitted
committed :: Uncommitted
committed} -> do
      SimulatedChainNetwork{(Party, UTxOType Tx) -> m ()
closeWithInitialSnapshot :: (Party, UTxOType Tx) -> m ()
$sel:closeWithInitialSnapshot:SimulatedChainNetwork :: forall tx (m :: * -> *).
SimulatedChainNetwork tx m -> (Party, UTxOType tx) -> m ()
closeWithInitialSnapshot} <- (Nodes m -> SimulatedChainNetwork Tx m)
-> RunMonad m (SimulatedChainNetwork Tx m)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Nodes m -> SimulatedChainNetwork Tx m
forall (m :: * -> *). Nodes m -> SimulatedChainNetwork Tx m
chain
      m () -> RunMonad m ()
forall (m :: * -> *) a. Monad m => m a -> RunMonad m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> RunMonad m ()) -> m () -> RunMonad m ()
forall a b. (a -> b) -> a -> b
$ do
        ()
_ <- (Party, UTxOType Tx) -> m ()
closeWithInitialSnapshot (Party
party, UTxOType Payment -> UTxOType Tx
toRealUTxO (UTxOType Payment -> UTxOType Tx)
-> UTxOType Payment -> UTxOType Tx
forall a b. (a -> b) -> a -> b
$ ((Party, [(CardanoSigningKey, Value)]) -> UTxOType Payment)
-> [(Party, [(CardanoSigningKey, Value)])] -> UTxOType Payment
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Party, [(CardanoSigningKey, Value)])
-> [(CardanoSigningKey, Value)]
(Party, [(CardanoSigningKey, Value)]) -> UTxOType Payment
forall a b. (a, b) -> b
snd ([(Party, [(CardanoSigningKey, Value)])] -> UTxOType Payment)
-> [(Party, [(CardanoSigningKey, Value)])] -> UTxOType Payment
forall a b. (a -> b) -> a -> b
$ Map Party [(CardanoSigningKey, Value)]
-> [(Party, [(CardanoSigningKey, Value)])]
forall k a. Map k a -> [(k, a)]
Map.toList Map Party [(CardanoSigningKey, Value)]
Uncommitted
committed)
        [TestHydraClient Tx m] -> (ServerOutput Tx -> Maybe ()) -> m ()
forall tx (m :: * -> *) a.
(Show (ServerOutput tx), HasCallStack, MonadThrow m, MonadAsync m,
 MonadTimer 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 Era]
toTxOuts [(CardanoSigningKey, Value)]
payments =
  (CardanoSigningKey -> Value -> TxOut CtxUTxO Era)
-> (CardanoSigningKey, Value) -> TxOut CtxUTxO Era
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry CardanoSigningKey -> Value -> TxOut CtxUTxO Era
mkTxOut ((CardanoSigningKey, Value) -> TxOut CtxUTxO Era)
-> [(CardanoSigningKey, Value)] -> [TxOut CtxUTxO Era]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(CardanoSigningKey, Value)]
payments

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

mkTxOut :: CardanoSigningKey -> Value -> TxOut CtxUTxO
mkTxOut :: CardanoSigningKey -> Value -> TxOut CtxUTxO Era
mkTxOut (CardanoSigningKey SigningKey PaymentKey
sk) Value
val =
  AddressInEra
-> Value
-> TxOutDatum CtxUTxO
-> ReferenceScript
-> TxOut CtxUTxO Era
forall ctx.
AddressInEra
-> Value -> TxOutDatum ctx -> ReferenceScript -> TxOut ctx
TxOut (NetworkId -> VerificationKey PaymentKey -> AddressInEra
forall era.
IsShelleyBasedEra era =>
NetworkId -> VerificationKey PaymentKey -> AddressInEra era
mkVkAddress NetworkId
testNetworkId (SigningKey PaymentKey -> VerificationKey PaymentKey
forall keyrole.
(Key keyrole, HasTypeProxy keyrole) =>
SigningKey keyrole -> VerificationKey keyrole
getVerificationKey SigningKey PaymentKey
sk)) Value
val TxOutDatum CtxUTxO
forall ctx. TxOutDatum ctx
TxOutDatumNone ReferenceScript
ReferenceScriptNone

mkMockTxIn :: CardanoSigningKey -> Word -> TxIn
mkMockTxIn :: CardanoSigningKey -> Word -> TxIn
mkMockTxIn (CardanoSigningKey SigningKey PaymentKey
sk) Word
ix =
  TxId -> TxIx -> TxIn
TxIn (Hash HASH EraIndependentTxBody -> TxId
TxId Hash HASH EraIndependentTxBody
tid) (Word -> TxIx
TxIx Word
ix)
 where
  vk :: VerificationKey PaymentKey
vk = SigningKey PaymentKey -> VerificationKey PaymentKey
forall keyrole.
(Key keyrole, HasTypeProxy keyrole) =>
SigningKey keyrole -> VerificationKey keyrole
getVerificationKey SigningKey PaymentKey
sk
  -- NOTE: Ugly, works because both binary representations are 32-byte long.
  tid :: Hash 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
forall {a}. IsString a => Bool -> a
interpret Bool
res String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> a -> String
forall b a. (Show a, IsString b) => a -> b
show a
y)
  Bool -> PostconditionM m Bool
forall a. a -> PostconditionM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
res
 where
  res :: Bool
res = a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
y
  interpret :: Bool -> a
interpret Bool
True = a
"=="
  interpret Bool
False = a
"/="

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

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

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)
-> (HeadState tx -> Maybe (UTxOType tx))
-> HeadState tx
-> UTxOType tx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeadState tx -> Maybe (UTxOType tx)
forall tx. IsTx tx => HeadState tx -> Maybe (UTxOType tx)
getHeadUTxO (HeadState tx -> UTxOType tx)
-> m (HeadState tx) -> m (UTxOType tx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TestHydraClient tx m -> m (HeadState tx)
forall tx (m :: * -> *). TestHydraClient tx m -> m (HeadState tx)
queryState TestHydraClient tx m
node

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

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

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