{-# LANGUAGE DuplicateRecordFields #-}

module Hydra.NodeSpec where

import Hydra.Prelude hiding (label)
import Test.Hydra.Prelude

import Control.Concurrent.Class.MonadSTM (MonadLabelledSTM, labelTVarIO, modifyTVar, newTVarIO, readTVarIO)
import Hydra.API.ClientInput (ClientInput (..))
import Hydra.API.Server (Server (..))
import Hydra.API.ServerOutput (ServerOutput (..))
import Hydra.Cardano.Api (SigningKey)
import Hydra.Chain (Chain (..), ChainEvent (..), OnChainTx (..), PostTxError (NoSeedInput))
import Hydra.Chain.ChainState (ChainSlot (ChainSlot), IsChainState)
import Hydra.Events (EventSink (..), EventSource (..), StateEvent (..), genStateEvent, getEventId)
import Hydra.Events.FileBased (eventPairFromPersistenceIncremental)
import Hydra.HeadLogic (Input (..))
import Hydra.HeadLogic.Outcome (StateChanged (HeadInitialized), genStateChanged)
import Hydra.HeadLogicSpec (inInitialState, receiveMessage, receiveMessageFrom, testSnapshot)
import Hydra.Ledger.Simple (SimpleChainState (..), SimpleTx (..), simpleLedger, utxoRef, utxoRefs)
import Hydra.Logging (Tracer, showLogsOnFailure, traceInTVar)
import Hydra.Logging qualified as Logging
import Hydra.Network (Network (..))
import Hydra.Network.Message (Message (..))
import Hydra.Node (
  DraftHydraNode,
  HydraNode (..),
  HydraNodeLog (..),
  checkHeadState,
  connect,
  hydrate,
  stepHydraNode,
 )
import Hydra.Node.InputQueue (InputQueue (..))
import Hydra.Node.ParameterMismatch (ParameterMismatch (..))
import Hydra.Options (defaultContestationPeriod)
import Hydra.Persistence (PersistenceIncremental (..))
import Hydra.Tx.ContestationPeriod (ContestationPeriod (..))
import Hydra.Tx.Crypto (HydraKey, sign)
import Hydra.Tx.Environment (Environment (..))
import Hydra.Tx.Environment qualified as Environment
import Hydra.Tx.HeadParameters (HeadParameters (..), mkHeadParameters)
import Hydra.Tx.Party (Party, deriveParty)
import Test.Hydra.Tx.Fixture (
  alice,
  aliceSk,
  bob,
  bobSk,
  carol,
  carolSk,
  cperiod,
  deriveOnChainId,
  testEnvironment,
  testHeadId,
  testHeadSeed,
 )
import Test.QuickCheck (classify, counterexample, elements, forAllBlind, forAllShrink, forAllShrinkBlind, idempotentIOProperty, listOf, listOf1, resize, (==>))
import Test.Util (isStrictlyMonotonic)

spec :: Spec
spec :: Spec
spec = Spec -> Spec
forall a. SpecWith a -> SpecWith a
parallel (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
  -- Set up a hydrate function with fixtures curried
  let setupHydrate :: ((EventSource (StateEvent SimpleTx) m
  -> [EventSink (StateEvent SimpleTx) m]
  -> m (DraftHydraNode SimpleTx m))
 -> m a)
-> m a
setupHydrate (EventSource (StateEvent SimpleTx) m
 -> [EventSink (StateEvent SimpleTx) m]
 -> m (DraftHydraNode SimpleTx m))
-> m a
action =
        Text -> (Tracer m (HydraNodeLog SimpleTx) -> m a) -> m a
forall (m :: * -> *) msg a.
(MonadSTM m, MonadCatch m, MonadFork m, MonadTime m, MonadSay m,
 ToJSON msg) =>
Text -> (Tracer m msg -> m a) -> m a
showLogsOnFailure Text
"NodeSpec" ((Tracer m (HydraNodeLog SimpleTx) -> m a) -> m a)
-> (Tracer m (HydraNodeLog SimpleTx) -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \Tracer m (HydraNodeLog SimpleTx)
tracer -> do
          let testHydrate :: EventSource (StateEvent SimpleTx) m
-> [EventSink (StateEvent SimpleTx) m]
-> m (DraftHydraNode SimpleTx m)
testHydrate = Tracer m (HydraNodeLog SimpleTx)
-> Environment
-> Ledger SimpleTx
-> ChainStateType SimpleTx
-> EventSource (StateEvent SimpleTx) m
-> [EventSink (StateEvent SimpleTx) m]
-> m (DraftHydraNode SimpleTx m)
forall (m :: * -> *) tx.
(MonadDelay m, MonadLabelledSTM m, MonadAsync m, MonadThrow m,
 IsChainState tx) =>
Tracer m (HydraNodeLog tx)
-> Environment
-> Ledger tx
-> ChainStateType tx
-> EventSource (StateEvent tx) m
-> [EventSink (StateEvent tx) m]
-> m (DraftHydraNode tx m)
hydrate Tracer m (HydraNodeLog SimpleTx)
tracer Environment
testEnvironment Ledger SimpleTx
simpleLedger SimpleChainState{$sel:slot:SimpleChainState :: ChainSlot
slot = Natural -> ChainSlot
ChainSlot Natural
0}
          (EventSource (StateEvent SimpleTx) m
 -> [EventSink (StateEvent SimpleTx) m]
 -> m (DraftHydraNode SimpleTx m))
-> m a
action EventSource (StateEvent SimpleTx) m
-> [EventSink (StateEvent SimpleTx) m]
-> m (DraftHydraNode SimpleTx m)
testHydrate

  String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"hydrate" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
    (((EventSource (StateEvent SimpleTx) IO
   -> [EventSink (StateEvent SimpleTx) IO]
   -> IO (DraftHydraNode SimpleTx IO))
  -> IO ())
 -> IO ())
-> SpecWith
     (EventSource (StateEvent SimpleTx) IO
      -> [EventSink (StateEvent SimpleTx) IO]
      -> IO (DraftHydraNode SimpleTx IO))
-> Spec
forall a. (ActionWith a -> IO ()) -> SpecWith a -> Spec
around ((EventSource (StateEvent SimpleTx) IO
  -> [EventSink (StateEvent SimpleTx) IO]
  -> IO (DraftHydraNode SimpleTx IO))
 -> IO ())
-> IO ()
forall {m :: * -> *} {a}.
(MonadCatch m, MonadFork m, MonadTime m, MonadSay m, MonadDelay m,
 MonadLabelledSTM m, MonadAsync m) =>
((EventSource (StateEvent SimpleTx) m
  -> [EventSink (StateEvent SimpleTx) m]
  -> m (DraftHydraNode SimpleTx m))
 -> m a)
-> m a
setupHydrate (SpecWith
   (EventSource (StateEvent SimpleTx) IO
    -> [EventSink (StateEvent SimpleTx) IO]
    -> IO (DraftHydraNode SimpleTx IO))
 -> Spec)
-> SpecWith
     (EventSource (StateEvent SimpleTx) IO
      -> [EventSink (StateEvent SimpleTx) IO]
      -> IO (DraftHydraNode SimpleTx IO))
-> Spec
forall a b. (a -> b) -> a -> b
$ do
      String
-> ((EventSource (StateEvent SimpleTx) IO
     -> [EventSink (StateEvent SimpleTx) IO]
     -> IO (DraftHydraNode SimpleTx IO))
    -> Property)
-> SpecWith
     (Arg
        ((EventSource (StateEvent SimpleTx) IO
          -> [EventSink (StateEvent SimpleTx) IO]
          -> IO (DraftHydraNode SimpleTx IO))
         -> Property))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"loads events from source into all sinks" (((EventSource (StateEvent SimpleTx) IO
   -> [EventSink (StateEvent SimpleTx) IO]
   -> IO (DraftHydraNode SimpleTx IO))
  -> Property)
 -> SpecWith
      (Arg
         ((EventSource (StateEvent SimpleTx) IO
           -> [EventSink (StateEvent SimpleTx) IO]
           -> IO (DraftHydraNode SimpleTx IO))
          -> Property)))
-> ((EventSource (StateEvent SimpleTx) IO
     -> [EventSink (StateEvent SimpleTx) IO]
     -> IO (DraftHydraNode SimpleTx IO))
    -> Property)
-> SpecWith
     (Arg
        ((EventSource (StateEvent SimpleTx) IO
          -> [EventSink (StateEvent SimpleTx) IO]
          -> IO (DraftHydraNode SimpleTx IO))
         -> Property))
forall a b. (a -> b) -> a -> b
$ \EventSource (StateEvent SimpleTx) IO
-> [EventSink (StateEvent SimpleTx) IO]
-> IO (DraftHydraNode SimpleTx IO)
testHydrate ->
        Gen [StateEvent SimpleTx]
-> ([StateEvent SimpleTx] -> [[StateEvent SimpleTx]])
-> ([StateEvent SimpleTx] -> IO ())
-> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> [a]) -> (a -> prop) -> Property
forAllShrink (Gen (StateEvent SimpleTx) -> Gen [StateEvent SimpleTx]
forall a. Gen a -> Gen [a]
listOf (Gen (StateEvent SimpleTx) -> Gen [StateEvent SimpleTx])
-> Gen (StateEvent SimpleTx) -> Gen [StateEvent SimpleTx]
forall a b. (a -> b) -> a -> b
$ Environment -> Gen (StateChanged SimpleTx)
forall tx.
(ArbitraryIsTx tx, IsChainState tx) =>
Environment -> Gen (StateChanged tx)
genStateChanged Environment
testEnvironment Gen (StateChanged SimpleTx)
-> (StateChanged SimpleTx -> Gen (StateEvent SimpleTx))
-> Gen (StateEvent SimpleTx)
forall a b. Gen a -> (a -> Gen b) -> Gen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= StateChanged SimpleTx -> Gen (StateEvent SimpleTx)
forall tx. StateChanged tx -> Gen (StateEvent tx)
genStateEvent) [StateEvent SimpleTx] -> [[StateEvent SimpleTx]]
forall a. Arbitrary a => a -> [a]
shrink (([StateEvent SimpleTx] -> IO ()) -> Property)
-> ([StateEvent SimpleTx] -> IO ()) -> Property
forall a b. (a -> b) -> a -> b
$
          \[StateEvent SimpleTx]
someEvents -> do
            (EventSink (StateEvent SimpleTx) IO
mockSink1, IO [StateEvent SimpleTx]
getMockSinkEvents1) <- IO (EventSink (StateEvent SimpleTx) IO, IO [StateEvent SimpleTx])
forall a. IO (EventSink a IO, IO [a])
createRecordingSink
            (EventSink (StateEvent SimpleTx) IO
mockSink2, IO [StateEvent SimpleTx]
getMockSinkEvents2) <- IO (EventSink (StateEvent SimpleTx) IO, IO [StateEvent SimpleTx])
forall a. IO (EventSink a IO, IO [a])
createRecordingSink

            IO (DraftHydraNode SimpleTx IO) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (DraftHydraNode SimpleTx IO) -> IO ())
-> IO (DraftHydraNode SimpleTx IO) -> IO ()
forall a b. (a -> b) -> a -> b
$ EventSource (StateEvent SimpleTx) IO
-> [EventSink (StateEvent SimpleTx) IO]
-> IO (DraftHydraNode SimpleTx IO)
testHydrate ([StateEvent SimpleTx] -> EventSource (StateEvent SimpleTx) IO
forall (m :: * -> *) a. Monad m => [a] -> EventSource a m
mockSource [StateEvent SimpleTx]
someEvents) [EventSink (StateEvent SimpleTx) IO
mockSink1, EventSink (StateEvent SimpleTx) IO
mockSink2]

            IO [StateEvent SimpleTx]
getMockSinkEvents1 IO [StateEvent SimpleTx] -> [StateEvent SimpleTx] -> IO ()
forall a. (HasCallStack, Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` [StateEvent SimpleTx]
someEvents
            IO [StateEvent SimpleTx]
getMockSinkEvents2 IO [StateEvent SimpleTx] -> [StateEvent SimpleTx] -> IO ()
forall a. (HasCallStack, Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` [StateEvent SimpleTx]
someEvents

      String
-> ((EventSource (StateEvent SimpleTx) IO
     -> [EventSink (StateEvent SimpleTx) IO]
     -> IO (DraftHydraNode SimpleTx IO))
    -> Property)
-> SpecWith
     (Arg
        ((EventSource (StateEvent SimpleTx) IO
          -> [EventSink (StateEvent SimpleTx) IO]
          -> IO (DraftHydraNode SimpleTx IO))
         -> Property))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"event ids are consistent" (((EventSource (StateEvent SimpleTx) IO
   -> [EventSink (StateEvent SimpleTx) IO]
   -> IO (DraftHydraNode SimpleTx IO))
  -> Property)
 -> SpecWith
      (Arg
         ((EventSource (StateEvent SimpleTx) IO
           -> [EventSink (StateEvent SimpleTx) IO]
           -> IO (DraftHydraNode SimpleTx IO))
          -> Property)))
-> ((EventSource (StateEvent SimpleTx) IO
     -> [EventSink (StateEvent SimpleTx) IO]
     -> IO (DraftHydraNode SimpleTx IO))
    -> Property)
-> SpecWith
     (Arg
        ((EventSource (StateEvent SimpleTx) IO
          -> [EventSink (StateEvent SimpleTx) IO]
          -> IO (DraftHydraNode SimpleTx IO))
         -> Property))
forall a b. (a -> b) -> a -> b
$ \EventSource (StateEvent SimpleTx) IO
-> [EventSink (StateEvent SimpleTx) IO]
-> IO (DraftHydraNode SimpleTx IO)
testHydrate ->
        Gen [StateEvent SimpleTx]
-> ([StateEvent SimpleTx] -> [[StateEvent SimpleTx]])
-> ([StateEvent SimpleTx] -> IO ())
-> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> [a]) -> (a -> prop) -> Property
forAllShrink (Gen (StateEvent SimpleTx) -> Gen [StateEvent SimpleTx]
forall a. Gen a -> Gen [a]
listOf (Gen (StateEvent SimpleTx) -> Gen [StateEvent SimpleTx])
-> Gen (StateEvent SimpleTx) -> Gen [StateEvent SimpleTx]
forall a b. (a -> b) -> a -> b
$ Environment -> Gen (StateChanged SimpleTx)
forall tx.
(ArbitraryIsTx tx, IsChainState tx) =>
Environment -> Gen (StateChanged tx)
genStateChanged Environment
testEnvironment Gen (StateChanged SimpleTx)
-> (StateChanged SimpleTx -> Gen (StateEvent SimpleTx))
-> Gen (StateEvent SimpleTx)
forall a b. Gen a -> (a -> Gen b) -> Gen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= StateChanged SimpleTx -> Gen (StateEvent SimpleTx)
forall tx. StateChanged tx -> Gen (StateEvent tx)
genStateEvent) [StateEvent SimpleTx] -> [[StateEvent SimpleTx]]
forall a. Arbitrary a => a -> [a]
shrink (([StateEvent SimpleTx] -> IO ()) -> Property)
-> ([StateEvent SimpleTx] -> IO ()) -> Property
forall a b. (a -> b) -> a -> b
$
          \[StateEvent SimpleTx]
someEvents -> do
            (EventSink (StateEvent SimpleTx) IO
sink, IO [StateEvent SimpleTx]
getSinkEvents) <- IO (EventSink (StateEvent SimpleTx) IO, IO [StateEvent SimpleTx])
forall a. IO (EventSink a IO, IO [a])
createRecordingSink

            IO (DraftHydraNode SimpleTx IO) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (DraftHydraNode SimpleTx IO) -> IO ())
-> IO (DraftHydraNode SimpleTx IO) -> IO ()
forall a b. (a -> b) -> a -> b
$ EventSource (StateEvent SimpleTx) IO
-> [EventSink (StateEvent SimpleTx) IO]
-> IO (DraftHydraNode SimpleTx IO)
testHydrate ([StateEvent SimpleTx] -> EventSource (StateEvent SimpleTx) IO
forall (m :: * -> *) a. Monad m => [a] -> EventSource a m
mockSource [StateEvent SimpleTx]
someEvents) [EventSink (StateEvent SimpleTx) IO
sink]

            [StateEvent SimpleTx]
seenEvents <- IO [StateEvent SimpleTx]
getSinkEvents
            StateEvent SimpleTx -> EventId
forall a. HasEventId a => a -> EventId
getEventId (StateEvent SimpleTx -> EventId)
-> [StateEvent SimpleTx] -> [EventId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [StateEvent SimpleTx]
seenEvents [EventId] -> [EventId] -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` StateEvent SimpleTx -> EventId
forall a. HasEventId a => a -> EventId
getEventId (StateEvent SimpleTx -> EventId)
-> [StateEvent SimpleTx] -> [EventId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [StateEvent SimpleTx]
someEvents

      String
-> ((EventSource (StateEvent SimpleTx) IO
     -> [EventSink (StateEvent SimpleTx) IO]
     -> IO (DraftHydraNode SimpleTx IO))
    -> Property)
-> SpecWith
     (Arg
        ((EventSource (StateEvent SimpleTx) IO
          -> [EventSink (StateEvent SimpleTx) IO]
          -> IO (DraftHydraNode SimpleTx IO))
         -> Property))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"fails if one sink fails" (((EventSource (StateEvent SimpleTx) IO
   -> [EventSink (StateEvent SimpleTx) IO]
   -> IO (DraftHydraNode SimpleTx IO))
  -> Property)
 -> SpecWith
      (Arg
         ((EventSource (StateEvent SimpleTx) IO
           -> [EventSink (StateEvent SimpleTx) IO]
           -> IO (DraftHydraNode SimpleTx IO))
          -> Property)))
-> ((EventSource (StateEvent SimpleTx) IO
     -> [EventSink (StateEvent SimpleTx) IO]
     -> IO (DraftHydraNode SimpleTx IO))
    -> Property)
-> SpecWith
     (Arg
        ((EventSource (StateEvent SimpleTx) IO
          -> [EventSink (StateEvent SimpleTx) IO]
          -> IO (DraftHydraNode SimpleTx IO))
         -> Property))
forall a b. (a -> b) -> a -> b
$ \EventSource (StateEvent SimpleTx) IO
-> [EventSink (StateEvent SimpleTx) IO]
-> IO (DraftHydraNode SimpleTx IO)
testHydrate ->
        Gen [StateEvent SimpleTx]
-> ([StateEvent SimpleTx] -> [[StateEvent SimpleTx]])
-> ([StateEvent SimpleTx] -> Property)
-> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> [a]) -> (a -> prop) -> Property
forAllShrink (Gen (StateEvent SimpleTx) -> Gen [StateEvent SimpleTx]
forall a. Gen a -> Gen [a]
listOf1 (Gen (StateEvent SimpleTx) -> Gen [StateEvent SimpleTx])
-> Gen (StateEvent SimpleTx) -> Gen [StateEvent SimpleTx]
forall a b. (a -> b) -> a -> b
$ Environment -> Gen (StateChanged SimpleTx)
forall tx.
(ArbitraryIsTx tx, IsChainState tx) =>
Environment -> Gen (StateChanged tx)
genStateChanged Environment
testEnvironment Gen (StateChanged SimpleTx)
-> (StateChanged SimpleTx -> Gen (StateEvent SimpleTx))
-> Gen (StateEvent SimpleTx)
forall a b. Gen a -> (a -> Gen b) -> Gen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= StateChanged SimpleTx -> Gen (StateEvent SimpleTx)
forall tx. StateChanged tx -> Gen (StateEvent tx)
genStateEvent) [StateEvent SimpleTx] -> [[StateEvent SimpleTx]]
forall a. Arbitrary a => a -> [a]
shrink (([StateEvent SimpleTx] -> Property) -> Property)
-> ([StateEvent SimpleTx] -> Property) -> Property
forall a b. (a -> b) -> a -> b
$
          \[StateEvent SimpleTx]
someEvents -> do
            let genSinks :: Gen (EventSink (StateEvent SimpleTx) IO)
genSinks = [EventSink (StateEvent SimpleTx) IO]
-> Gen (EventSink (StateEvent SimpleTx) IO)
forall a. HasCallStack => [a] -> Gen a
elements [EventSink (StateEvent SimpleTx) IO
forall (m :: * -> *) a. Monad m => EventSink a m
mockSink, EventSink (StateEvent SimpleTx) IO
forall {e}. EventSink e IO
failingSink]
                failingSink :: EventSink e IO
failingSink = EventSink{$sel:putEvent:EventSink :: HasEventId e => e -> IO ()
putEvent = \e
_ -> String -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure String
"failing sink called"}
            Gen [EventSink (StateEvent SimpleTx) IO]
-> ([EventSink (StateEvent SimpleTx) IO] -> IO ()) -> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind (Gen (EventSink (StateEvent SimpleTx) IO)
-> Gen [EventSink (StateEvent SimpleTx) IO]
forall a. Gen a -> Gen [a]
listOf Gen (EventSink (StateEvent SimpleTx) IO)
genSinks) (([EventSink (StateEvent SimpleTx) IO] -> IO ()) -> Property)
-> ([EventSink (StateEvent SimpleTx) IO] -> IO ()) -> Property
forall a b. (a -> b) -> a -> b
$ \[EventSink (StateEvent SimpleTx) IO]
sinks ->
              EventSource (StateEvent SimpleTx) IO
-> [EventSink (StateEvent SimpleTx) IO]
-> IO (DraftHydraNode SimpleTx IO)
testHydrate ([StateEvent SimpleTx] -> EventSource (StateEvent SimpleTx) IO
forall (m :: * -> *) a. Monad m => [a] -> EventSource a m
mockSource [StateEvent SimpleTx]
someEvents) ([EventSink (StateEvent SimpleTx) IO]
sinks [EventSink (StateEvent SimpleTx) IO]
-> [EventSink (StateEvent SimpleTx) IO]
-> [EventSink (StateEvent SimpleTx) IO]
forall a. Semigroup a => a -> a -> a
<> [EventSink (StateEvent SimpleTx) IO
forall {e}. EventSink e IO
failingSink])
                IO (DraftHydraNode SimpleTx IO) -> Selector HUnitFailure -> IO ()
forall e a.
(HasCallStack, Exception e) =>
IO a -> Selector e -> IO ()
`shouldThrow` \(HUnitFailure
_ :: HUnitFailure) -> Bool
True

      String
-> ((EventSource (StateEvent SimpleTx) IO
     -> [EventSink (StateEvent SimpleTx) IO]
     -> IO (DraftHydraNode SimpleTx IO))
    -> Property)
-> SpecWith
     (Arg
        ((EventSource (StateEvent SimpleTx) IO
          -> [EventSink (StateEvent SimpleTx) IO]
          -> IO (DraftHydraNode SimpleTx IO))
         -> Property))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"checks head state" (((EventSource (StateEvent SimpleTx) IO
   -> [EventSink (StateEvent SimpleTx) IO]
   -> IO (DraftHydraNode SimpleTx IO))
  -> Property)
 -> SpecWith
      (Arg
         ((EventSource (StateEvent SimpleTx) IO
           -> [EventSink (StateEvent SimpleTx) IO]
           -> IO (DraftHydraNode SimpleTx IO))
          -> Property)))
-> ((EventSource (StateEvent SimpleTx) IO
     -> [EventSink (StateEvent SimpleTx) IO]
     -> IO (DraftHydraNode SimpleTx IO))
    -> Property)
-> SpecWith
     (Arg
        ((EventSource (StateEvent SimpleTx) IO
          -> [EventSink (StateEvent SimpleTx) IO]
          -> IO (DraftHydraNode SimpleTx IO))
         -> Property))
forall a b. (a -> b) -> a -> b
$ \EventSource (StateEvent SimpleTx) IO
-> [EventSink (StateEvent SimpleTx) IO]
-> IO (DraftHydraNode SimpleTx IO)
testHydrate ->
        Gen Environment
-> (Environment -> [Environment])
-> (Environment -> Property)
-> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> [a]) -> (a -> prop) -> Property
forAllShrink Gen Environment
forall a. Arbitrary a => Gen a
arbitrary Environment -> [Environment]
forall a. Arbitrary a => a -> [a]
shrink ((Environment -> Property) -> Property)
-> (Environment -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \Environment
env ->
          Environment
env Environment -> Environment -> Bool
forall a. Eq a => a -> a -> Bool
/= Environment
testEnvironment Bool -> Property -> Property
forall prop. Testable prop => Bool -> prop -> Property
==> do
            -- XXX: This is very tied to the fact that 'HeadInitialized' results in
            -- a head state that gets checked by 'checkHeadState'
            let genEvent :: Gen (StateEvent SimpleTx)
genEvent = do
                  EventId -> StateChanged SimpleTx -> StateEvent SimpleTx
forall tx. EventId -> StateChanged tx -> StateEvent tx
StateEvent
                    (EventId -> StateChanged SimpleTx -> StateEvent SimpleTx)
-> Gen EventId
-> Gen (StateChanged SimpleTx -> StateEvent SimpleTx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen EventId
forall a. Arbitrary a => Gen a
arbitrary
                    Gen (StateChanged SimpleTx -> StateEvent SimpleTx)
-> Gen (StateChanged SimpleTx) -> Gen (StateEvent SimpleTx)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (HeadParameters
-> ChainStateType SimpleTx
-> HeadId
-> HeadSeed
-> StateChanged SimpleTx
forall tx.
HeadParameters
-> ChainStateType tx -> HeadId -> HeadSeed -> StateChanged tx
HeadInitialized (Environment -> HeadParameters
mkHeadParameters Environment
env) (SimpleChainState -> HeadId -> HeadSeed -> StateChanged SimpleTx)
-> Gen SimpleChainState
-> Gen (HeadId -> HeadSeed -> StateChanged SimpleTx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen SimpleChainState
forall a. Arbitrary a => Gen a
arbitrary Gen (HeadId -> HeadSeed -> StateChanged SimpleTx)
-> Gen HeadId -> Gen (HeadSeed -> StateChanged SimpleTx)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen HeadId
forall a. Arbitrary a => Gen a
arbitrary Gen (HeadSeed -> StateChanged SimpleTx)
-> Gen HeadSeed -> Gen (StateChanged SimpleTx)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen HeadSeed
forall a. Arbitrary a => Gen a
arbitrary)
            Gen (StateEvent SimpleTx)
-> (StateEvent SimpleTx -> [StateEvent SimpleTx])
-> (StateEvent SimpleTx -> IO ())
-> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> [a]) -> (a -> prop) -> Property
forAllShrink Gen (StateEvent SimpleTx)
genEvent StateEvent SimpleTx -> [StateEvent SimpleTx]
forall a. Arbitrary a => a -> [a]
shrink ((StateEvent SimpleTx -> IO ()) -> Property)
-> (StateEvent SimpleTx -> IO ()) -> Property
forall a b. (a -> b) -> a -> b
$ \StateEvent SimpleTx
incompatibleEvent ->
              EventSource (StateEvent SimpleTx) IO
-> [EventSink (StateEvent SimpleTx) IO]
-> IO (DraftHydraNode SimpleTx IO)
testHydrate ([StateEvent SimpleTx] -> EventSource (StateEvent SimpleTx) IO
forall (m :: * -> *) a. Monad m => [a] -> EventSource a m
mockSource [StateEvent SimpleTx
incompatibleEvent]) []
                IO (DraftHydraNode SimpleTx IO)
-> Selector ParameterMismatch -> IO ()
forall e a.
(HasCallStack, Exception e) =>
IO a -> Selector e -> IO ()
`shouldThrow` \(ParameterMismatch
_ :: ParameterMismatch) -> Bool
True

  String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"stepHydraNode" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
    (((EventSource (StateEvent SimpleTx) IO
   -> [EventSink (StateEvent SimpleTx) IO]
   -> IO (DraftHydraNode SimpleTx IO))
  -> IO ())
 -> IO ())
-> SpecWith
     (EventSource (StateEvent SimpleTx) IO
      -> [EventSink (StateEvent SimpleTx) IO]
      -> IO (DraftHydraNode SimpleTx IO))
-> Spec
forall a. (ActionWith a -> IO ()) -> SpecWith a -> Spec
around ((EventSource (StateEvent SimpleTx) IO
  -> [EventSink (StateEvent SimpleTx) IO]
  -> IO (DraftHydraNode SimpleTx IO))
 -> IO ())
-> IO ()
forall {m :: * -> *} {a}.
(MonadCatch m, MonadFork m, MonadTime m, MonadSay m, MonadDelay m,
 MonadLabelledSTM m, MonadAsync m) =>
((EventSource (StateEvent SimpleTx) m
  -> [EventSink (StateEvent SimpleTx) m]
  -> m (DraftHydraNode SimpleTx m))
 -> m a)
-> m a
setupHydrate (SpecWith
   (EventSource (StateEvent SimpleTx) IO
    -> [EventSink (StateEvent SimpleTx) IO]
    -> IO (DraftHydraNode SimpleTx IO))
 -> Spec)
-> SpecWith
     (EventSource (StateEvent SimpleTx) IO
      -> [EventSink (StateEvent SimpleTx) IO]
      -> IO (DraftHydraNode SimpleTx IO))
-> Spec
forall a b. (a -> b) -> a -> b
$ do
      String
-> ((EventSource (StateEvent SimpleTx) IO
     -> [EventSink (StateEvent SimpleTx) IO]
     -> IO (DraftHydraNode SimpleTx IO))
    -> IO ())
-> SpecWith
     (Arg
        ((EventSource (StateEvent SimpleTx) IO
          -> [EventSink (StateEvent SimpleTx) IO]
          -> IO (DraftHydraNode SimpleTx IO))
         -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"events are sent to all sinks" (((EventSource (StateEvent SimpleTx) IO
   -> [EventSink (StateEvent SimpleTx) IO]
   -> IO (DraftHydraNode SimpleTx IO))
  -> IO ())
 -> SpecWith
      (Arg
         ((EventSource (StateEvent SimpleTx) IO
           -> [EventSink (StateEvent SimpleTx) IO]
           -> IO (DraftHydraNode SimpleTx IO))
          -> IO ())))
-> ((EventSource (StateEvent SimpleTx) IO
     -> [EventSink (StateEvent SimpleTx) IO]
     -> IO (DraftHydraNode SimpleTx IO))
    -> IO ())
-> SpecWith
     (Arg
        ((EventSource (StateEvent SimpleTx) IO
          -> [EventSink (StateEvent SimpleTx) IO]
          -> IO (DraftHydraNode SimpleTx IO))
         -> IO ()))
forall a b. (a -> b) -> a -> b
$ \EventSource (StateEvent SimpleTx) IO
-> [EventSink (StateEvent SimpleTx) IO]
-> IO (DraftHydraNode SimpleTx IO)
testHydrate -> do
        (EventSink (StateEvent SimpleTx) IO
mockSink1, IO [StateEvent SimpleTx]
getMockSinkEvents1) <- IO (EventSink (StateEvent SimpleTx) IO, IO [StateEvent SimpleTx])
forall a. IO (EventSink a IO, IO [a])
createRecordingSink
        (EventSink (StateEvent SimpleTx) IO
mockSink2, IO [StateEvent SimpleTx]
getMockSinkEvents2) <- IO (EventSink (StateEvent SimpleTx) IO, IO [StateEvent SimpleTx])
forall a. IO (EventSink a IO, IO [a])
createRecordingSink

        EventSource (StateEvent SimpleTx) IO
-> [EventSink (StateEvent SimpleTx) IO]
-> IO (DraftHydraNode SimpleTx IO)
testHydrate ([StateEvent SimpleTx] -> EventSource (StateEvent SimpleTx) IO
forall (m :: * -> *) a. Monad m => [a] -> EventSource a m
mockSource []) [EventSink (StateEvent SimpleTx) IO
mockSink1, EventSink (StateEvent SimpleTx) IO
mockSink2]
          IO (DraftHydraNode SimpleTx IO)
-> (DraftHydraNode SimpleTx IO -> IO (HydraNode SimpleTx IO))
-> IO (HydraNode SimpleTx IO)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= DraftHydraNode SimpleTx IO -> IO (HydraNode SimpleTx IO)
forall (m :: * -> *).
MonadThrow m =>
DraftHydraNode SimpleTx m -> m (HydraNode SimpleTx m)
notConnect
          IO (HydraNode SimpleTx IO)
-> (HydraNode SimpleTx IO -> IO (HydraNode SimpleTx IO))
-> IO (HydraNode SimpleTx IO)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Input SimpleTx]
-> HydraNode SimpleTx IO -> IO (HydraNode SimpleTx IO)
forall (m :: * -> *).
Monad m =>
[Input SimpleTx]
-> HydraNode SimpleTx m -> m (HydraNode SimpleTx m)
primeWith [Input SimpleTx]
inputsToOpenHead
          IO (HydraNode SimpleTx IO)
-> (HydraNode SimpleTx IO -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HydraNode SimpleTx IO -> IO ()
forall tx. IsChainState tx => HydraNode tx IO -> IO ()
runToCompletion

        [StateEvent SimpleTx]
events <- IO [StateEvent SimpleTx]
getMockSinkEvents1
        [StateEvent SimpleTx]
events [StateEvent SimpleTx] -> [StateEvent SimpleTx] -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldNotBe` []
        IO [StateEvent SimpleTx]
getMockSinkEvents2 IO [StateEvent SimpleTx] -> [StateEvent SimpleTx] -> IO ()
forall a. (HasCallStack, Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` [StateEvent SimpleTx]
events

      String
-> ((EventSource (StateEvent SimpleTx) IO
     -> [EventSink (StateEvent SimpleTx) IO]
     -> IO (DraftHydraNode SimpleTx IO))
    -> Property)
-> SpecWith
     (Arg
        ((EventSource (StateEvent SimpleTx) IO
          -> [EventSink (StateEvent SimpleTx) IO]
          -> IO (DraftHydraNode SimpleTx IO))
         -> Property))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"event ids are strictly monotonic" (((EventSource (StateEvent SimpleTx) IO
   -> [EventSink (StateEvent SimpleTx) IO]
   -> IO (DraftHydraNode SimpleTx IO))
  -> Property)
 -> SpecWith
      (Arg
         ((EventSource (StateEvent SimpleTx) IO
           -> [EventSink (StateEvent SimpleTx) IO]
           -> IO (DraftHydraNode SimpleTx IO))
          -> Property)))
-> ((EventSource (StateEvent SimpleTx) IO
     -> [EventSink (StateEvent SimpleTx) IO]
     -> IO (DraftHydraNode SimpleTx IO))
    -> Property)
-> SpecWith
     (Arg
        ((EventSource (StateEvent SimpleTx) IO
          -> [EventSink (StateEvent SimpleTx) IO]
          -> IO (DraftHydraNode SimpleTx IO))
         -> Property))
forall a b. (a -> b) -> a -> b
$ \EventSource (StateEvent SimpleTx) IO
-> [EventSink (StateEvent SimpleTx) IO]
-> IO (DraftHydraNode SimpleTx IO)
testHydrate -> do
        -- NOTE: Arbitrary inputs in open head state results more likely in
        -- multiple state change events per input (during tx processing).
        let genInputs :: Gen [Input SimpleTx]
genInputs = do
              -- Resize to reducing complexity of additional input contents
              Input SimpleTx
someInput <- Int -> Gen (Input SimpleTx) -> Gen (Input SimpleTx)
forall a. HasCallStack => Int -> Gen a -> Gen a
resize Int
1 Gen (Input SimpleTx)
forall a. Arbitrary a => Gen a
arbitrary
              [Input SimpleTx] -> Gen [Input SimpleTx]
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Input SimpleTx] -> Gen [Input SimpleTx])
-> [Input SimpleTx] -> Gen [Input SimpleTx]
forall a b. (a -> b) -> a -> b
$ [Input SimpleTx]
inputsToOpenHead [Input SimpleTx] -> [Input SimpleTx] -> [Input SimpleTx]
forall a. Semigroup a => a -> a -> a
<> [Input SimpleTx
someInput]

        Gen [Input SimpleTx]
-> ([Input SimpleTx] -> [[Input SimpleTx]])
-> ([Input SimpleTx] -> Property)
-> Property
forall prop a.
Testable prop =>
Gen a -> (a -> [a]) -> (a -> prop) -> Property
forAllShrinkBlind Gen [Input SimpleTx]
genInputs [Input SimpleTx] -> [[Input SimpleTx]]
forall a. Arbitrary a => a -> [a]
shrink (([Input SimpleTx] -> Property) -> Property)
-> ([Input SimpleTx] -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \[Input SimpleTx]
someInputs ->
          IO Property -> Property
forall prop. Testable prop => IO prop -> Property
idempotentIOProperty (IO Property -> Property) -> IO Property -> Property
forall a b. (a -> b) -> a -> b
$ do
            (EventSink (StateEvent SimpleTx) IO
sink, IO [StateEvent SimpleTx]
getSinkEvents) <- IO (EventSink (StateEvent SimpleTx) IO, IO [StateEvent SimpleTx])
forall a. IO (EventSink a IO, IO [a])
createRecordingSink
            EventSource (StateEvent SimpleTx) IO
-> [EventSink (StateEvent SimpleTx) IO]
-> IO (DraftHydraNode SimpleTx IO)
testHydrate ([StateEvent SimpleTx] -> EventSource (StateEvent SimpleTx) IO
forall (m :: * -> *) a. Monad m => [a] -> EventSource a m
mockSource []) [EventSink (StateEvent SimpleTx) IO
sink]
              IO (DraftHydraNode SimpleTx IO)
-> (DraftHydraNode SimpleTx IO -> IO (HydraNode SimpleTx IO))
-> IO (HydraNode SimpleTx IO)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= DraftHydraNode SimpleTx IO -> IO (HydraNode SimpleTx IO)
forall (m :: * -> *).
MonadThrow m =>
DraftHydraNode SimpleTx m -> m (HydraNode SimpleTx m)
notConnect
              IO (HydraNode SimpleTx IO)
-> (HydraNode SimpleTx IO -> IO (HydraNode SimpleTx IO))
-> IO (HydraNode SimpleTx IO)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Input SimpleTx]
-> HydraNode SimpleTx IO -> IO (HydraNode SimpleTx IO)
forall (m :: * -> *).
Monad m =>
[Input SimpleTx]
-> HydraNode SimpleTx m -> m (HydraNode SimpleTx m)
primeWith [Input SimpleTx]
someInputs
              IO (HydraNode SimpleTx IO)
-> (HydraNode SimpleTx IO -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HydraNode SimpleTx IO -> IO ()
forall tx. IsChainState tx => HydraNode tx IO -> IO ()
runToCompletion

            [StateEvent SimpleTx]
events <- IO [StateEvent SimpleTx]
getSinkEvents
            let eventIds :: [EventId]
eventIds = StateEvent SimpleTx -> EventId
forall a. HasEventId a => a -> EventId
getEventId (StateEvent SimpleTx -> EventId)
-> [StateEvent SimpleTx] -> [EventId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [StateEvent SimpleTx]
events
            Property -> IO Property
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Property -> IO Property) -> Property -> IO Property
forall a b. (a -> b) -> a -> b
$
              [EventId] -> Bool
forall a. Ord a => [a] -> Bool
isStrictlyMonotonic [EventId]
eventIds
                Bool -> (Bool -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample String
"Not strictly monotonic"
                Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Event ids: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [EventId] -> String
forall b a. (Show a, IsString b) => a -> b
show [EventId]
eventIds)
                Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Events: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [StateEvent SimpleTx] -> String
forall b a. (Show a, IsString b) => a -> b
show [StateEvent SimpleTx]
events)
                Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Inputs: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [Input SimpleTx] -> String
forall b a. (Show a, IsString b) => a -> b
show [Input SimpleTx]
someInputs)
                Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& Bool -> String -> Property -> Property
forall prop. Testable prop => Bool -> String -> prop -> Property
classify ([EventId] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [EventId]
eventIds) String
"empty list of events"

      String
-> ((EventSource (StateEvent SimpleTx) IO
     -> [EventSink (StateEvent SimpleTx) IO]
     -> IO (DraftHydraNode SimpleTx IO))
    -> IO ())
-> SpecWith
     (Arg
        ((EventSource (StateEvent SimpleTx) IO
          -> [EventSink (StateEvent SimpleTx) IO]
          -> IO (DraftHydraNode SimpleTx IO))
         -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"can continue after re-hydration" (((EventSource (StateEvent SimpleTx) IO
   -> [EventSink (StateEvent SimpleTx) IO]
   -> IO (DraftHydraNode SimpleTx IO))
  -> IO ())
 -> SpecWith
      (Arg
         ((EventSource (StateEvent SimpleTx) IO
           -> [EventSink (StateEvent SimpleTx) IO]
           -> IO (DraftHydraNode SimpleTx IO))
          -> IO ())))
-> ((EventSource (StateEvent SimpleTx) IO
     -> [EventSink (StateEvent SimpleTx) IO]
     -> IO (DraftHydraNode SimpleTx IO))
    -> IO ())
-> SpecWith
     (Arg
        ((EventSource (StateEvent SimpleTx) IO
          -> [EventSink (StateEvent SimpleTx) IO]
          -> IO (DraftHydraNode SimpleTx IO))
         -> IO ()))
forall a b. (a -> b) -> a -> b
$ \EventSource (StateEvent SimpleTx) IO
-> [EventSink (StateEvent SimpleTx) IO]
-> IO (DraftHydraNode SimpleTx IO)
testHydrate ->
        NominalDiffTime -> IO () -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTimer m, MonadThrow m) =>
NominalDiffTime -> m a -> m a
failAfter NominalDiffTime
1 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          PersistenceIncremental (PersistedStateChange SimpleTx) IO
persistence <- IO (PersistenceIncremental (PersistedStateChange SimpleTx) IO)
forall (m :: * -> *) a.
MonadLabelledSTM m =>
m (PersistenceIncremental a m)
createPersistenceInMemory
          (EventSource (StateEvent SimpleTx) IO
eventSource, EventSink (StateEvent SimpleTx) IO
eventSink) <- PersistenceIncremental (PersistedStateChange SimpleTx) IO
-> IO
     (EventSource (StateEvent SimpleTx) IO,
      EventSink (StateEvent SimpleTx) IO)
forall tx (m :: * -> *).
(IsChainState tx, MonadSTM m) =>
PersistenceIncremental (PersistedStateChange tx) m
-> m (EventSource (StateEvent tx) m, EventSink (StateEvent tx) m)
eventPairFromPersistenceIncremental PersistenceIncremental (PersistedStateChange SimpleTx) IO
persistence

          EventSource (StateEvent SimpleTx) IO
-> [EventSink (StateEvent SimpleTx) IO]
-> IO (DraftHydraNode SimpleTx IO)
testHydrate EventSource (StateEvent SimpleTx) IO
eventSource [EventSink (StateEvent SimpleTx) IO
eventSink]
            IO (DraftHydraNode SimpleTx IO)
-> (DraftHydraNode SimpleTx IO -> IO (HydraNode SimpleTx IO))
-> IO (HydraNode SimpleTx IO)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= DraftHydraNode SimpleTx IO -> IO (HydraNode SimpleTx IO)
forall (m :: * -> *).
MonadThrow m =>
DraftHydraNode SimpleTx m -> m (HydraNode SimpleTx m)
notConnect
            IO (HydraNode SimpleTx IO)
-> (HydraNode SimpleTx IO -> IO (HydraNode SimpleTx IO))
-> IO (HydraNode SimpleTx IO)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Input SimpleTx]
-> HydraNode SimpleTx IO -> IO (HydraNode SimpleTx IO)
forall (m :: * -> *).
Monad m =>
[Input SimpleTx]
-> HydraNode SimpleTx m -> m (HydraNode SimpleTx m)
primeWith [Input SimpleTx]
inputsToOpenHead
            IO (HydraNode SimpleTx IO)
-> (HydraNode SimpleTx IO -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HydraNode SimpleTx IO -> IO ()
forall tx. IsChainState tx => HydraNode tx IO -> IO ()
runToCompletion

          let reqTx :: Input SimpleTx
reqTx = Message SimpleTx -> Input SimpleTx
forall tx. Message tx -> Input tx
receiveMessage ReqTx{$sel:transaction:ReqTx :: SimpleTx
transaction = SimpleTx
tx1}
              tx1 :: SimpleTx
tx1 = SimpleTx{$sel:txSimpleId:SimpleTx :: SimpleId
txSimpleId = SimpleId
1, $sel:txInputs:SimpleTx :: UTxOType SimpleTx
txInputs = [SimpleId] -> UTxOType SimpleTx
utxoRefs [SimpleId
2], $sel:txOutputs:SimpleTx :: UTxOType SimpleTx
txOutputs = [SimpleId] -> UTxOType SimpleTx
utxoRefs [SimpleId
4]}

          (EventSink (StateEvent SimpleTx) IO
recordingSink, IO [StateEvent SimpleTx]
getRecordedEvents) <- IO (EventSink (StateEvent SimpleTx) IO, IO [StateEvent SimpleTx])
forall a. IO (EventSink a IO, IO [a])
createRecordingSink

          (HydraNode SimpleTx IO
node, IO [ServerOutput SimpleTx]
getServerOutputs) <-
            EventSource (StateEvent SimpleTx) IO
-> [EventSink (StateEvent SimpleTx) IO]
-> IO (DraftHydraNode SimpleTx IO)
testHydrate EventSource (StateEvent SimpleTx) IO
eventSource [EventSink (StateEvent SimpleTx) IO
eventSink, EventSink (StateEvent SimpleTx) IO
recordingSink]
              IO (DraftHydraNode SimpleTx IO)
-> (DraftHydraNode SimpleTx IO -> IO (HydraNode SimpleTx IO))
-> IO (HydraNode SimpleTx IO)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= DraftHydraNode SimpleTx IO -> IO (HydraNode SimpleTx IO)
forall (m :: * -> *).
MonadThrow m =>
DraftHydraNode SimpleTx m -> m (HydraNode SimpleTx m)
notConnect
              IO (HydraNode SimpleTx IO)
-> (HydraNode SimpleTx IO -> IO (HydraNode SimpleTx IO))
-> IO (HydraNode SimpleTx IO)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Input SimpleTx]
-> HydraNode SimpleTx IO -> IO (HydraNode SimpleTx IO)
forall (m :: * -> *).
Monad m =>
[Input SimpleTx]
-> HydraNode SimpleTx m -> m (HydraNode SimpleTx m)
primeWith [Input SimpleTx
reqTx]
              IO (HydraNode SimpleTx IO)
-> (HydraNode SimpleTx IO
    -> IO (HydraNode SimpleTx IO, IO [ServerOutput SimpleTx]))
-> IO (HydraNode SimpleTx IO, IO [ServerOutput SimpleTx])
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HydraNode SimpleTx IO
-> IO (HydraNode SimpleTx IO, IO [ServerOutput SimpleTx])
forall tx.
HydraNode tx IO -> IO (HydraNode tx IO, IO [ServerOutput tx])
recordServerOutputs
          HydraNode SimpleTx IO -> IO ()
forall tx. IsChainState tx => HydraNode tx IO -> IO ()
runToCompletion HydraNode SimpleTx IO
node

          IO [ServerOutput SimpleTx]
getServerOutputs IO [ServerOutput SimpleTx]
-> ([ServerOutput SimpleTx] -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ([ServerOutput SimpleTx] -> [ServerOutput SimpleTx] -> IO ()
forall a. (HasCallStack, Show a, Eq a) => [a] -> [a] -> IO ()
`shouldContain` [TxValid{$sel:headId:PeerConnected :: HeadId
headId = HeadId
testHeadId, $sel:transactionId:PeerConnected :: TxIdType SimpleTx
transactionId = SimpleId
TxIdType SimpleTx
1}])

          -- Ensures that event ids are correctly loaded in hydrate
          [StateEvent SimpleTx]
events <- IO [StateEvent SimpleTx]
getRecordedEvents
          StateEvent SimpleTx -> EventId
forall a. HasEventId a => a -> EventId
getEventId (StateEvent SimpleTx -> EventId)
-> [StateEvent SimpleTx] -> [EventId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [StateEvent SimpleTx]
events [EventId] -> ([EventId] -> Bool) -> IO ()
forall a. (HasCallStack, Show a) => a -> (a -> Bool) -> IO ()
`shouldSatisfy` [EventId] -> Bool
forall a. Ord a => [a] -> Bool
isStrictlyMonotonic

    String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"emits a single ReqSn as leader, even after multiple ReqTxs" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$
      Text -> (Tracer IO (HydraNodeLog SimpleTx) -> IO ()) -> IO ()
forall (m :: * -> *) msg a.
(MonadSTM m, MonadCatch m, MonadFork m, MonadTime m, MonadSay m,
 ToJSON msg) =>
Text -> (Tracer m msg -> m a) -> m a
showLogsOnFailure Text
"NodeSpec" ((Tracer IO (HydraNodeLog SimpleTx) -> IO ()) -> IO ())
-> (Tracer IO (HydraNodeLog SimpleTx) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Tracer IO (HydraNodeLog SimpleTx)
tracer -> do
        -- NOTE(SN): Sequence of parties in OnInitTx of
        -- 'inputsToOpenHead' is relevant, so 10 is the (initial) snapshot leader
        let tx1 :: SimpleTx
tx1 = SimpleTx{$sel:txSimpleId:SimpleTx :: SimpleId
txSimpleId = SimpleId
1, $sel:txInputs:SimpleTx :: UTxOType SimpleTx
txInputs = [SimpleId] -> UTxOType SimpleTx
utxoRefs [SimpleId
2], $sel:txOutputs:SimpleTx :: UTxOType SimpleTx
txOutputs = [SimpleId] -> UTxOType SimpleTx
utxoRefs [SimpleId
4]}
            tx2 :: SimpleTx
tx2 = SimpleTx{$sel:txSimpleId:SimpleTx :: SimpleId
txSimpleId = SimpleId
2, $sel:txInputs:SimpleTx :: UTxOType SimpleTx
txInputs = [SimpleId] -> UTxOType SimpleTx
utxoRefs [SimpleId
4], $sel:txOutputs:SimpleTx :: UTxOType SimpleTx
txOutputs = [SimpleId] -> UTxOType SimpleTx
utxoRefs [SimpleId
5]}
            tx3 :: SimpleTx
tx3 = SimpleTx{$sel:txSimpleId:SimpleTx :: SimpleId
txSimpleId = SimpleId
3, $sel:txInputs:SimpleTx :: UTxOType SimpleTx
txInputs = [SimpleId] -> UTxOType SimpleTx
utxoRefs [SimpleId
5], $sel:txOutputs:SimpleTx :: UTxOType SimpleTx
txOutputs = [SimpleId] -> UTxOType SimpleTx
utxoRefs [SimpleId
6]}
            inputs :: [Input SimpleTx]
inputs =
              [Input SimpleTx]
inputsToOpenHead
                [Input SimpleTx] -> [Input SimpleTx] -> [Input SimpleTx]
forall a. Semigroup a => a -> a -> a
<> [ Message SimpleTx -> Input SimpleTx
forall tx. Message tx -> Input tx
receiveMessage ReqTx{$sel:transaction:ReqTx :: SimpleTx
transaction = SimpleTx
tx1}
                   , Message SimpleTx -> Input SimpleTx
forall tx. Message tx -> Input tx
receiveMessage ReqTx{$sel:transaction:ReqTx :: SimpleTx
transaction = SimpleTx
tx2}
                   , Message SimpleTx -> Input SimpleTx
forall tx. Message tx -> Input tx
receiveMessage ReqTx{$sel:transaction:ReqTx :: SimpleTx
transaction = SimpleTx
tx3}
                   ]
        (HydraNode SimpleTx IO
node, IO [Message SimpleTx]
getNetworkEvents) <-
          Tracer IO (HydraNodeLog SimpleTx)
-> SigningKey HydraKey
-> [Party]
-> ContestationPeriod
-> [Input SimpleTx]
-> IO (HydraNode SimpleTx IO)
forall (m :: * -> *).
(MonadDelay m, MonadAsync m, MonadLabelledSTM m, MonadThrow m) =>
Tracer m (HydraNodeLog SimpleTx)
-> SigningKey HydraKey
-> [Party]
-> ContestationPeriod
-> [Input SimpleTx]
-> m (HydraNode SimpleTx m)
testHydraNode Tracer IO (HydraNodeLog SimpleTx)
tracer SigningKey HydraKey
aliceSk [Party
bob, Party
carol] ContestationPeriod
cperiod [Input SimpleTx]
inputs
            IO (HydraNode SimpleTx IO)
-> (HydraNode SimpleTx IO
    -> IO (HydraNode SimpleTx IO, IO [Message SimpleTx]))
-> IO (HydraNode SimpleTx IO, IO [Message SimpleTx])
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HydraNode SimpleTx IO
-> IO (HydraNode SimpleTx IO, IO [Message SimpleTx])
forall tx. HydraNode tx IO -> IO (HydraNode tx IO, IO [Message tx])
recordNetwork
        HydraNode SimpleTx IO -> IO ()
forall tx. IsChainState tx => HydraNode tx IO -> IO ()
runToCompletion HydraNode SimpleTx IO
node
        IO [Message SimpleTx]
getNetworkEvents IO [Message SimpleTx] -> [Message SimpleTx] -> IO ()
forall a. (HasCallStack, Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` [SnapshotVersion
-> SnapshotNumber
-> [TxIdType SimpleTx]
-> Maybe SimpleTx
-> Maybe (UTxOType SimpleTx)
-> Message SimpleTx
forall tx.
SnapshotVersion
-> SnapshotNumber
-> [TxIdType tx]
-> Maybe tx
-> Maybe (UTxOType tx)
-> Message tx
ReqSn SnapshotVersion
0 SnapshotNumber
1 [SimpleId
TxIdType SimpleTx
1] Maybe SimpleTx
forall a. Maybe a
Nothing Maybe (Set SimpleTxOut)
Maybe (UTxOType SimpleTx)
forall a. Maybe a
Nothing]

    String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"rotates snapshot leaders" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$
      Text -> (Tracer IO (HydraNodeLog SimpleTx) -> IO ()) -> IO ()
forall (m :: * -> *) msg a.
(MonadSTM m, MonadCatch m, MonadFork m, MonadTime m, MonadSay m,
 ToJSON msg) =>
Text -> (Tracer m msg -> m a) -> m a
showLogsOnFailure Text
"NodeSpec" ((Tracer IO (HydraNodeLog SimpleTx) -> IO ()) -> IO ())
-> (Tracer IO (HydraNodeLog SimpleTx) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Tracer IO (HydraNodeLog SimpleTx)
tracer -> do
        let tx1 :: SimpleTx
tx1 = SimpleTx{$sel:txSimpleId:SimpleTx :: SimpleId
txSimpleId = SimpleId
1, $sel:txInputs:SimpleTx :: UTxOType SimpleTx
txInputs = [SimpleId] -> UTxOType SimpleTx
utxoRefs [SimpleId
2], $sel:txOutputs:SimpleTx :: UTxOType SimpleTx
txOutputs = [SimpleId] -> UTxOType SimpleTx
utxoRefs [SimpleId
4]}
            sn1 :: Snapshot SimpleTx
sn1 = SnapshotNumber
-> SnapshotVersion
-> [SimpleTx]
-> UTxOType SimpleTx
-> Snapshot SimpleTx
forall tx.
Monoid (UTxOType tx) =>
SnapshotNumber
-> SnapshotVersion -> [tx] -> UTxOType tx -> Snapshot tx
testSnapshot SnapshotNumber
1 SnapshotVersion
0 [] ([SimpleId] -> UTxOType SimpleTx
utxoRefs [SimpleId
1, SimpleId
2, SimpleId
3])
            inputs :: [Input SimpleTx]
inputs =
              [Input SimpleTx]
inputsToOpenHead
                [Input SimpleTx] -> [Input SimpleTx] -> [Input SimpleTx]
forall a. Semigroup a => a -> a -> a
<> [ Message SimpleTx -> Input SimpleTx
forall tx. Message tx -> Input tx
receiveMessage ReqSn{$sel:snapshotVersion:ReqTx :: SnapshotVersion
snapshotVersion = SnapshotVersion
0, $sel:snapshotNumber:ReqTx :: SnapshotNumber
snapshotNumber = SnapshotNumber
1, $sel:transactionIds:ReqTx :: [TxIdType SimpleTx]
transactionIds = [SimpleId]
[TxIdType SimpleTx]
forall a. Monoid a => a
mempty, $sel:incrementUTxO:ReqTx :: Maybe (UTxOType SimpleTx)
incrementUTxO = Maybe (Set SimpleTxOut)
Maybe (UTxOType SimpleTx)
forall a. Maybe a
Nothing, $sel:decommitTx:ReqTx :: Maybe SimpleTx
decommitTx = Maybe SimpleTx
forall a. Maybe a
Nothing}
                   , Party -> Message SimpleTx -> Input SimpleTx
forall tx. Party -> Message tx -> Input tx
receiveMessageFrom Party
alice (Message SimpleTx -> Input SimpleTx)
-> Message SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ Signature (Snapshot SimpleTx) -> SnapshotNumber -> Message SimpleTx
forall tx. Signature (Snapshot tx) -> SnapshotNumber -> Message tx
AckSn (SigningKey HydraKey
-> Snapshot SimpleTx -> Signature (Snapshot SimpleTx)
forall a.
SignableRepresentation a =>
SigningKey HydraKey -> a -> Signature a
sign SigningKey HydraKey
aliceSk Snapshot SimpleTx
sn1) SnapshotNumber
1
                   , Party -> Message SimpleTx -> Input SimpleTx
forall tx. Party -> Message tx -> Input tx
receiveMessageFrom Party
bob (Message SimpleTx -> Input SimpleTx)
-> Message SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ Signature (Snapshot SimpleTx) -> SnapshotNumber -> Message SimpleTx
forall tx. Signature (Snapshot tx) -> SnapshotNumber -> Message tx
AckSn (SigningKey HydraKey
-> Snapshot SimpleTx -> Signature (Snapshot SimpleTx)
forall a.
SignableRepresentation a =>
SigningKey HydraKey -> a -> Signature a
sign SigningKey HydraKey
bobSk Snapshot SimpleTx
sn1) SnapshotNumber
1
                   , Party -> Message SimpleTx -> Input SimpleTx
forall tx. Party -> Message tx -> Input tx
receiveMessageFrom Party
carol (Message SimpleTx -> Input SimpleTx)
-> Message SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ Signature (Snapshot SimpleTx) -> SnapshotNumber -> Message SimpleTx
forall tx. Signature (Snapshot tx) -> SnapshotNumber -> Message tx
AckSn (SigningKey HydraKey
-> Snapshot SimpleTx -> Signature (Snapshot SimpleTx)
forall a.
SignableRepresentation a =>
SigningKey HydraKey -> a -> Signature a
sign SigningKey HydraKey
carolSk Snapshot SimpleTx
sn1) SnapshotNumber
1
                   , Message SimpleTx -> Input SimpleTx
forall tx. Message tx -> Input tx
receiveMessage ReqTx{$sel:transaction:ReqTx :: SimpleTx
transaction = SimpleTx
tx1}
                   ]

        (HydraNode SimpleTx IO
node, IO [Message SimpleTx]
getNetworkEvents) <-
          Tracer IO (HydraNodeLog SimpleTx)
-> SigningKey HydraKey
-> [Party]
-> ContestationPeriod
-> [Input SimpleTx]
-> IO (HydraNode SimpleTx IO)
forall (m :: * -> *).
(MonadDelay m, MonadAsync m, MonadLabelledSTM m, MonadThrow m) =>
Tracer m (HydraNodeLog SimpleTx)
-> SigningKey HydraKey
-> [Party]
-> ContestationPeriod
-> [Input SimpleTx]
-> m (HydraNode SimpleTx m)
testHydraNode Tracer IO (HydraNodeLog SimpleTx)
tracer SigningKey HydraKey
bobSk [Party
alice, Party
carol] ContestationPeriod
cperiod [Input SimpleTx]
inputs
            IO (HydraNode SimpleTx IO)
-> (HydraNode SimpleTx IO
    -> IO (HydraNode SimpleTx IO, IO [Message SimpleTx]))
-> IO (HydraNode SimpleTx IO, IO [Message SimpleTx])
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HydraNode SimpleTx IO
-> IO (HydraNode SimpleTx IO, IO [Message SimpleTx])
forall tx. HydraNode tx IO -> IO (HydraNode tx IO, IO [Message tx])
recordNetwork
        HydraNode SimpleTx IO -> IO ()
forall tx. IsChainState tx => HydraNode tx IO -> IO ()
runToCompletion HydraNode SimpleTx IO
node

        IO [Message SimpleTx]
getNetworkEvents IO [Message SimpleTx] -> [Message SimpleTx] -> IO ()
forall a. (HasCallStack, Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` [Signature (Snapshot SimpleTx) -> SnapshotNumber -> Message SimpleTx
forall tx. Signature (Snapshot tx) -> SnapshotNumber -> Message tx
AckSn (SigningKey HydraKey
-> Snapshot SimpleTx -> Signature (Snapshot SimpleTx)
forall a.
SignableRepresentation a =>
SigningKey HydraKey -> a -> Signature a
sign SigningKey HydraKey
bobSk Snapshot SimpleTx
sn1) SnapshotNumber
1, SnapshotVersion
-> SnapshotNumber
-> [TxIdType SimpleTx]
-> Maybe SimpleTx
-> Maybe (UTxOType SimpleTx)
-> Message SimpleTx
forall tx.
SnapshotVersion
-> SnapshotNumber
-> [TxIdType tx]
-> Maybe tx
-> Maybe (UTxOType tx)
-> Message tx
ReqSn SnapshotVersion
0 SnapshotNumber
2 [SimpleId
TxIdType SimpleTx
1] Maybe SimpleTx
forall a. Maybe a
Nothing Maybe (Set SimpleTxOut)
Maybe (UTxOType SimpleTx)
forall a. Maybe a
Nothing]

    String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"processes out-of-order AckSn" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$
      Text -> (Tracer IO (HydraNodeLog SimpleTx) -> IO ()) -> IO ()
forall (m :: * -> *) msg a.
(MonadSTM m, MonadCatch m, MonadFork m, MonadTime m, MonadSay m,
 ToJSON msg) =>
Text -> (Tracer m msg -> m a) -> m a
showLogsOnFailure Text
"NodeSpec" ((Tracer IO (HydraNodeLog SimpleTx) -> IO ()) -> IO ())
-> (Tracer IO (HydraNodeLog SimpleTx) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Tracer IO (HydraNodeLog SimpleTx)
tracer -> do
        let snapshot :: Snapshot SimpleTx
snapshot = SnapshotNumber
-> SnapshotVersion
-> [SimpleTx]
-> UTxOType SimpleTx
-> Snapshot SimpleTx
forall tx.
Monoid (UTxOType tx) =>
SnapshotNumber
-> SnapshotVersion -> [tx] -> UTxOType tx -> Snapshot tx
testSnapshot SnapshotNumber
1 SnapshotVersion
0 [] ([SimpleId] -> UTxOType SimpleTx
utxoRefs [SimpleId
1, SimpleId
2, SimpleId
3])
            sigBob :: Signature (Snapshot SimpleTx)
sigBob = SigningKey HydraKey
-> Snapshot SimpleTx -> Signature (Snapshot SimpleTx)
forall a.
SignableRepresentation a =>
SigningKey HydraKey -> a -> Signature a
sign SigningKey HydraKey
bobSk Snapshot SimpleTx
snapshot
            sigAlice :: Signature (Snapshot SimpleTx)
sigAlice = SigningKey HydraKey
-> Snapshot SimpleTx -> Signature (Snapshot SimpleTx)
forall a.
SignableRepresentation a =>
SigningKey HydraKey -> a -> Signature a
sign SigningKey HydraKey
aliceSk Snapshot SimpleTx
snapshot
            inputs :: [Input SimpleTx]
inputs =
              [Input SimpleTx]
inputsToOpenHead
                [Input SimpleTx] -> [Input SimpleTx] -> [Input SimpleTx]
forall a. Semigroup a => a -> a -> a
<> [ Party -> Message SimpleTx -> Input SimpleTx
forall tx. Party -> Message tx -> Input tx
receiveMessageFrom Party
bob AckSn{$sel:signed:ReqTx :: Signature (Snapshot SimpleTx)
signed = Signature (Snapshot SimpleTx)
sigBob, $sel:snapshotNumber:ReqTx :: SnapshotNumber
snapshotNumber = SnapshotNumber
1}
                   , Message SimpleTx -> Input SimpleTx
forall tx. Message tx -> Input tx
receiveMessage ReqSn{$sel:snapshotVersion:ReqTx :: SnapshotVersion
snapshotVersion = SnapshotVersion
0, $sel:snapshotNumber:ReqTx :: SnapshotNumber
snapshotNumber = SnapshotNumber
1, $sel:transactionIds:ReqTx :: [TxIdType SimpleTx]
transactionIds = [], $sel:decommitTx:ReqTx :: Maybe SimpleTx
decommitTx = Maybe SimpleTx
forall a. Maybe a
Nothing, $sel:incrementUTxO:ReqTx :: Maybe (UTxOType SimpleTx)
incrementUTxO = Maybe (Set SimpleTxOut)
Maybe (UTxOType SimpleTx)
forall a. Maybe a
Nothing}
                   ]
        (HydraNode SimpleTx IO
node, IO [Message SimpleTx]
getNetworkEvents) <-
          Tracer IO (HydraNodeLog SimpleTx)
-> SigningKey HydraKey
-> [Party]
-> ContestationPeriod
-> [Input SimpleTx]
-> IO (HydraNode SimpleTx IO)
forall (m :: * -> *).
(MonadDelay m, MonadAsync m, MonadLabelledSTM m, MonadThrow m) =>
Tracer m (HydraNodeLog SimpleTx)
-> SigningKey HydraKey
-> [Party]
-> ContestationPeriod
-> [Input SimpleTx]
-> m (HydraNode SimpleTx m)
testHydraNode Tracer IO (HydraNodeLog SimpleTx)
tracer SigningKey HydraKey
aliceSk [Party
bob, Party
carol] ContestationPeriod
cperiod [Input SimpleTx]
inputs
            IO (HydraNode SimpleTx IO)
-> (HydraNode SimpleTx IO
    -> IO (HydraNode SimpleTx IO, IO [Message SimpleTx]))
-> IO (HydraNode SimpleTx IO, IO [Message SimpleTx])
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HydraNode SimpleTx IO
-> IO (HydraNode SimpleTx IO, IO [Message SimpleTx])
forall tx. HydraNode tx IO -> IO (HydraNode tx IO, IO [Message tx])
recordNetwork
        HydraNode SimpleTx IO -> IO ()
forall tx. IsChainState tx => HydraNode tx IO -> IO ()
runToCompletion HydraNode SimpleTx IO
node
        IO [Message SimpleTx]
getNetworkEvents IO [Message SimpleTx] -> [Message SimpleTx] -> IO ()
forall a. (HasCallStack, Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` [AckSn{$sel:signed:ReqTx :: Signature (Snapshot SimpleTx)
signed = Signature (Snapshot SimpleTx)
sigAlice, $sel:snapshotNumber:ReqTx :: SnapshotNumber
snapshotNumber = SnapshotNumber
1}]

    String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"notifies client when postTx throws PostTxError" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$
      Text -> (Tracer IO (HydraNodeLog SimpleTx) -> IO ()) -> IO ()
forall (m :: * -> *) msg a.
(MonadSTM m, MonadCatch m, MonadFork m, MonadTime m, MonadSay m,
 ToJSON msg) =>
Text -> (Tracer m msg -> m a) -> m a
showLogsOnFailure Text
"NodeSpec" ((Tracer IO (HydraNodeLog SimpleTx) -> IO ()) -> IO ())
-> (Tracer IO (HydraNodeLog SimpleTx) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Tracer IO (HydraNodeLog SimpleTx)
tracer -> do
        let inputs :: [Input tx]
inputs = [ClientInput tx -> Input tx
forall tx. ClientInput tx -> Input tx
ClientInput ClientInput tx
forall tx. ClientInput tx
Init]
        (HydraNode SimpleTx IO
node, IO [ServerOutput SimpleTx]
getServerOutputs) <-
          Tracer IO (HydraNodeLog SimpleTx)
-> SigningKey HydraKey
-> [Party]
-> ContestationPeriod
-> [Input SimpleTx]
-> IO (HydraNode SimpleTx IO)
forall (m :: * -> *).
(MonadDelay m, MonadAsync m, MonadLabelledSTM m, MonadThrow m) =>
Tracer m (HydraNodeLog SimpleTx)
-> SigningKey HydraKey
-> [Party]
-> ContestationPeriod
-> [Input SimpleTx]
-> m (HydraNode SimpleTx m)
testHydraNode Tracer IO (HydraNodeLog SimpleTx)
tracer SigningKey HydraKey
aliceSk [Party
bob, Party
carol] ContestationPeriod
cperiod [Input SimpleTx]
forall {tx}. [Input tx]
inputs
            IO (HydraNode SimpleTx IO)
-> (HydraNode SimpleTx IO -> IO (HydraNode SimpleTx IO))
-> IO (HydraNode SimpleTx IO)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= PostTxError SimpleTx
-> HydraNode SimpleTx IO -> IO (HydraNode SimpleTx IO)
forall tx.
IsChainState tx =>
PostTxError tx -> HydraNode tx IO -> IO (HydraNode tx IO)
throwExceptionOnPostTx PostTxError SimpleTx
forall tx. PostTxError tx
NoSeedInput
            IO (HydraNode SimpleTx IO)
-> (HydraNode SimpleTx IO
    -> IO (HydraNode SimpleTx IO, IO [ServerOutput SimpleTx]))
-> IO (HydraNode SimpleTx IO, IO [ServerOutput SimpleTx])
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HydraNode SimpleTx IO
-> IO (HydraNode SimpleTx IO, IO [ServerOutput SimpleTx])
forall tx.
HydraNode tx IO -> IO (HydraNode tx IO, IO [ServerOutput tx])
recordServerOutputs

        HydraNode SimpleTx IO -> IO ()
forall tx. IsChainState tx => HydraNode tx IO -> IO ()
runToCompletion HydraNode SimpleTx IO
node

        [ServerOutput SimpleTx]
outputs <- IO [ServerOutput SimpleTx]
getServerOutputs
        let isPostTxOnChainFailed :: ServerOutput SimpleTx -> Bool
isPostTxOnChainFailed = \case
              PostTxOnChainFailed{PostTxError SimpleTx
postTxError :: PostTxError SimpleTx
$sel:postTxError:PeerConnected :: forall tx. ServerOutput tx -> PostTxError tx
postTxError} -> PostTxError SimpleTx
postTxError PostTxError SimpleTx -> PostTxError SimpleTx -> Bool
forall a. Eq a => a -> a -> Bool
== PostTxError SimpleTx
forall tx. PostTxError tx
NoSeedInput
              ServerOutput SimpleTx
_ -> Bool
False
        (ServerOutput SimpleTx -> Bool) -> [ServerOutput SimpleTx] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ServerOutput SimpleTx -> Bool
isPostTxOnChainFailed [ServerOutput SimpleTx]
outputs Bool -> Bool -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Bool
True

    String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"signs snapshot even if it has seen conflicting transactions" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$
      NominalDiffTime -> IO () -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTimer m, MonadThrow m) =>
NominalDiffTime -> m a -> m a
failAfter NominalDiffTime
1 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        Text -> (Tracer IO (HydraNodeLog SimpleTx) -> IO ()) -> IO ()
forall (m :: * -> *) msg a.
(MonadSTM m, MonadCatch m, MonadFork m, MonadTime m, MonadSay m,
 ToJSON msg) =>
Text -> (Tracer m msg -> m a) -> m a
showLogsOnFailure Text
"NodeSpec" ((Tracer IO (HydraNodeLog SimpleTx) -> IO ()) -> IO ())
-> (Tracer IO (HydraNodeLog SimpleTx) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Tracer IO (HydraNodeLog SimpleTx)
tracer -> do
          let tx1 :: SimpleTx
tx1 = SimpleTx{$sel:txSimpleId:SimpleTx :: SimpleId
txSimpleId = SimpleId
1, $sel:txInputs:SimpleTx :: UTxOType SimpleTx
txInputs = [SimpleId] -> UTxOType SimpleTx
utxoRefs [SimpleId
2], $sel:txOutputs:SimpleTx :: UTxOType SimpleTx
txOutputs = [SimpleId] -> UTxOType SimpleTx
utxoRefs [SimpleId
4]}
              tx2 :: SimpleTx
tx2 = SimpleTx{$sel:txSimpleId:SimpleTx :: SimpleId
txSimpleId = SimpleId
2, $sel:txInputs:SimpleTx :: UTxOType SimpleTx
txInputs = [SimpleId] -> UTxOType SimpleTx
utxoRefs [SimpleId
2], $sel:txOutputs:SimpleTx :: UTxOType SimpleTx
txOutputs = [SimpleId] -> UTxOType SimpleTx
utxoRefs [SimpleId
5]}
              snapshot :: Snapshot SimpleTx
snapshot = SnapshotNumber
-> SnapshotVersion
-> [SimpleTx]
-> UTxOType SimpleTx
-> Snapshot SimpleTx
forall tx.
Monoid (UTxOType tx) =>
SnapshotNumber
-> SnapshotVersion -> [tx] -> UTxOType tx -> Snapshot tx
testSnapshot SnapshotNumber
1 SnapshotVersion
0 [SimpleTx
tx2] ([SimpleId] -> UTxOType SimpleTx
utxoRefs [SimpleId
1, SimpleId
3, SimpleId
5])
              sigBob :: Signature (Snapshot SimpleTx)
sigBob = SigningKey HydraKey
-> Snapshot SimpleTx -> Signature (Snapshot SimpleTx)
forall a.
SignableRepresentation a =>
SigningKey HydraKey -> a -> Signature a
sign SigningKey HydraKey
bobSk Snapshot SimpleTx
snapshot
              inputs :: [Input SimpleTx]
inputs =
                [Input SimpleTx]
inputsToOpenHead
                  [Input SimpleTx] -> [Input SimpleTx] -> [Input SimpleTx]
forall a. Semigroup a => a -> a -> a
<> [ Party -> Message SimpleTx -> Input SimpleTx
forall tx. Party -> Message tx -> Input tx
receiveMessageFrom Party
bob ReqTx{$sel:transaction:ReqTx :: SimpleTx
transaction = SimpleTx
tx1}
                     , Party -> Message SimpleTx -> Input SimpleTx
forall tx. Party -> Message tx -> Input tx
receiveMessageFrom Party
bob ReqTx{$sel:transaction:ReqTx :: SimpleTx
transaction = SimpleTx
tx2}
                     , Message SimpleTx -> Input SimpleTx
forall tx. Message tx -> Input tx
receiveMessage ReqSn{$sel:snapshotVersion:ReqTx :: SnapshotVersion
snapshotVersion = SnapshotVersion
0, $sel:snapshotNumber:ReqTx :: SnapshotNumber
snapshotNumber = SnapshotNumber
1, $sel:transactionIds:ReqTx :: [TxIdType SimpleTx]
transactionIds = [SimpleId
TxIdType SimpleTx
2], $sel:decommitTx:ReqTx :: Maybe SimpleTx
decommitTx = Maybe SimpleTx
forall a. Maybe a
Nothing, $sel:incrementUTxO:ReqTx :: Maybe (UTxOType SimpleTx)
incrementUTxO = Maybe (Set SimpleTxOut)
Maybe (UTxOType SimpleTx)
forall a. Maybe a
Nothing}
                     ]
          (HydraNode SimpleTx IO
node, IO [Message SimpleTx]
getNetworkEvents) <-
            Tracer IO (HydraNodeLog SimpleTx)
-> SigningKey HydraKey
-> [Party]
-> ContestationPeriod
-> [Input SimpleTx]
-> IO (HydraNode SimpleTx IO)
forall (m :: * -> *).
(MonadDelay m, MonadAsync m, MonadLabelledSTM m, MonadThrow m) =>
Tracer m (HydraNodeLog SimpleTx)
-> SigningKey HydraKey
-> [Party]
-> ContestationPeriod
-> [Input SimpleTx]
-> m (HydraNode SimpleTx m)
testHydraNode Tracer IO (HydraNodeLog SimpleTx)
tracer SigningKey HydraKey
bobSk [Party
alice, Party
carol] ContestationPeriod
cperiod [Input SimpleTx]
inputs
              IO (HydraNode SimpleTx IO)
-> (HydraNode SimpleTx IO
    -> IO (HydraNode SimpleTx IO, IO [Message SimpleTx]))
-> IO (HydraNode SimpleTx IO, IO [Message SimpleTx])
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HydraNode SimpleTx IO
-> IO (HydraNode SimpleTx IO, IO [Message SimpleTx])
forall tx. HydraNode tx IO -> IO (HydraNode tx IO, IO [Message tx])
recordNetwork
          HydraNode SimpleTx IO -> IO ()
forall tx. IsChainState tx => HydraNode tx IO -> IO ()
runToCompletion HydraNode SimpleTx IO
node
          IO [Message SimpleTx]
getNetworkEvents IO [Message SimpleTx] -> [Message SimpleTx] -> IO ()
forall a. (HasCallStack, Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` [AckSn{$sel:signed:ReqTx :: Signature (Snapshot SimpleTx)
signed = Signature (Snapshot SimpleTx)
sigBob, $sel:snapshotNumber:ReqTx :: SnapshotNumber
snapshotNumber = SnapshotNumber
1}]

  String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"checkHeadState" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
    let defaultEnv :: Environment
defaultEnv =
          Environment
            { $sel:party:Environment :: Party
party = Party
alice
            , $sel:signingKey:Environment :: SigningKey HydraKey
signingKey = SigningKey HydraKey
aliceSk
            , $sel:otherParties:Environment :: [Party]
otherParties = [Party
bob]
            , $sel:contestationPeriod:Environment :: ContestationPeriod
contestationPeriod = ContestationPeriod
defaultContestationPeriod
            , $sel:participants:Environment :: [OnChainId]
participants = Text -> [OnChainId]
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"should not be recorded in head state"
            }
        headState :: HeadState SimpleTx
headState = [Party] -> HeadState SimpleTx
inInitialState [Party
alice, Party
bob]

    String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"accepts configuration consistent with HeadState" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$
      Text -> (Tracer IO (HydraNodeLog SimpleTx) -> IO ()) -> IO ()
forall (m :: * -> *) msg a.
(MonadSTM m, MonadCatch m, MonadFork m, MonadTime m, MonadSay m,
 ToJSON msg) =>
Text -> (Tracer m msg -> m a) -> m a
showLogsOnFailure Text
"NodeSpec" ((Tracer IO (HydraNodeLog SimpleTx) -> IO ()) -> IO ())
-> (Tracer IO (HydraNodeLog SimpleTx) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Tracer IO (HydraNodeLog SimpleTx)
tracer -> do
        Tracer IO (HydraNodeLog SimpleTx)
-> Environment -> HeadState SimpleTx -> IO ()
forall (m :: * -> *) tx.
MonadThrow m =>
Tracer m (HydraNodeLog tx) -> Environment -> HeadState tx -> m ()
checkHeadState Tracer IO (HydraNodeLog SimpleTx)
tracer Environment
defaultEnv HeadState SimpleTx
headState IO () -> () -> IO ()
forall a. (HasCallStack, Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` ()

    String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"throws exception given contestation period differs" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$
      Text -> (Tracer IO (HydraNodeLog SimpleTx) -> IO ()) -> IO ()
forall (m :: * -> *) msg a.
(MonadSTM m, MonadCatch m, MonadFork m, MonadTime m, MonadSay m,
 ToJSON msg) =>
Text -> (Tracer m msg -> m a) -> m a
showLogsOnFailure Text
"NodeSpec" ((Tracer IO (HydraNodeLog SimpleTx) -> IO ()) -> IO ())
-> (Tracer IO (HydraNodeLog SimpleTx) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Tracer IO (HydraNodeLog SimpleTx)
tracer -> do
        let invalidPeriodEnv :: Environment
invalidPeriodEnv =
              Environment
defaultEnv{Environment.contestationPeriod = UnsafeContestationPeriod 42}
        Tracer IO (HydraNodeLog SimpleTx)
-> Environment -> HeadState SimpleTx -> IO ()
forall (m :: * -> *) tx.
MonadThrow m =>
Tracer m (HydraNodeLog tx) -> Environment -> HeadState tx -> m ()
checkHeadState Tracer IO (HydraNodeLog SimpleTx)
tracer Environment
invalidPeriodEnv HeadState SimpleTx
headState
          IO () -> Selector ParameterMismatch -> IO ()
forall e a.
(HasCallStack, Exception e) =>
IO a -> Selector e -> IO ()
`shouldThrow` \(ParameterMismatch
_ :: ParameterMismatch) -> Bool
True

    String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"throws exception given parties differ" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$
      Text -> (Tracer IO (HydraNodeLog SimpleTx) -> IO ()) -> IO ()
forall (m :: * -> *) msg a.
(MonadSTM m, MonadCatch m, MonadFork m, MonadTime m, MonadSay m,
 ToJSON msg) =>
Text -> (Tracer m msg -> m a) -> m a
showLogsOnFailure Text
"NodeSpec" ((Tracer IO (HydraNodeLog SimpleTx) -> IO ()) -> IO ())
-> (Tracer IO (HydraNodeLog SimpleTx) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Tracer IO (HydraNodeLog SimpleTx)
tracer -> do
        let invalidPeriodEnv :: Environment
invalidPeriodEnv = Environment
defaultEnv{otherParties = []}
        Tracer IO (HydraNodeLog SimpleTx)
-> Environment -> HeadState SimpleTx -> IO ()
forall (m :: * -> *) tx.
MonadThrow m =>
Tracer m (HydraNodeLog tx) -> Environment -> HeadState tx -> m ()
checkHeadState Tracer IO (HydraNodeLog SimpleTx)
tracer Environment
invalidPeriodEnv HeadState SimpleTx
headState
          IO () -> Selector ParameterMismatch -> IO ()
forall e a.
(HasCallStack, Exception e) =>
IO a -> Selector e -> IO ()
`shouldThrow` \(ParameterMismatch
_ :: ParameterMismatch) -> Bool
True

    String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"log error given configuration mismatches head state" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
      TVar [Envelope (HydraNodeLog SimpleTx)]
logs <- [Envelope (HydraNodeLog SimpleTx)]
-> IO (TVar IO [Envelope (HydraNodeLog SimpleTx)])
forall a. a -> IO (TVar IO a)
forall (m :: * -> *) a. MonadSTM m => a -> m (TVar m a)
newTVarIO []
      let invalidPeriodEnv :: Environment
invalidPeriodEnv = Environment
defaultEnv{otherParties = []}
          isContestationPeriodMismatch :: HydraNodeLog tx -> Bool
isContestationPeriodMismatch = \case
            Misconfiguration{} -> Bool
True
            HydraNodeLog tx
_ -> Bool
False

      Tracer IO (HydraNodeLog SimpleTx)
-> Environment -> HeadState SimpleTx -> IO ()
forall (m :: * -> *) tx.
MonadThrow m =>
Tracer m (HydraNodeLog tx) -> Environment -> HeadState tx -> m ()
checkHeadState (TVar IO [Envelope (HydraNodeLog SimpleTx)]
-> Text -> Tracer IO (HydraNodeLog SimpleTx)
forall (m :: * -> *) msg.
(MonadFork m, MonadTime m, MonadSTM m) =>
TVar m [Envelope msg] -> Text -> Tracer m msg
traceInTVar TVar [Envelope (HydraNodeLog SimpleTx)]
TVar IO [Envelope (HydraNodeLog SimpleTx)]
logs Text
"NodeSpec") Environment
invalidPeriodEnv HeadState SimpleTx
headState
        IO () -> (ParameterMismatch -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \(ParameterMismatch
_ :: ParameterMismatch) -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

      [HydraNodeLog SimpleTx]
entries <- (Envelope (HydraNodeLog SimpleTx) -> HydraNodeLog SimpleTx)
-> [Envelope (HydraNodeLog SimpleTx)] -> [HydraNodeLog SimpleTx]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Envelope (HydraNodeLog SimpleTx) -> HydraNodeLog SimpleTx
forall a. Envelope a -> a
Logging.message ([Envelope (HydraNodeLog SimpleTx)] -> [HydraNodeLog SimpleTx])
-> IO [Envelope (HydraNodeLog SimpleTx)]
-> IO [HydraNodeLog SimpleTx]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar IO [Envelope (HydraNodeLog SimpleTx)]
-> IO [Envelope (HydraNodeLog SimpleTx)]
forall a. TVar IO a -> IO a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> m a
readTVarIO TVar [Envelope (HydraNodeLog SimpleTx)]
TVar IO [Envelope (HydraNodeLog SimpleTx)]
logs
      [HydraNodeLog SimpleTx]
entries [HydraNodeLog SimpleTx]
-> ([HydraNodeLog SimpleTx] -> Bool) -> IO ()
forall a. (HasCallStack, Show a) => a -> (a -> Bool) -> IO ()
`shouldSatisfy` (HydraNodeLog SimpleTx -> Bool) -> [HydraNodeLog SimpleTx] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any HydraNodeLog SimpleTx -> Bool
forall {tx}. HydraNodeLog tx -> Bool
isContestationPeriodMismatch

-- | Add given list of inputs to the 'InputQueue'. This is returning the node to
-- allow for chaining with 'runToCompletion'.
primeWith :: Monad m => [Input SimpleTx] -> HydraNode SimpleTx m -> m (HydraNode SimpleTx m)
primeWith :: forall (m :: * -> *).
Monad m =>
[Input SimpleTx]
-> HydraNode SimpleTx m -> m (HydraNode SimpleTx m)
primeWith [Input SimpleTx]
inputs node :: HydraNode SimpleTx m
node@HydraNode{$sel:inputQueue:HydraNode :: forall tx (m :: * -> *). HydraNode tx m -> InputQueue m (Input tx)
inputQueue = InputQueue{Input SimpleTx -> m ()
enqueue :: Input SimpleTx -> m ()
$sel:enqueue:InputQueue :: forall (m :: * -> *) e. InputQueue m e -> e -> m ()
enqueue}} = do
  [Input SimpleTx] -> (Input SimpleTx -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Input SimpleTx]
inputs Input SimpleTx -> m ()
enqueue
  HydraNode SimpleTx m -> m (HydraNode SimpleTx m)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure HydraNode SimpleTx m
node

-- | Convert a 'DraftHydraNode' to a 'HydraNode' by providing mock implementations.
notConnect :: MonadThrow m => DraftHydraNode SimpleTx m -> m (HydraNode SimpleTx m)
notConnect :: forall (m :: * -> *).
MonadThrow m =>
DraftHydraNode SimpleTx m -> m (HydraNode SimpleTx m)
notConnect =
  Chain SimpleTx m
-> Network m (Message SimpleTx)
-> Server SimpleTx m
-> DraftHydraNode SimpleTx m
-> m (HydraNode SimpleTx m)
forall (m :: * -> *) tx.
Monad m =>
Chain tx m
-> Network m (Message tx)
-> Server tx m
-> DraftHydraNode tx m
-> m (HydraNode tx m)
connect Chain SimpleTx m
forall (m :: * -> *). MonadThrow m => Chain SimpleTx m
mockChain Network m (Message SimpleTx)
forall (m :: * -> *). Monad m => Network m (Message SimpleTx)
mockNetwork Server SimpleTx m
forall (m :: * -> *). Monad m => Server SimpleTx m
mockServer

mockServer :: Monad m => Server SimpleTx m
mockServer :: forall (m :: * -> *). Monad m => Server SimpleTx m
mockServer =
  Server{$sel:sendOutput:Server :: ServerOutput SimpleTx -> m ()
sendOutput = \ServerOutput SimpleTx
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()}

mockNetwork :: Monad m => Network m (Message SimpleTx)
mockNetwork :: forall (m :: * -> *). Monad m => Network m (Message SimpleTx)
mockNetwork =
  Network{$sel:broadcast:Network :: Message SimpleTx -> m ()
broadcast = \Message SimpleTx
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()}

mockChain :: MonadThrow m => Chain SimpleTx m
mockChain :: forall (m :: * -> *). MonadThrow m => Chain SimpleTx m
mockChain =
  Chain
    { $sel:postTx:Chain :: MonadThrow m => PostChainTx SimpleTx -> m ()
postTx = \PostChainTx SimpleTx
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    , $sel:draftCommitTx:Chain :: MonadThrow m =>
HeadId
-> CommitBlueprintTx SimpleTx
-> m (Either (PostTxError SimpleTx) SimpleTx)
draftCommitTx = \HeadId
_ CommitBlueprintTx SimpleTx
_ -> String -> m (Either (PostTxError SimpleTx) SimpleTx)
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure String
"mockChain: unexpected draftCommitTx"
    , $sel:draftDepositTx:Chain :: MonadThrow m =>
HeadId
-> CommitBlueprintTx SimpleTx
-> UTCTime
-> m (Either (PostTxError SimpleTx) SimpleTx)
draftDepositTx = \HeadId
_ CommitBlueprintTx SimpleTx
_ UTCTime
_ -> String -> m (Either (PostTxError SimpleTx) SimpleTx)
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure String
"mockChain: unexpected draftDepositTx"
    , $sel:submitTx:Chain :: MonadThrow m => SimpleTx -> m ()
submitTx = \SimpleTx
_ -> String -> m ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure String
"mockChain: unexpected submitTx"
    }

mockSink :: Monad m => EventSink a m
mockSink :: forall (m :: * -> *) a. Monad m => EventSink a m
mockSink = EventSink{$sel:putEvent:EventSink :: HasEventId a => a -> m ()
putEvent = m () -> a -> m ()
forall a b. a -> b -> a
const (m () -> a -> m ()) -> m () -> a -> m ()
forall a b. (a -> b) -> a -> b
$ () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()}

mockSource :: Monad m => [a] -> EventSource a m
mockSource :: forall (m :: * -> *) a. Monad m => [a] -> EventSource a m
mockSource [a]
events = EventSource{$sel:getEvents:EventSource :: HasEventId a => m [a]
getEvents = [a] -> m [a]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [a]
events}

createRecordingSink :: IO (EventSink a IO, IO [a])
createRecordingSink :: forall a. IO (EventSink a IO, IO [a])
createRecordingSink = do
  (a -> IO ()
putEvent, IO [a]
getAll) <- IO (a -> IO (), IO [a])
forall msg. IO (msg -> IO (), IO [msg])
messageRecorder
  (EventSink a IO, IO [a]) -> IO (EventSink a IO, IO [a])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EventSink{a -> IO ()
HasEventId a => a -> IO ()
$sel:putEvent:EventSink :: HasEventId a => a -> IO ()
putEvent :: a -> IO ()
putEvent}, IO [a]
getAll)

createPersistenceInMemory :: MonadLabelledSTM m => m (PersistenceIncremental a m)
createPersistenceInMemory :: forall (m :: * -> *) a.
MonadLabelledSTM m =>
m (PersistenceIncremental a m)
createPersistenceInMemory = do
  TVar m [a]
tvar <- [a] -> m (TVar m [a])
forall a. a -> m (TVar m a)
forall (m :: * -> *) a. MonadSTM m => a -> m (TVar m a)
newTVarIO []
  TVar m [a] -> String -> m ()
forall a. TVar m a -> String -> m ()
forall (m :: * -> *) a.
MonadLabelledSTM m =>
TVar m a -> String -> m ()
labelTVarIO TVar m [a]
tvar String
"persistence-in-memory"
  PersistenceIncremental a m -> m (PersistenceIncremental a m)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    PersistenceIncremental
      { $sel:append:PersistenceIncremental :: ToJSON a => a -> m ()
append = \a
x -> STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ TVar m [a] -> ([a] -> [a]) -> STM m ()
forall a. TVar m a -> (a -> a) -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
TVar m a -> (a -> a) -> STM m ()
modifyTVar TVar m [a]
tvar ([a] -> [a] -> [a]
forall a. Semigroup a => a -> a -> a
<> [a
x])
      , $sel:loadAll:PersistenceIncremental :: FromJSON a => m [a]
loadAll = TVar m [a] -> m [a]
forall a. TVar m a -> m a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> m a
readTVarIO TVar m [a]
tvar
      }

isReqSn :: Message tx -> Bool
isReqSn :: forall tx. Message tx -> Bool
isReqSn = \case
  ReqSn{} -> Bool
True
  Message tx
_ -> Bool
False

inputsToOpenHead :: [Input SimpleTx]
inputsToOpenHead :: [Input SimpleTx]
inputsToOpenHead =
  [ OnChainTx SimpleTx -> Input SimpleTx
observationInput (OnChainTx SimpleTx -> Input SimpleTx)
-> OnChainTx SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ HeadId
-> HeadSeed -> HeadParameters -> [OnChainId] -> OnChainTx SimpleTx
forall tx.
HeadId -> HeadSeed -> HeadParameters -> [OnChainId] -> OnChainTx tx
OnInitTx HeadId
testHeadId HeadSeed
testHeadSeed HeadParameters
headParameters [OnChainId]
participants
  , OnChainTx SimpleTx -> Input SimpleTx
observationInput (OnChainTx SimpleTx -> Input SimpleTx)
-> OnChainTx SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ HeadId -> Party -> UTxOType SimpleTx -> OnChainTx SimpleTx
forall tx. HeadId -> Party -> UTxOType tx -> OnChainTx tx
OnCommitTx HeadId
testHeadId Party
carol (SimpleId -> UTxOType SimpleTx
utxoRef SimpleId
3)
  , OnChainTx SimpleTx -> Input SimpleTx
observationInput (OnChainTx SimpleTx -> Input SimpleTx)
-> OnChainTx SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ HeadId -> Party -> UTxOType SimpleTx -> OnChainTx SimpleTx
forall tx. HeadId -> Party -> UTxOType tx -> OnChainTx tx
OnCommitTx HeadId
testHeadId Party
bob (SimpleId -> UTxOType SimpleTx
utxoRef SimpleId
2)
  , OnChainTx SimpleTx -> Input SimpleTx
observationInput (OnChainTx SimpleTx -> Input SimpleTx)
-> OnChainTx SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ HeadId -> Party -> UTxOType SimpleTx -> OnChainTx SimpleTx
forall tx. HeadId -> Party -> UTxOType tx -> OnChainTx tx
OnCommitTx HeadId
testHeadId Party
alice (SimpleId -> UTxOType SimpleTx
utxoRef SimpleId
1)
  , OnChainTx SimpleTx -> Input SimpleTx
observationInput (OnChainTx SimpleTx -> Input SimpleTx)
-> OnChainTx SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ HeadId -> OnChainTx SimpleTx
forall tx. HeadId -> OnChainTx tx
OnCollectComTx HeadId
testHeadId
  ]
 where
  observationInput :: OnChainTx SimpleTx -> Input SimpleTx
  observationInput :: OnChainTx SimpleTx -> Input SimpleTx
observationInput OnChainTx SimpleTx
observedTx =
    ChainInput
      { $sel:chainEvent:ClientInput :: ChainEvent SimpleTx
chainEvent =
          Observation
            { OnChainTx SimpleTx
observedTx :: OnChainTx SimpleTx
$sel:observedTx:Observation :: OnChainTx SimpleTx
observedTx
            , $sel:newChainState:Observation :: ChainStateType SimpleTx
newChainState = SimpleChainState{$sel:slot:SimpleChainState :: ChainSlot
slot = Natural -> ChainSlot
ChainSlot Natural
0}
            }
      }

  parties :: [Party]
parties = [Party
alice, Party
bob, Party
carol]
  headParameters :: HeadParameters
headParameters = ContestationPeriod -> [Party] -> HeadParameters
HeadParameters ContestationPeriod
cperiod [Party]
parties
  participants :: [OnChainId]
participants = Party -> OnChainId
deriveOnChainId (Party -> OnChainId) -> [Party] -> [OnChainId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Party]
parties

runToCompletion ::
  IsChainState tx =>
  HydraNode tx IO ->
  IO ()
runToCompletion :: forall tx. IsChainState tx => HydraNode tx IO -> IO ()
runToCompletion node :: HydraNode tx IO
node@HydraNode{$sel:inputQueue:HydraNode :: forall tx (m :: * -> *). HydraNode tx m -> InputQueue m (Input tx)
inputQueue = InputQueue{IO Bool
isEmpty :: IO Bool
$sel:isEmpty:InputQueue :: forall (m :: * -> *) e. InputQueue m e -> m Bool
isEmpty}} = IO ()
go
 where
  go :: IO ()
go =
    IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM IO Bool
isEmpty (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      HydraNode tx IO -> IO ()
forall (m :: * -> *) tx.
(MonadCatch m, MonadAsync m, IsChainState tx) =>
HydraNode tx m -> m ()
stepHydraNode HydraNode tx IO
node IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
go

-- | Creates a full 'HydraNode' with given parameters and primed 'Input's. Note
-- that this node is 'notConnect'ed to any components.
testHydraNode ::
  (MonadDelay m, MonadAsync m, MonadLabelledSTM m, MonadThrow m) =>
  Tracer m (HydraNodeLog SimpleTx) ->
  SigningKey HydraKey ->
  [Party] ->
  ContestationPeriod ->
  [Input SimpleTx] ->
  m (HydraNode SimpleTx m)
testHydraNode :: forall (m :: * -> *).
(MonadDelay m, MonadAsync m, MonadLabelledSTM m, MonadThrow m) =>
Tracer m (HydraNodeLog SimpleTx)
-> SigningKey HydraKey
-> [Party]
-> ContestationPeriod
-> [Input SimpleTx]
-> m (HydraNode SimpleTx m)
testHydraNode Tracer m (HydraNodeLog SimpleTx)
tracer SigningKey HydraKey
signingKey [Party]
otherParties ContestationPeriod
contestationPeriod [Input SimpleTx]
inputs = do
  Tracer m (HydraNodeLog SimpleTx)
-> Environment
-> Ledger SimpleTx
-> ChainStateType SimpleTx
-> EventSource (StateEvent SimpleTx) m
-> [EventSink (StateEvent SimpleTx) m]
-> m (DraftHydraNode SimpleTx m)
forall (m :: * -> *) tx.
(MonadDelay m, MonadLabelledSTM m, MonadAsync m, MonadThrow m,
 IsChainState tx) =>
Tracer m (HydraNodeLog tx)
-> Environment
-> Ledger tx
-> ChainStateType tx
-> EventSource (StateEvent tx) m
-> [EventSink (StateEvent tx) m]
-> m (DraftHydraNode tx m)
hydrate Tracer m (HydraNodeLog SimpleTx)
tracer Environment
env Ledger SimpleTx
simpleLedger SimpleChainState{$sel:slot:SimpleChainState :: ChainSlot
slot = Natural -> ChainSlot
ChainSlot Natural
0} ([StateEvent SimpleTx] -> EventSource (StateEvent SimpleTx) m
forall (m :: * -> *) a. Monad m => [a] -> EventSource a m
mockSource []) []
    m (DraftHydraNode SimpleTx m)
-> (DraftHydraNode SimpleTx m -> m (HydraNode SimpleTx m))
-> m (HydraNode SimpleTx m)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= DraftHydraNode SimpleTx m -> m (HydraNode SimpleTx m)
forall (m :: * -> *).
MonadThrow m =>
DraftHydraNode SimpleTx m -> m (HydraNode SimpleTx m)
notConnect
    m (HydraNode SimpleTx m)
-> (HydraNode SimpleTx m -> m (HydraNode SimpleTx m))
-> m (HydraNode SimpleTx m)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Input SimpleTx]
-> HydraNode SimpleTx m -> m (HydraNode SimpleTx m)
forall (m :: * -> *).
Monad m =>
[Input SimpleTx]
-> HydraNode SimpleTx m -> m (HydraNode SimpleTx m)
primeWith [Input SimpleTx]
inputs
 where
  env :: Environment
env =
    Environment
      { Party
$sel:party:Environment :: Party
party :: Party
party
      , SigningKey HydraKey
$sel:signingKey:Environment :: SigningKey HydraKey
signingKey :: SigningKey HydraKey
signingKey
      , [Party]
$sel:otherParties:Environment :: [Party]
otherParties :: [Party]
otherParties
      , ContestationPeriod
$sel:contestationPeriod:Environment :: ContestationPeriod
contestationPeriod :: ContestationPeriod
contestationPeriod
      , [OnChainId]
$sel:participants:Environment :: [OnChainId]
participants :: [OnChainId]
participants
      }

  party :: Party
party = SigningKey HydraKey -> Party
deriveParty SigningKey HydraKey
signingKey

  -- NOTE: We use the hydra-keys as on-chain identities directly. This is fine
  -- as this is a simulated network.
  participants :: [OnChainId]
participants = Party -> OnChainId
deriveOnChainId (Party -> OnChainId) -> [Party] -> [OnChainId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Party
party Party -> [Party] -> [Party]
forall a. a -> [a] -> [a]
: [Party]
otherParties)

recordNetwork :: HydraNode tx IO -> IO (HydraNode tx IO, IO [Message tx])
recordNetwork :: forall tx. HydraNode tx IO -> IO (HydraNode tx IO, IO [Message tx])
recordNetwork HydraNode tx IO
node = do
  (Message tx -> IO ()
record, IO [Message tx]
query) <- IO (Message tx -> IO (), IO [Message tx])
forall msg. IO (msg -> IO (), IO [msg])
messageRecorder
  (HydraNode tx IO, IO [Message tx])
-> IO (HydraNode tx IO, IO [Message tx])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HydraNode tx IO
node{hn = Network{broadcast = record}}, IO [Message tx]
query)

recordServerOutputs :: HydraNode tx IO -> IO (HydraNode tx IO, IO [ServerOutput tx])
recordServerOutputs :: forall tx.
HydraNode tx IO -> IO (HydraNode tx IO, IO [ServerOutput tx])
recordServerOutputs HydraNode tx IO
node = do
  (ServerOutput tx -> IO ()
record, IO [ServerOutput tx]
query) <- IO (ServerOutput tx -> IO (), IO [ServerOutput tx])
forall msg. IO (msg -> IO (), IO [msg])
messageRecorder
  (HydraNode tx IO, IO [ServerOutput tx])
-> IO (HydraNode tx IO, IO [ServerOutput tx])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HydraNode tx IO
node{server = Server{sendOutput = record}}, IO [ServerOutput tx]
query)

messageRecorder :: IO (msg -> IO (), IO [msg])
messageRecorder :: forall msg. IO (msg -> IO (), IO [msg])
messageRecorder = do
  IORef [msg]
ref <- [msg] -> IO (IORef [msg])
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef []
  (msg -> IO (), IO [msg]) -> IO (msg -> IO (), IO [msg])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IORef [msg] -> msg -> IO ()
forall {m :: * -> *} {a}. MonadIO m => IORef [a] -> a -> m ()
appendMsg IORef [msg]
ref, IORef [msg] -> IO [msg]
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef [msg]
ref)
 where
  appendMsg :: IORef [a] -> a -> m ()
appendMsg IORef [a]
ref a
x = IORef [a] -> ([a] -> ([a], ())) -> m ()
forall (m :: * -> *) a b.
MonadIO m =>
IORef a -> (a -> (a, b)) -> m b
atomicModifyIORef' IORef [a]
ref (([a] -> ([a], ())) -> m ()) -> ([a] -> ([a], ())) -> m ()
forall a b. (a -> b) -> a -> b
$ \[a]
old -> ([a]
old [a] -> [a] -> [a]
forall a. Semigroup a => a -> a -> a
<> [a
x], ())

throwExceptionOnPostTx ::
  IsChainState tx =>
  PostTxError tx ->
  HydraNode tx IO ->
  IO (HydraNode tx IO)
throwExceptionOnPostTx :: forall tx.
IsChainState tx =>
PostTxError tx -> HydraNode tx IO -> IO (HydraNode tx IO)
throwExceptionOnPostTx PostTxError tx
exception HydraNode tx IO
node =
  HydraNode tx IO -> IO (HydraNode tx IO)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    HydraNode tx IO
node
      { oc =
          Chain
            { postTx = \PostChainTx tx
_ -> PostTxError tx -> IO ()
forall e a. Exception e => e -> IO a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO PostTxError tx
exception
            , draftCommitTx = \HeadId
_ -> Text -> CommitBlueprintTx tx -> IO (Either (PostTxError tx) tx)
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"draftCommitTx not implemented"
            , draftDepositTx = \HeadId
_ -> Text
-> CommitBlueprintTx tx
-> UTCTime
-> IO (Either (PostTxError tx) tx)
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"draftDepositTx not implemented"
            , submitTx = \tx
_ -> Text -> IO ()
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"submitTx not implemented"
            }
      }