{-# LANGUAGE DuplicateRecordFields #-}

module Hydra.NodeSpec where

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

import Conduit (MonadUnliftIO, yieldMany)
import Control.Concurrent.Class.MonadSTM (modifyTVar, newTVarIO, readTVarIO, writeTVar)
import Hydra.API.ClientInput (ClientInput (..))
import Hydra.API.Server (Server (..), mkTimedServerOutputFromStateEvent, updateSeenSnapshot)
import Hydra.API.ServerOutput (ClientMessage (..), ServerOutput (..), TimedServerOutput (..))
import Hydra.Cardano.Api (SigningKey)
import Hydra.Chain (Chain (..), ChainEvent (..), OnChainTx (..), PostTxError (..))
import Hydra.Chain.ChainState (IsChainState (..))
import Hydra.Events (EventSink (..), EventSource (..), getEventId, mkEventSink)
import Hydra.Events.Rotation (EventStore (..), LogId)
import Hydra.HeadLogic (Input (..), StateChanged (..), TTL)
import Hydra.HeadLogic.StateEvent (StateEvent (..))
import Hydra.HeadLogicSpec (inOpenState, receiveMessage, receiveMessageFrom, testSnapshot)
import Hydra.Ledger.Simple (SimpleTx (..), simpleLedger)
import Hydra.Logging (Tracer, showLogsOnFailure, traceInTVar)
import Hydra.Logging qualified as Logging
import Hydra.Network (Network (..))
import Hydra.Network.Message (Message (..), NetworkEvent (..))
import Hydra.Node (
  DraftHydraNode,
  HydraNode (..),
  HydraNodeLog (..),
  NodeStateHandler (..),
  checkHeadState,
  connect,
  hydrate,
  stepHydraNode,
 )
import Hydra.Node.Environment as Environment
import Hydra.Node.InputQueue (InputQueue (..))
import Hydra.Node.ParameterMismatch (ParameterMismatch (..))
import Hydra.Node.State (ChainPointTime (..), NodeState (..))
import Hydra.Node.UnsyncedPeriod (defaultUnsyncedPeriodFor)
import Hydra.Options (defaultContestationPeriod, defaultDepositActivation, defaultDepositPeriod, defaultUnsyncedPeriod)
import Hydra.Tx.ContestationPeriod (ContestationPeriod (..))
import Hydra.Tx.Crypto (HydraKey, sign)
import Hydra.Tx.HeadParameters (HeadParameters (..))
import Hydra.Tx.Party (Party, deriveParty)
import Test.Hydra.HeadLogic.Outcome (genStateChanged)
import Test.Hydra.HeadLogic.StateEvent (genStateEvent)
import Test.Hydra.Ledger.Simple (aValidTx, utxoRefs)
import Test.Hydra.Node.Fixture (testEnvironment)
import Test.Hydra.Tx.Fixture (
  alice,
  aliceSk,
  bob,
  bobSk,
  carol,
  carolSk,
  cperiod,
  deriveOnChainId,
  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 ::
        ( ( EventStore (StateEvent SimpleTx) IO ->
            [EventSink (StateEvent SimpleTx) IO] ->
            IO (DraftHydraNode SimpleTx IO)
          ) ->
          IO ()
        ) ->
        IO ()
      setupHydrate :: ((EventStore (StateEvent SimpleTx) IO
  -> [EventSink (StateEvent SimpleTx) IO]
  -> IO (DraftHydraNode SimpleTx IO))
 -> IO ())
-> IO ()
setupHydrate (EventStore (StateEvent SimpleTx) IO
 -> [EventSink (StateEvent SimpleTx) IO]
 -> IO (DraftHydraNode SimpleTx IO))
-> IO ()
action =
        Text -> (Tracer IO (HydraNodeLog SimpleTx) -> IO ()) -> IO ()
forall (m :: * -> *) msg a.
(MonadLabelledSTM 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 testHydrate :: EventStore (StateEvent SimpleTx) IO
-> [EventSink (StateEvent SimpleTx) IO]
-> IO (DraftHydraNode SimpleTx IO)
testHydrate = Tracer IO (HydraNodeLog SimpleTx)
-> Environment
-> Ledger SimpleTx
-> ChainStateType SimpleTx
-> EventStore (StateEvent SimpleTx) IO
-> [EventSink (StateEvent SimpleTx) IO]
-> IO (DraftHydraNode SimpleTx IO)
forall tx (m :: * -> *).
(IsChainState tx, MonadDelay m, MonadLabelledSTM m, MonadAsync m,
 MonadThrow m, MonadUnliftIO m) =>
Tracer m (HydraNodeLog tx)
-> Environment
-> Ledger tx
-> ChainStateType tx
-> EventStore (StateEvent tx) m
-> [EventSink (StateEvent tx) m]
-> m (DraftHydraNode tx m)
hydrate Tracer IO (HydraNodeLog SimpleTx)
tracer Environment
testEnvironment Ledger SimpleTx
simpleLedger ChainStateType SimpleTx
SimpleChainState
0
          (EventStore (StateEvent SimpleTx) IO
 -> [EventSink (StateEvent SimpleTx) IO]
 -> IO (DraftHydraNode SimpleTx IO))
-> IO ()
action EventStore (StateEvent SimpleTx) IO
-> [EventSink (StateEvent SimpleTx) IO]
-> IO (DraftHydraNode SimpleTx IO)
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
    (((EventStore (StateEvent SimpleTx) IO
   -> [EventSink (StateEvent SimpleTx) IO]
   -> IO (DraftHydraNode SimpleTx IO))
  -> IO ())
 -> IO ())
-> SpecWith
     (EventStore (StateEvent SimpleTx) IO
      -> [EventSink (StateEvent SimpleTx) IO]
      -> IO (DraftHydraNode SimpleTx IO))
-> Spec
forall a. (ActionWith a -> IO ()) -> SpecWith a -> Spec
around ((EventStore (StateEvent SimpleTx) IO
  -> [EventSink (StateEvent SimpleTx) IO]
  -> IO (DraftHydraNode SimpleTx IO))
 -> IO ())
-> IO ()
setupHydrate (SpecWith
   (EventStore (StateEvent SimpleTx) IO
    -> [EventSink (StateEvent SimpleTx) IO]
    -> IO (DraftHydraNode SimpleTx IO))
 -> Spec)
-> SpecWith
     (EventStore (StateEvent SimpleTx) IO
      -> [EventSink (StateEvent SimpleTx) IO]
      -> IO (DraftHydraNode SimpleTx IO))
-> Spec
forall a b. (a -> b) -> a -> b
$ do
      String
-> ((EventStore (StateEvent SimpleTx) IO
     -> [EventSink (StateEvent SimpleTx) IO]
     -> IO (DraftHydraNode SimpleTx IO))
    -> Property)
-> SpecWith
     (Arg
        ((EventStore (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" (((EventStore (StateEvent SimpleTx) IO
   -> [EventSink (StateEvent SimpleTx) IO]
   -> IO (DraftHydraNode SimpleTx IO))
  -> Property)
 -> SpecWith
      (Arg
         ((EventStore (StateEvent SimpleTx) IO
           -> [EventSink (StateEvent SimpleTx) IO]
           -> IO (DraftHydraNode SimpleTx IO))
          -> Property)))
-> ((EventStore (StateEvent SimpleTx) IO
     -> [EventSink (StateEvent SimpleTx) IO]
     -> IO (DraftHydraNode SimpleTx IO))
    -> Property)
-> SpecWith
     (Arg
        ((EventStore (StateEvent SimpleTx) IO
          -> [EventSink (StateEvent SimpleTx) IO]
          -> IO (DraftHydraNode SimpleTx IO))
         -> Property))
forall a b. (a -> b) -> a -> b
$ \EventStore (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, Arbitrary (ChainPointType tx),
 Arbitrary (ChainStateType 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
$ EventStore (StateEvent SimpleTx) IO
-> [EventSink (StateEvent SimpleTx) IO]
-> IO (DraftHydraNode SimpleTx IO)
testHydrate ([StateEvent SimpleTx] -> EventStore (StateEvent SimpleTx) IO
forall a (m :: * -> *). Monad m => [a] -> EventStore a m
mockEventStore [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
-> ((EventStore (StateEvent SimpleTx) IO
     -> [EventSink (StateEvent SimpleTx) IO]
     -> IO (DraftHydraNode SimpleTx IO))
    -> Property)
-> SpecWith
     (Arg
        ((EventStore (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" (((EventStore (StateEvent SimpleTx) IO
   -> [EventSink (StateEvent SimpleTx) IO]
   -> IO (DraftHydraNode SimpleTx IO))
  -> Property)
 -> SpecWith
      (Arg
         ((EventStore (StateEvent SimpleTx) IO
           -> [EventSink (StateEvent SimpleTx) IO]
           -> IO (DraftHydraNode SimpleTx IO))
          -> Property)))
-> ((EventStore (StateEvent SimpleTx) IO
     -> [EventSink (StateEvent SimpleTx) IO]
     -> IO (DraftHydraNode SimpleTx IO))
    -> Property)
-> SpecWith
     (Arg
        ((EventStore (StateEvent SimpleTx) IO
          -> [EventSink (StateEvent SimpleTx) IO]
          -> IO (DraftHydraNode SimpleTx IO))
         -> Property))
forall a b. (a -> b) -> a -> b
$ \EventStore (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, Arbitrary (ChainPointType tx),
 Arbitrary (ChainStateType 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
$ EventStore (StateEvent SimpleTx) IO
-> [EventSink (StateEvent SimpleTx) IO]
-> IO (DraftHydraNode SimpleTx IO)
testHydrate ([StateEvent SimpleTx] -> EventStore (StateEvent SimpleTx) IO
forall a (m :: * -> *). Monad m => [a] -> EventStore a m
mockEventStore [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
-> ((EventStore (StateEvent SimpleTx) IO
     -> [EventSink (StateEvent SimpleTx) IO]
     -> IO (DraftHydraNode SimpleTx IO))
    -> Property)
-> SpecWith
     (Arg
        ((EventStore (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" (((EventStore (StateEvent SimpleTx) IO
   -> [EventSink (StateEvent SimpleTx) IO]
   -> IO (DraftHydraNode SimpleTx IO))
  -> Property)
 -> SpecWith
      (Arg
         ((EventStore (StateEvent SimpleTx) IO
           -> [EventSink (StateEvent SimpleTx) IO]
           -> IO (DraftHydraNode SimpleTx IO))
          -> Property)))
-> ((EventStore (StateEvent SimpleTx) IO
     -> [EventSink (StateEvent SimpleTx) IO]
     -> IO (DraftHydraNode SimpleTx IO))
    -> Property)
-> SpecWith
     (Arg
        ((EventStore (StateEvent SimpleTx) IO
          -> [EventSink (StateEvent SimpleTx) IO]
          -> IO (DraftHydraNode SimpleTx IO))
         -> Property))
forall a b. (a -> b) -> a -> b
$ \EventStore (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, Arbitrary (ChainPointType tx),
 Arbitrary (ChainStateType 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 :: 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
failingSink]
                failingSink :: EventSink (StateEvent SimpleTx) IO
                failingSink :: EventSink (StateEvent SimpleTx) IO
failingSink =
                  (HasEventId (StateEvent SimpleTx) => StateEvent SimpleTx -> IO ())
-> EventSink (StateEvent SimpleTx) IO
forall (m :: * -> *) e.
Monad m =>
(HasEventId e => e -> m ()) -> EventSink e m
mkEventSink (\StateEvent SimpleTx
_ -> String -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure String
"failing putEvent 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 ->
              EventStore (StateEvent SimpleTx) IO
-> [EventSink (StateEvent SimpleTx) IO]
-> IO (DraftHydraNode SimpleTx IO)
testHydrate ([StateEvent SimpleTx] -> EventStore (StateEvent SimpleTx) IO
forall a (m :: * -> *). Monad m => [a] -> EventStore a m
mockEventStore [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
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
-> ((EventStore (StateEvent SimpleTx) IO
     -> [EventSink (StateEvent SimpleTx) IO]
     -> IO (DraftHydraNode SimpleTx IO))
    -> Property)
-> SpecWith
     (Arg
        ((EventStore (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" (((EventStore (StateEvent SimpleTx) IO
   -> [EventSink (StateEvent SimpleTx) IO]
   -> IO (DraftHydraNode SimpleTx IO))
  -> Property)
 -> SpecWith
      (Arg
         ((EventStore (StateEvent SimpleTx) IO
           -> [EventSink (StateEvent SimpleTx) IO]
           -> IO (DraftHydraNode SimpleTx IO))
          -> Property)))
-> ((EventStore (StateEvent SimpleTx) IO
     -> [EventSink (StateEvent SimpleTx) IO]
     -> IO (DraftHydraNode SimpleTx IO))
    -> Property)
-> SpecWith
     (Arg
        ((EventStore (StateEvent SimpleTx) IO
          -> [EventSink (StateEvent SimpleTx) IO]
          -> IO (DraftHydraNode SimpleTx IO))
         -> Property))
forall a b. (a -> b) -> a -> b
$ \EventStore (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 ->
          Gen UTCTime
-> (UTCTime -> [UTCTime]) -> (UTCTime -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> [a]) -> (a -> prop) -> Property
forAllShrink Gen UTCTime
forall a. Arbitrary a => Gen a
arbitrary UTCTime -> [UTCTime]
forall a. Arbitrary a => a -> [a]
shrink ((UTCTime -> Property) -> Property)
-> (UTCTime -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \UTCTime
now ->
            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 'HeadOpened' results in
                -- a head state that gets checked by 'checkHeadState'
                let genEvent :: Gen (StateEvent SimpleTx)
genEvent = do
                      EventId -> StateChanged SimpleTx -> UTCTime -> StateEvent SimpleTx
forall tx. EventId -> StateChanged tx -> UTCTime -> StateEvent tx
StateEvent
                        (EventId
 -> StateChanged SimpleTx -> UTCTime -> StateEvent SimpleTx)
-> Gen EventId
-> Gen (StateChanged SimpleTx -> UTCTime -> 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 -> UTCTime -> StateEvent SimpleTx)
-> Gen (StateChanged SimpleTx)
-> Gen (UTCTime -> 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
-> [Party]
-> StateChanged SimpleTx
forall tx.
HeadParameters
-> ChainStateType tx
-> HeadId
-> HeadSeed
-> [Party]
-> StateChanged tx
HeadOpened (Environment -> HeadParameters
mkHeadParameters Environment
env) (SimpleChainState
 -> HeadId -> HeadSeed -> [Party] -> StateChanged SimpleTx)
-> Gen SimpleChainState
-> Gen (HeadId -> HeadSeed -> [Party] -> 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 -> [Party] -> StateChanged SimpleTx)
-> Gen HeadId -> Gen (HeadSeed -> [Party] -> 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 -> [Party] -> StateChanged SimpleTx)
-> Gen HeadSeed -> Gen ([Party] -> 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 ([Party] -> StateChanged SimpleTx)
-> Gen [Party] -> 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 [Party]
forall a. Arbitrary a => Gen a
arbitrary)
                        Gen (UTCTime -> StateEvent SimpleTx)
-> Gen UTCTime -> 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
<*> UTCTime -> Gen UTCTime
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure UTCTime
now
                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 ->
                  EventStore (StateEvent SimpleTx) IO
-> [EventSink (StateEvent SimpleTx) IO]
-> IO (DraftHydraNode SimpleTx IO)
testHydrate ([StateEvent SimpleTx] -> EventStore (StateEvent SimpleTx) IO
forall a (m :: * -> *). Monad m => [a] -> EventStore a m
mockEventStore [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
    (((EventStore (StateEvent SimpleTx) IO
   -> [EventSink (StateEvent SimpleTx) IO]
   -> IO (DraftHydraNode SimpleTx IO))
  -> IO ())
 -> IO ())
-> SpecWith
     (EventStore (StateEvent SimpleTx) IO
      -> [EventSink (StateEvent SimpleTx) IO]
      -> IO (DraftHydraNode SimpleTx IO))
-> Spec
forall a. (ActionWith a -> IO ()) -> SpecWith a -> Spec
around ((EventStore (StateEvent SimpleTx) IO
  -> [EventSink (StateEvent SimpleTx) IO]
  -> IO (DraftHydraNode SimpleTx IO))
 -> IO ())
-> IO ()
setupHydrate (SpecWith
   (EventStore (StateEvent SimpleTx) IO
    -> [EventSink (StateEvent SimpleTx) IO]
    -> IO (DraftHydraNode SimpleTx IO))
 -> Spec)
-> SpecWith
     (EventStore (StateEvent SimpleTx) IO
      -> [EventSink (StateEvent SimpleTx) IO]
      -> IO (DraftHydraNode SimpleTx IO))
-> Spec
forall a b. (a -> b) -> a -> b
$ do
      String
-> ((EventStore (StateEvent SimpleTx) IO
     -> [EventSink (StateEvent SimpleTx) IO]
     -> IO (DraftHydraNode SimpleTx IO))
    -> IO ())
-> SpecWith
     (Arg
        ((EventStore (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" (((EventStore (StateEvent SimpleTx) IO
   -> [EventSink (StateEvent SimpleTx) IO]
   -> IO (DraftHydraNode SimpleTx IO))
  -> IO ())
 -> SpecWith
      (Arg
         ((EventStore (StateEvent SimpleTx) IO
           -> [EventSink (StateEvent SimpleTx) IO]
           -> IO (DraftHydraNode SimpleTx IO))
          -> IO ())))
-> ((EventStore (StateEvent SimpleTx) IO
     -> [EventSink (StateEvent SimpleTx) IO]
     -> IO (DraftHydraNode SimpleTx IO))
    -> IO ())
-> SpecWith
     (Arg
        ((EventStore (StateEvent SimpleTx) IO
          -> [EventSink (StateEvent SimpleTx) IO]
          -> IO (DraftHydraNode SimpleTx IO))
         -> IO ()))
forall a b. (a -> b) -> a -> b
$ \EventStore (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

        EventStore (StateEvent SimpleTx) IO
-> [EventSink (StateEvent SimpleTx) IO]
-> IO (DraftHydraNode SimpleTx IO)
testHydrate ([StateEvent SimpleTx] -> EventStore (StateEvent SimpleTx) IO
forall a (m :: * -> *). Monad m => [a] -> EventStore a m
mockEventStore []) [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 :: * -> *) tx.
MonadThrow m =>
DraftHydraNode tx m -> m (HydraNode tx 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 :: * -> *) tx.
MonadSTM m =>
[Input tx] -> HydraNode tx m -> m (HydraNode tx 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
-> ((EventStore (StateEvent SimpleTx) IO
     -> [EventSink (StateEvent SimpleTx) IO]
     -> IO (DraftHydraNode SimpleTx IO))
    -> Property)
-> SpecWith
     (Arg
        ((EventStore (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" (((EventStore (StateEvent SimpleTx) IO
   -> [EventSink (StateEvent SimpleTx) IO]
   -> IO (DraftHydraNode SimpleTx IO))
  -> Property)
 -> SpecWith
      (Arg
         ((EventStore (StateEvent SimpleTx) IO
           -> [EventSink (StateEvent SimpleTx) IO]
           -> IO (DraftHydraNode SimpleTx IO))
          -> Property)))
-> ((EventStore (StateEvent SimpleTx) IO
     -> [EventSink (StateEvent SimpleTx) IO]
     -> IO (DraftHydraNode SimpleTx IO))
    -> Property)
-> SpecWith
     (Arg
        ((EventStore (StateEvent SimpleTx) IO
          -> [EventSink (StateEvent SimpleTx) IO]
          -> IO (DraftHydraNode SimpleTx IO))
         -> Property))
forall a b. (a -> b) -> a -> b
$ \EventStore (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
            EventStore (StateEvent SimpleTx) IO
-> [EventSink (StateEvent SimpleTx) IO]
-> IO (DraftHydraNode SimpleTx IO)
testHydrate ([StateEvent SimpleTx] -> EventStore (StateEvent SimpleTx) IO
forall a (m :: * -> *). Monad m => [a] -> EventStore a m
mockEventStore []) [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 :: * -> *) tx.
MonadThrow m =>
DraftHydraNode tx m -> m (HydraNode tx 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 :: * -> *) tx.
MonadSTM m =>
[Input tx] -> HydraNode tx m -> m (HydraNode tx 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
-> ((EventStore (StateEvent SimpleTx) IO
     -> [EventSink (StateEvent SimpleTx) IO]
     -> IO (DraftHydraNode SimpleTx IO))
    -> IO ())
-> SpecWith
     (Arg
        ((EventStore (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" (((EventStore (StateEvent SimpleTx) IO
   -> [EventSink (StateEvent SimpleTx) IO]
   -> IO (DraftHydraNode SimpleTx IO))
  -> IO ())
 -> SpecWith
      (Arg
         ((EventStore (StateEvent SimpleTx) IO
           -> [EventSink (StateEvent SimpleTx) IO]
           -> IO (DraftHydraNode SimpleTx IO))
          -> IO ())))
-> ((EventStore (StateEvent SimpleTx) IO
     -> [EventSink (StateEvent SimpleTx) IO]
     -> IO (DraftHydraNode SimpleTx IO))
    -> IO ())
-> SpecWith
     (Arg
        ((EventStore (StateEvent SimpleTx) IO
          -> [EventSink (StateEvent SimpleTx) IO]
          -> IO (DraftHydraNode SimpleTx IO))
         -> IO ()))
forall a b. (a -> b) -> a -> b
$ \EventStore (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
10 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          EventStore (StateEvent SimpleTx) IO
eventStore <- IO (EventStore (StateEvent SimpleTx) IO)
forall (m :: * -> *) a. MonadLabelledSTM m => m (EventStore a m)
createMockEventStore

          EventStore (StateEvent SimpleTx) IO
-> [EventSink (StateEvent SimpleTx) IO]
-> IO (DraftHydraNode SimpleTx IO)
testHydrate EventStore (StateEvent SimpleTx) IO
eventStore []
            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 :: * -> *) tx.
MonadThrow m =>
DraftHydraNode tx m -> m (HydraNode tx 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
>>= HydraNode SimpleTx IO -> IO (HydraNode SimpleTx IO)
forall (m :: * -> *).
MonadSTM m =>
HydraNode SimpleTx m -> m (HydraNode SimpleTx m)
primeWithTime
            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 :: * -> *) tx.
MonadSTM m =>
[Input tx] -> HydraNode tx m -> m (HydraNode tx 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

          (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 [Either (ServerOutput SimpleTx) (ClientMessage SimpleTx)]
getServerOutputs) <-
            EventStore (StateEvent SimpleTx) IO
-> [EventSink (StateEvent SimpleTx) IO]
-> IO (DraftHydraNode SimpleTx IO)
testHydrate EventStore (StateEvent SimpleTx) IO
eventStore [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 :: * -> *) tx.
MonadThrow m =>
DraftHydraNode tx m -> m (HydraNode tx 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 :: * -> *) tx.
MonadSTM m =>
[Input tx] -> HydraNode tx m -> m (HydraNode tx m)
primeWith [Message SimpleTx -> Input SimpleTx
forall tx. Message tx -> Input tx
receiveMessage ReqTx{$sel:transaction:ReqTx :: SimpleTx
transaction = SimpleId -> SimpleTx
aValidTx SimpleId
1}]
              IO (HydraNode SimpleTx IO)
-> (HydraNode SimpleTx IO
    -> IO
         (HydraNode SimpleTx IO,
          IO [Either (ServerOutput SimpleTx) (ClientMessage SimpleTx)]))
-> IO
     (HydraNode SimpleTx IO,
      IO [Either (ServerOutput SimpleTx) (ClientMessage 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 [Either (ServerOutput SimpleTx) (ClientMessage SimpleTx)])
forall tx.
IsChainState tx =>
HydraNode tx IO
-> IO
     (HydraNode tx IO, IO [Either (ServerOutput tx) (ClientMessage tx)])
recordServerOutputs
          HydraNode SimpleTx IO -> IO ()
forall tx. IsChainState tx => HydraNode tx IO -> IO ()
runToCompletion HydraNode SimpleTx IO
node

          IO [Either (ServerOutput SimpleTx) (ClientMessage SimpleTx)]
getServerOutputs IO [Either (ServerOutput SimpleTx) (ClientMessage SimpleTx)]
-> ([Either (ServerOutput SimpleTx) (ClientMessage 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
>>= ([Either (ServerOutput SimpleTx) (ClientMessage SimpleTx)]
-> [Either (ServerOutput SimpleTx) (ClientMessage SimpleTx)]
-> IO ()
forall a. (HasCallStack, Show a, Eq a) => [a] -> [a] -> IO ()
`shouldContain` [ServerOutput SimpleTx
-> Either (ServerOutput SimpleTx) (ClientMessage SimpleTx)
forall a b. a -> Either a b
Left TxValid{$sel:headId:NetworkConnected :: HeadId
headId = HeadId
testHeadId, $sel:transactionId:NetworkConnected :: 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.
(MonadLabelledSTM 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 alice is the (initial) snapshot leader
        let 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 = SimpleId -> SimpleTx
aValidTx SimpleId
1}
                   , Message SimpleTx -> Input SimpleTx
forall tx. Message tx -> Input tx
receiveMessage ReqTx{$sel:transaction:ReqTx :: SimpleTx
transaction = SimpleId -> SimpleTx
aValidTx SimpleId
2}
                   , Message SimpleTx -> Input SimpleTx
forall tx. Message tx -> Input tx
receiveMessage ReqTx{$sel:transaction:ReqTx :: SimpleTx
transaction = SimpleId -> SimpleTx
aValidTx SimpleId
3}
                   ]
        (HydraNode SimpleTx IO
node, IO [Message SimpleTx]
getNetworkEvents) <-
          Tracer IO (HydraNodeLog SimpleTx)
-> Secret (SigningKey HydraKey)
-> [Party]
-> ContestationPeriod
-> [Input SimpleTx]
-> IO (HydraNode SimpleTx IO)
forall (m :: * -> *).
(MonadTime m, MonadDelay m, MonadAsync m, MonadLabelledSTM m,
 MonadThrow m, MonadUnliftIO m) =>
Tracer m (HydraNodeLog SimpleTx)
-> Secret (SigningKey HydraKey)
-> [Party]
-> ContestationPeriod
-> [Input SimpleTx]
-> m (HydraNode SimpleTx m)
testHydraNode Tracer IO (HydraNodeLog SimpleTx)
tracer Secret (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 (TxIdType SimpleTx)
-> Message SimpleTx
forall tx.
SnapshotVersion
-> SnapshotNumber
-> [TxIdType tx]
-> Maybe tx
-> Maybe (TxIdType tx)
-> Message tx
ReqSn SnapshotVersion
0 SnapshotNumber
1 [SimpleId
TxIdType SimpleTx
1] Maybe SimpleTx
forall a. Maybe a
Nothing Maybe SimpleId
Maybe (TxIdType SimpleTx)
forall a. Maybe a
Nothing]

    String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"parks network inputs received while catching up instead of looping forever" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$
      -- Regression test: while a node is still catching up, network inputs are
      -- rejected with 'WaitOnNodeInSync'. They must be held until the node is
      -- in sync rather than re-enqueued in a tight loop forever (which hung the
      -- node, and timed out CI after 6h). We deliberately omit 'primeWithTime'
      -- so the node stays in 'NodeCatchingUp'.
      NominalDiffTime -> IO () -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTimer m, MonadThrow m) =>
NominalDiffTime -> m a -> m a
failAfter NominalDiffTime
10 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        Text -> (Tracer IO (HydraNodeLog SimpleTx) -> IO ()) -> IO ()
forall (m :: * -> *) msg a.
(MonadLabelledSTM 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
          HydraNode SimpleTx IO
node <-
            Tracer IO (HydraNodeLog SimpleTx)
-> Environment
-> Ledger SimpleTx
-> ChainStateType SimpleTx
-> EventStore (StateEvent SimpleTx) IO
-> [EventSink (StateEvent SimpleTx) IO]
-> IO (DraftHydraNode SimpleTx IO)
forall tx (m :: * -> *).
(IsChainState tx, MonadDelay m, MonadLabelledSTM m, MonadAsync m,
 MonadThrow m, MonadUnliftIO m) =>
Tracer m (HydraNodeLog tx)
-> Environment
-> Ledger tx
-> ChainStateType tx
-> EventStore (StateEvent tx) m
-> [EventSink (StateEvent tx) m]
-> m (DraftHydraNode tx m)
hydrate Tracer IO (HydraNodeLog SimpleTx)
tracer Environment
testEnvironment Ledger SimpleTx
simpleLedger ChainStateType SimpleTx
SimpleChainState
0 ([StateEvent SimpleTx] -> EventStore (StateEvent SimpleTx) IO
forall a (m :: * -> *). Monad m => [a] -> EventStore a m
mockEventStore []) []
              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 :: * -> *) tx.
MonadThrow m =>
DraftHydraNode tx m -> m (HydraNode tx 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 :: * -> *) tx.
MonadSTM m =>
[Input tx] -> HydraNode tx m -> m (HydraNode tx m)
primeWith [Message SimpleTx -> Input SimpleTx
forall tx. Message tx -> Input tx
receiveMessage ReqTx{$sel:transaction:ReqTx :: SimpleTx
transaction = SimpleId -> SimpleTx
aValidTx SimpleId
1}]
          HydraNode SimpleTx IO -> IO ()
forall tx. IsChainState tx => HydraNode tx IO -> IO ()
runToCompletion HydraNode SimpleTx IO
node

    String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"rejects client inputs received while catching up" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$
      -- Omitting 'primeWithTime' leaves the node in 'NodeCatchingUp'.
      NominalDiffTime -> IO () -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTimer m, MonadThrow m) =>
NominalDiffTime -> m a -> m a
failAfter NominalDiffTime
5 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        Text -> (Tracer IO (HydraNodeLog SimpleTx) -> IO ()) -> IO ()
forall (m :: * -> *) msg a.
(MonadLabelledSTM 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
          (HydraNode SimpleTx IO
node, IO [Either (ServerOutput SimpleTx) (ClientMessage SimpleTx)]
getServerOutputs) <-
            Tracer IO (HydraNodeLog SimpleTx)
-> Environment
-> Ledger SimpleTx
-> ChainStateType SimpleTx
-> EventStore (StateEvent SimpleTx) IO
-> [EventSink (StateEvent SimpleTx) IO]
-> IO (DraftHydraNode SimpleTx IO)
forall tx (m :: * -> *).
(IsChainState tx, MonadDelay m, MonadLabelledSTM m, MonadAsync m,
 MonadThrow m, MonadUnliftIO m) =>
Tracer m (HydraNodeLog tx)
-> Environment
-> Ledger tx
-> ChainStateType tx
-> EventStore (StateEvent tx) m
-> [EventSink (StateEvent tx) m]
-> m (DraftHydraNode tx m)
hydrate Tracer IO (HydraNodeLog SimpleTx)
tracer Environment
testEnvironment Ledger SimpleTx
simpleLedger ChainStateType SimpleTx
SimpleChainState
0 ([StateEvent SimpleTx] -> EventStore (StateEvent SimpleTx) IO
forall a (m :: * -> *). Monad m => [a] -> EventStore a m
mockEventStore []) []
              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 :: * -> *) tx.
MonadThrow m =>
DraftHydraNode tx m -> m (HydraNode tx 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 :: * -> *) tx.
MonadSTM m =>
[Input tx] -> HydraNode tx m -> m (HydraNode tx m)
primeWith [ClientInput SimpleTx -> Input SimpleTx
forall tx. ClientInput tx -> Input tx
ClientInput ClientInput SimpleTx
forall tx. ClientInput tx
Init]
              IO (HydraNode SimpleTx IO)
-> (HydraNode SimpleTx IO
    -> IO
         (HydraNode SimpleTx IO,
          IO [Either (ServerOutput SimpleTx) (ClientMessage SimpleTx)]))
-> IO
     (HydraNode SimpleTx IO,
      IO [Either (ServerOutput SimpleTx) (ClientMessage 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 [Either (ServerOutput SimpleTx) (ClientMessage SimpleTx)])
forall tx.
IsChainState tx =>
HydraNode tx IO
-> IO
     (HydraNode tx IO, IO [Either (ServerOutput tx) (ClientMessage tx)])
recordServerOutputs
          HydraNode SimpleTx IO -> IO ()
forall tx. IsChainState tx => HydraNode tx IO -> IO ()
runToCompletion HydraNode SimpleTx IO
node
          [Either (ServerOutput SimpleTx) (ClientMessage SimpleTx)]
outputs <- IO [Either (ServerOutput SimpleTx) (ClientMessage SimpleTx)]
getServerOutputs
          [Either (ServerOutput SimpleTx) (ClientMessage SimpleTx)]
outputs
            [Either (ServerOutput SimpleTx) (ClientMessage SimpleTx)]
-> ([Either (ServerOutput SimpleTx) (ClientMessage SimpleTx)]
    -> Bool)
-> IO ()
forall a. (HasCallStack, Show a) => a -> (a -> Bool) -> IO ()
`shouldSatisfy` (Either (ServerOutput SimpleTx) (ClientMessage SimpleTx) -> Bool)
-> [Either (ServerOutput SimpleTx) (ClientMessage SimpleTx)]
-> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any
              ( \case
                  Right RejectedInputBecauseUnsynced{} -> Bool
True
                  Either (ServerOutput SimpleTx) (ClientMessage SimpleTx)
_ -> Bool
False
              )

    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
$ NominalDiffTime -> IO () -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTimer m, MonadThrow m) =>
NominalDiffTime -> m a -> m a
failAfter NominalDiffTime
5 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      Text -> (Tracer IO (HydraNodeLog SimpleTx) -> IO ()) -> IO ()
forall (m :: * -> *) msg a.
(MonadLabelledSTM 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 = Set SimpleTxOut
UTxOType SimpleTx
forall a. Monoid a => a
mempty, $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.
IsTx tx =>
SnapshotNumber
-> SnapshotVersion -> [tx] -> UTxOType tx -> Snapshot tx
testSnapshot SnapshotNumber
1 SnapshotVersion
0 [] ([SimpleId] -> UTxOType SimpleTx
utxoRefs [])
            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:depositTxId:ReqTx :: Maybe (TxIdType SimpleTx)
depositTxId = Maybe SimpleId
Maybe (TxIdType 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 (Secret (SigningKey HydraKey)
-> Snapshot SimpleTx -> Signature (Snapshot SimpleTx)
forall a.
SignableRepresentation a =>
Secret (SigningKey HydraKey) -> a -> Signature a
sign Secret (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 (Secret (SigningKey HydraKey)
-> Snapshot SimpleTx -> Signature (Snapshot SimpleTx)
forall a.
SignableRepresentation a =>
Secret (SigningKey HydraKey) -> a -> Signature a
sign Secret (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 (Secret (SigningKey HydraKey)
-> Snapshot SimpleTx -> Signature (Snapshot SimpleTx)
forall a.
SignableRepresentation a =>
Secret (SigningKey HydraKey) -> a -> Signature a
sign Secret (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)
-> Secret (SigningKey HydraKey)
-> [Party]
-> ContestationPeriod
-> [Input SimpleTx]
-> IO (HydraNode SimpleTx IO)
forall (m :: * -> *).
(MonadTime m, MonadDelay m, MonadAsync m, MonadLabelledSTM m,
 MonadThrow m, MonadUnliftIO m) =>
Tracer m (HydraNodeLog SimpleTx)
-> Secret (SigningKey HydraKey)
-> [Party]
-> ContestationPeriod
-> [Input SimpleTx]
-> m (HydraNode SimpleTx m)
testHydraNode Tracer IO (HydraNodeLog SimpleTx)
tracer Secret (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 (Secret (SigningKey HydraKey)
-> Snapshot SimpleTx -> Signature (Snapshot SimpleTx)
forall a.
SignableRepresentation a =>
Secret (SigningKey HydraKey) -> a -> Signature a
sign Secret (SigningKey HydraKey)
bobSk Snapshot SimpleTx
sn1) SnapshotNumber
1, SnapshotVersion
-> SnapshotNumber
-> [TxIdType SimpleTx]
-> Maybe SimpleTx
-> Maybe (TxIdType SimpleTx)
-> Message SimpleTx
forall tx.
SnapshotVersion
-> SnapshotNumber
-> [TxIdType tx]
-> Maybe tx
-> Maybe (TxIdType tx)
-> Message tx
ReqSn SnapshotVersion
0 SnapshotNumber
2 [SimpleId
TxIdType SimpleTx
1] Maybe SimpleTx
forall a. Maybe a
Nothing Maybe SimpleId
Maybe (TxIdType 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
$ NominalDiffTime -> IO () -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTimer m, MonadThrow m) =>
NominalDiffTime -> m a -> m a
failAfter NominalDiffTime
5 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      Text -> (Tracer IO (HydraNodeLog SimpleTx) -> IO ()) -> IO ()
forall (m :: * -> *) msg a.
(MonadLabelledSTM 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.
IsTx tx =>
SnapshotNumber
-> SnapshotVersion -> [tx] -> UTxOType tx -> Snapshot tx
testSnapshot SnapshotNumber
1 SnapshotVersion
0 [] UTxOType SimpleTx
forall a. Monoid a => a
mempty
            sigBob :: Signature (Snapshot SimpleTx)
sigBob = Secret (SigningKey HydraKey)
-> Snapshot SimpleTx -> Signature (Snapshot SimpleTx)
forall a.
SignableRepresentation a =>
Secret (SigningKey HydraKey) -> a -> Signature a
sign Secret (SigningKey HydraKey)
bobSk Snapshot SimpleTx
snapshot
            sigAlice :: Signature (Snapshot SimpleTx)
sigAlice = Secret (SigningKey HydraKey)
-> Snapshot SimpleTx -> Signature (Snapshot SimpleTx)
forall a.
SignableRepresentation a =>
Secret (SigningKey HydraKey) -> a -> Signature a
sign Secret (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:depositTxId:ReqTx :: Maybe (TxIdType SimpleTx)
depositTxId = Maybe SimpleId
Maybe (TxIdType SimpleTx)
forall a. Maybe a
Nothing}
                   ]
        (HydraNode SimpleTx IO
node, IO [Message SimpleTx]
getNetworkEvents) <-
          Tracer IO (HydraNodeLog SimpleTx)
-> Secret (SigningKey HydraKey)
-> [Party]
-> ContestationPeriod
-> [Input SimpleTx]
-> IO (HydraNode SimpleTx IO)
forall (m :: * -> *).
(MonadTime m, MonadDelay m, MonadAsync m, MonadLabelledSTM m,
 MonadThrow m, MonadUnliftIO m) =>
Tracer m (HydraNodeLog SimpleTx)
-> Secret (SigningKey HydraKey)
-> [Party]
-> ContestationPeriod
-> [Input SimpleTx]
-> m (HydraNode SimpleTx m)
testHydraNode Tracer IO (HydraNodeLog SimpleTx)
tracer Secret (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.
(MonadLabelledSTM 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 [Input SimpleTx]
inputs :: [Input SimpleTx] = [ClientInput SimpleTx -> Input SimpleTx
forall tx. ClientInput tx -> Input tx
ClientInput ClientInput SimpleTx
forall tx. ClientInput tx
Init]
        let tx :: SimpleTx
tx = SimpleId -> SimpleTx
aValidTx SimpleId
1
        let expectedError :: PostTxError SimpleTx
expectedError = FailedToPostTx{$sel:failureReason:NoSeedInput :: Text
failureReason = Text
"unknown failure", $sel:failingTx:NoSeedInput :: SimpleTx
failingTx = SimpleTx
tx}
        (HydraNode SimpleTx IO
node, IO [Either (ServerOutput SimpleTx) (ClientMessage SimpleTx)]
getServerOutputs) <-
          Tracer IO (HydraNodeLog SimpleTx)
-> Secret (SigningKey HydraKey)
-> [Party]
-> ContestationPeriod
-> [Input SimpleTx]
-> IO (HydraNode SimpleTx IO)
forall (m :: * -> *).
(MonadTime m, MonadDelay m, MonadAsync m, MonadLabelledSTM m,
 MonadThrow m, MonadUnliftIO m) =>
Tracer m (HydraNodeLog SimpleTx)
-> Secret (SigningKey HydraKey)
-> [Party]
-> ContestationPeriod
-> [Input SimpleTx]
-> m (HydraNode SimpleTx m)
testHydraNode Tracer IO (HydraNodeLog SimpleTx)
tracer Secret (SigningKey HydraKey)
aliceSk [Party
bob, Party
carol] ContestationPeriod
cperiod [Input SimpleTx]
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
expectedError
            IO (HydraNode SimpleTx IO)
-> (HydraNode SimpleTx IO
    -> IO
         (HydraNode SimpleTx IO,
          IO [Either (ServerOutput SimpleTx) (ClientMessage SimpleTx)]))
-> IO
     (HydraNode SimpleTx IO,
      IO [Either (ServerOutput SimpleTx) (ClientMessage 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 [Either (ServerOutput SimpleTx) (ClientMessage SimpleTx)])
forall tx.
IsChainState tx =>
HydraNode tx IO
-> IO
     (HydraNode tx IO, IO [Either (ServerOutput tx) (ClientMessage tx)])
recordServerOutputs

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

        [Either (ServerOutput SimpleTx) (ClientMessage SimpleTx)]
outputs <- IO [Either (ServerOutput SimpleTx) (ClientMessage SimpleTx)]
getServerOutputs
        let isPostTxOnChainFailed :: Either (ServerOutput SimpleTx) (ClientMessage SimpleTx) -> Bool
            isPostTxOnChainFailed :: Either (ServerOutput SimpleTx) (ClientMessage SimpleTx) -> Bool
isPostTxOnChainFailed = \case
              Right PostTxOnChainFailed{PostTxError SimpleTx
postTxError :: PostTxError SimpleTx
$sel:postTxError:CommandFailed :: forall tx. ClientMessage tx -> PostTxError tx
postTxError} -> PostTxError SimpleTx
postTxError PostTxError SimpleTx -> PostTxError SimpleTx -> Bool
forall a. Eq a => a -> a -> Bool
== PostTxError SimpleTx
expectedError
              Either (ServerOutput SimpleTx) (ClientMessage SimpleTx)
_ -> Bool
False

        (Either (ServerOutput SimpleTx) (ClientMessage SimpleTx) -> Bool)
-> [Either (ServerOutput SimpleTx) (ClientMessage SimpleTx)]
-> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Either (ServerOutput SimpleTx) (ClientMessage SimpleTx) -> Bool
isPostTxOnChainFailed [Either (ServerOutput SimpleTx) (ClientMessage 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
10 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        Text -> (Tracer IO (HydraNodeLog SimpleTx) -> IO ()) -> IO ()
forall (m :: * -> *) msg a.
(MonadLabelledSTM 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 = SimpleId -> SimpleTx
aValidTx SimpleId
1
              tx2 :: SimpleTx
tx2 = SimpleTx{$sel:txSimpleId:SimpleTx :: SimpleId
txSimpleId = SimpleId
2, $sel:txInputs:SimpleTx :: UTxOType SimpleTx
txInputs = [SimpleId] -> UTxOType SimpleTx
utxoRefs [SimpleId
1], $sel:txOutputs:SimpleTx :: UTxOType SimpleTx
txOutputs = [SimpleId] -> UTxOType SimpleTx
utxoRefs [SimpleId
4]}
              tx3 :: SimpleTx
tx3 = SimpleTx{$sel:txSimpleId:SimpleTx :: SimpleId
txSimpleId = SimpleId
3, $sel:txInputs:SimpleTx :: UTxOType SimpleTx
txInputs = [SimpleId] -> UTxOType SimpleTx
utxoRefs [SimpleId
1], $sel:txOutputs:SimpleTx :: UTxOType SimpleTx
txOutputs = [SimpleId] -> UTxOType SimpleTx
utxoRefs [SimpleId
5]}
              inputs :: [Input SimpleTx]
inputs =
                [Input SimpleTx]
inputsToOpenHead
                  [Input SimpleTx] -> [Input SimpleTx] -> [Input SimpleTx]
forall a. Semigroup a => a -> a -> a
<> [ TTL -> NetworkEvent (Message SimpleTx) -> Input SimpleTx
forall tx. TTL -> NetworkEvent (Message tx) -> Input tx
NetworkInput TTL
testTTL (NetworkEvent (Message SimpleTx) -> Input SimpleTx)
-> NetworkEvent (Message SimpleTx) -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ ReceivedMessage{$sel:sender:ConnectivityEvent :: Party
sender = Party
alice, $sel:msg:ConnectivityEvent :: Message SimpleTx
msg = ReqTx{$sel:transaction:ReqTx :: SimpleTx
transaction = SimpleTx
tx1}}
                     , TTL -> NetworkEvent (Message SimpleTx) -> Input SimpleTx
forall tx. TTL -> NetworkEvent (Message tx) -> Input tx
NetworkInput TTL
testTTL (NetworkEvent (Message SimpleTx) -> Input SimpleTx)
-> NetworkEvent (Message SimpleTx) -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ ReceivedMessage{$sel:sender:ConnectivityEvent :: Party
sender = Party
alice, $sel:msg:ConnectivityEvent :: Message SimpleTx
msg = ReqTx{$sel:transaction:ReqTx :: SimpleTx
transaction = SimpleTx
tx2}}
                     , TTL -> NetworkEvent (Message SimpleTx) -> Input SimpleTx
forall tx. TTL -> NetworkEvent (Message tx) -> Input tx
NetworkInput TTL
testTTL (NetworkEvent (Message SimpleTx) -> Input SimpleTx)
-> NetworkEvent (Message SimpleTx) -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ ReceivedMessage{$sel:sender:ConnectivityEvent :: Party
sender = Party
carol, $sel:msg:ConnectivityEvent :: Message SimpleTx
msg = ReqTx{$sel:transaction:ReqTx :: SimpleTx
transaction = SimpleTx
tx3}}
                     , -- Alice's ledger decides whether tx2 or tx3 wins
                       TTL -> NetworkEvent (Message SimpleTx) -> Input SimpleTx
forall tx. TTL -> NetworkEvent (Message tx) -> Input tx
NetworkInput TTL
testTTL (NetworkEvent (Message SimpleTx) -> Input SimpleTx)
-> NetworkEvent (Message SimpleTx) -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$
                        ReceivedMessage
                          { $sel:sender:ConnectivityEvent :: Party
sender = Party
alice
                          , $sel:msg:ConnectivityEvent :: Message SimpleTx
msg =
                              ReqSn
                                { $sel:snapshotVersion:ReqTx :: SnapshotVersion
snapshotVersion = SnapshotVersion
0
                                , $sel:snapshotNumber:ReqTx :: SnapshotNumber
snapshotNumber = SnapshotNumber
1
                                , $sel:transactionIds:ReqTx :: [TxIdType SimpleTx]
transactionIds = [SimpleId
TxIdType SimpleTx
1, SimpleId
TxIdType SimpleTx
2]
                                , $sel:decommitTx:ReqTx :: Maybe SimpleTx
decommitTx = Maybe SimpleTx
forall a. Maybe a
Nothing
                                , $sel:depositTxId:ReqTx :: Maybe (TxIdType SimpleTx)
depositTxId = Maybe SimpleId
Maybe (TxIdType SimpleTx)
forall a. Maybe a
Nothing
                                }
                          }
                     ]
          (HydraNode SimpleTx IO
node, IO [Message SimpleTx]
getNetworkEvents) <-
            Tracer IO (HydraNodeLog SimpleTx)
-> Secret (SigningKey HydraKey)
-> [Party]
-> ContestationPeriod
-> [Input SimpleTx]
-> IO (HydraNode SimpleTx IO)
forall (m :: * -> *).
(MonadTime m, MonadDelay m, MonadAsync m, MonadLabelledSTM m,
 MonadThrow m, MonadUnliftIO m) =>
Tracer m (HydraNodeLog SimpleTx)
-> Secret (SigningKey HydraKey)
-> [Party]
-> ContestationPeriod
-> [Input SimpleTx]
-> m (HydraNode SimpleTx m)
testHydraNode Tracer IO (HydraNodeLog SimpleTx)
tracer Secret (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 = Secret (SigningKey HydraKey)
-> Snapshot SimpleTx -> Signature (Snapshot SimpleTx)
forall a.
SignableRepresentation a =>
Secret (SigningKey HydraKey) -> a -> Signature a
sign Secret (SigningKey HydraKey)
bobSk (Snapshot SimpleTx -> Signature (Snapshot SimpleTx))
-> Snapshot SimpleTx -> Signature (Snapshot SimpleTx)
forall a b. (a -> b) -> a -> b
$ SnapshotNumber
-> SnapshotVersion
-> [SimpleTx]
-> UTxOType SimpleTx
-> Snapshot SimpleTx
forall tx.
IsTx tx =>
SnapshotNumber
-> SnapshotVersion -> [tx] -> UTxOType tx -> Snapshot tx
testSnapshot SnapshotNumber
1 SnapshotVersion
0 [SimpleTx
tx2] ([SimpleId] -> UTxOType SimpleTx
utxoRefs [SimpleId
4])
                              , $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 :: Secret (SigningKey HydraKey)
signingKey = Secret (SigningKey HydraKey)
aliceSk
            , $sel:otherParties:Environment :: [Party]
otherParties = [Party
bob]
            , $sel:contestationPeriod:Environment :: ContestationPeriod
contestationPeriod = ContestationPeriod
defaultContestationPeriod
            , $sel:depositPeriod:Environment :: DepositPeriod
depositPeriod = DepositPeriod
defaultDepositPeriod
            , $sel:depositActivation:Environment :: DepositPeriod
depositActivation = DepositPeriod
defaultDepositActivation
            , $sel:unsyncedPeriod:Environment :: UnsyncedPeriod
unsyncedPeriod = UnsyncedPeriod
defaultUnsyncedPeriod
            , $sel:participants:Environment :: [OnChainId]
participants = Party -> OnChainId
deriveOnChainId (Party -> OnChainId) -> [Party] -> [OnChainId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Party
alice, Party
bob]
            , $sel:configuredPeers:Environment :: Text
configuredPeers = Text
""
            }
        nodeState :: NodeState SimpleTx
nodeState = [Party] -> NodeState SimpleTx
inOpenState [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.
(MonadLabelledSTM 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 (NodeState SimpleTx -> HeadState SimpleTx
forall tx. NodeState tx -> HeadState tx
headState NodeState SimpleTx
nodeState) 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.
(MonadLabelledSTM 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 = 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 (NodeState SimpleTx -> HeadState SimpleTx
forall tx. NodeState tx -> HeadState tx
headState NodeState SimpleTx
nodeState)
          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 deposit 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.
(MonadLabelledSTM 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.depositPeriod = 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 (NodeState SimpleTx -> HeadState SimpleTx
forall tx. NodeState tx -> HeadState tx
headState NodeState SimpleTx
nodeState)
          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.
(MonadLabelledSTM 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 (NodeState SimpleTx -> HeadState SimpleTx
forall tx. NodeState tx -> HeadState tx
headState NodeState SimpleTx
nodeState)
          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 <- String
-> [Envelope (HydraNodeLog SimpleTx)]
-> IO (TVar IO [Envelope (HydraNodeLog SimpleTx)])
forall (m :: * -> *) a.
MonadLabelledSTM m =>
String -> a -> m (TVar m a)
newLabelledTVarIO String
"logs" []
      let invalidPeriodEnv :: Environment
invalidPeriodEnv = Environment
defaultEnv{otherParties = []}
          isContestationPeriodMismatch :: HydraNodeLog SimpleTx -> Bool
          isContestationPeriodMismatch :: HydraNodeLog SimpleTx -> Bool
isContestationPeriodMismatch = \case
            Misconfiguration{} -> Bool
True
            HydraNodeLog SimpleTx
_ -> 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 (NodeState SimpleTx -> HeadState SimpleTx
forall tx. NodeState tx -> HeadState tx
headState NodeState SimpleTx
nodeState)
        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
isContestationPeriodMismatch

-- | Add given list of inputs to the 'InputQueue'. A preceding 'Tick' is enqueued
-- to advance the chain slot and ensure the 'NodeState' is in sync. This is
-- returning the node to allow for chaining with 'runToCompletion'.
primeWith :: MonadSTM m => [Input tx] -> HydraNode tx m -> m (HydraNode tx m)
primeWith :: forall (m :: * -> *) tx.
MonadSTM m =>
[Input tx] -> HydraNode tx m -> m (HydraNode tx m)
primeWith [Input tx]
inputs node :: HydraNode tx m
node@HydraNode{$sel:inputQueue:HydraNode :: forall tx (m :: * -> *). HydraNode tx m -> InputQueue m (Input tx)
inputQueue = InputQueue{Input tx -> m ()
enqueue :: Input tx -> m ()
$sel:enqueue:InputQueue :: forall (m :: * -> *) e. InputQueue m e -> e -> m ()
enqueue}} = do
  [Input tx] -> (Input tx -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Input tx]
inputs Input tx -> m ()
enqueue
  HydraNode tx m -> m (HydraNode tx m)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure HydraNode tx m
node

-- | A preceding 'Tick' is enqueued to advance the chain slot and ensure the 'NodeState' is in sync. This is
-- returning the node to allow for chaining with 'runToCompletion'.
primeWithTime :: MonadSTM m => HydraNode SimpleTx m -> m (HydraNode SimpleTx m)
primeWithTime :: forall (m :: * -> *).
MonadSTM m =>
HydraNode SimpleTx m -> m (HydraNode SimpleTx m)
primeWithTime node :: HydraNode SimpleTx m
node@HydraNode{$sel:inputQueue:HydraNode :: forall tx (m :: * -> *). HydraNode tx m -> InputQueue m (Input tx)
inputQueue = InputQueue{Input SimpleTx -> m ()
$sel:enqueue:InputQueue :: forall (m :: * -> *) e. InputQueue m e -> e -> m ()
enqueue :: Input SimpleTx -> m ()
enqueue}, $sel:nodeStateHandler:HydraNode :: forall tx (m :: * -> *). HydraNode tx m -> NodeStateHandler tx m
nodeStateHandler = NodeStateHandler{STM m (NodeState SimpleTx)
queryNodeState :: STM m (NodeState SimpleTx)
$sel:queryNodeState:NodeStateHandler :: forall tx (m :: * -> *).
NodeStateHandler tx m -> STM m (NodeState tx)
queryNodeState}} = do
  UTCTime
knownChainTime <- ChainPointTime -> UTCTime
currentChainTime (ChainPointTime -> UTCTime)
-> (NodeState SimpleTx -> ChainPointTime)
-> NodeState SimpleTx
-> UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NodeState SimpleTx -> ChainPointTime
forall tx. NodeState tx -> ChainPointTime
chainPointTime (NodeState SimpleTx -> UTCTime)
-> m (NodeState SimpleTx) -> m UTCTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM m (NodeState SimpleTx) -> m (NodeState SimpleTx)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically STM m (NodeState SimpleTx)
queryNodeState
  ChainSlot
knownChainSlot <- ChainPointTime -> ChainSlot
currentSlot (ChainPointTime -> ChainSlot)
-> (NodeState SimpleTx -> ChainPointTime)
-> NodeState SimpleTx
-> ChainSlot
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NodeState SimpleTx -> ChainPointTime
forall tx. NodeState tx -> ChainPointTime
chainPointTime (NodeState SimpleTx -> ChainSlot)
-> m (NodeState SimpleTx) -> m ChainSlot
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM m (NodeState SimpleTx) -> m (NodeState SimpleTx)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically STM m (NodeState SimpleTx)
queryNodeState
  let chainSlot :: ChainSlot
chainSlot = ChainSlot
knownChainSlot ChainSlot -> ChainSlot -> ChainSlot
forall a. Num a => a -> a -> a
+ ChainSlot
1
      chainTime :: UTCTime
chainTime = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
1 UTCTime
knownChainTime
      tick :: Input SimpleTx
tick = ChainEvent SimpleTx -> Input SimpleTx
forall tx. ChainEvent tx -> Input tx
ChainInput (ChainEvent SimpleTx -> Input SimpleTx)
-> ChainEvent SimpleTx -> Input SimpleTx
forall a b. (a -> b) -> a -> b
$ UTCTime -> ChainPointType SimpleTx -> ChainEvent SimpleTx
forall tx. UTCTime -> ChainPointType tx -> ChainEvent tx
Tick UTCTime
chainTime ChainSlot
ChainPointType SimpleTx
chainSlot
  Input SimpleTx -> m ()
enqueue Input SimpleTx
tick
  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 tx m -> m (HydraNode tx m)
notConnect :: forall (m :: * -> *) tx.
MonadThrow m =>
DraftHydraNode tx m -> m (HydraNode tx m)
notConnect =
  Chain tx m
-> Network m (Message tx)
-> Server tx m
-> DraftHydraNode tx m
-> m (HydraNode tx 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 tx m
forall (m :: * -> *) tx. MonadThrow m => Chain tx m
mockChain Network m (Message tx)
forall (m :: * -> *) tx. Monad m => Network m (Message tx)
mockNetwork Server tx m
forall (m :: * -> *) tx. Monad m => Server tx m
mockServer

mockServer :: Monad m => Server tx m
mockServer :: forall (m :: * -> *) tx. Monad m => Server tx m
mockServer =
  Server
    { $sel:sendMessage:Server :: ClientMessage tx -> m ()
sendMessage = \ClientMessage tx
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    }

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

mockChain :: MonadThrow m => Chain tx m
mockChain :: forall (m :: * -> *) tx. MonadThrow m => Chain tx m
mockChain =
  Chain
    { $sel:postTx:Chain :: MonadThrow m => PostChainTx tx -> m ()
postTx = \PostChainTx tx
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    , $sel:draftDepositTx:Chain :: MonadThrow m =>
HeadId
-> PParams LedgerEra
-> ConfirmedSnapshot tx
-> CommitBlueprintTx tx
-> UTCTime
-> Maybe AddressInEra
-> m (Either (PostTxError tx) tx)
draftDepositTx = \HeadId
_ PParams LedgerEra
_ ConfirmedSnapshot tx
_ CommitBlueprintTx tx
_ UTCTime
_ Maybe AddressInEra
_ -> String -> m (Either (PostTxError tx) tx)
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure String
"mockChain: unexpected draftDepositTx"
    , $sel:submitTx:Chain :: MonadThrow m => tx -> m ()
submitTx = \tx
_ -> String -> m ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure String
"mockChain: unexpected submitTx"
    , $sel:checkNonADAAssets:Chain :: ConfirmedSnapshot tx -> Either Value ()
checkNonADAAssets = \ConfirmedSnapshot tx
_ -> Text -> Either Value ()
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"mockChain: unexpected checkNonADAAssets"
    }

mockSink :: Monad m => EventSink a m
mockSink :: forall (m :: * -> *) a. Monad m => EventSink a m
mockSink = (HasEventId a => a -> m ()) -> EventSink a m
forall (m :: * -> *) e.
Monad m =>
(HasEventId e => e -> m ()) -> EventSink e m
mkEventSink (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 ())

mockEventStore :: forall a m. Monad m => [a] -> EventStore a m
mockEventStore :: forall a (m :: * -> *). Monad m => [a] -> EventStore a m
mockEventStore [a]
events =
  EventStore{EventSource a m
eventSource :: EventSource a m
$sel:eventSource:EventStore :: EventSource a m
eventSource, EventSink a m
eventSink :: EventSink a m
$sel:eventSink:EventStore :: EventSink a m
eventSink, EventId -> a -> m ()
rotate :: EventId -> a -> m ()
$sel:rotate:EventStore :: EventId -> a -> m ()
rotate}
 where
  eventSource :: EventSource a m
eventSource = [a] -> EventSource a m
forall (m :: * -> *) a. Monad m => [a] -> EventSource a m
mockSource [a]
events

  eventSink :: EventSink a m
  eventSink :: EventSink a m
eventSink = EventSink a m
forall (m :: * -> *) a. Monad m => EventSink a m
mockSink

  rotate :: LogId -> a -> m ()
  rotate :: EventId -> a -> m ()
rotate = (a -> m ()) -> EventId -> a -> m ()
forall a b. a -> b -> a
const ((a -> m ()) -> EventId -> a -> m ())
-> (m () -> a -> m ()) -> m () -> EventId -> a -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m () -> a -> m ()
forall a b. a -> b -> a
const (m () -> EventId -> a -> m ()) -> m () -> EventId -> 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:sourceEvents:EventSource :: HasEventId a => ConduitT () a (ResourceT m) ()
sourceEvents = [a] -> ConduitT () (Element [a]) (ResourceT m) ()
forall (m :: * -> *) mono i.
(Monad m, MonoFoldable mono) =>
mono -> ConduitT i (Element mono) m ()
yieldMany [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 ((HasEventId a => a -> IO ()) -> EventSink a IO
forall (m :: * -> *) e.
Monad m =>
(HasEventId e => e -> m ()) -> EventSink e m
mkEventSink a -> IO ()
HasEventId a => a -> IO ()
putEvent, IO [a]
getAll)

createMockEventStore :: MonadLabelledSTM m => m (EventStore a m)
createMockEventStore :: forall (m :: * -> *) a. MonadLabelledSTM m => m (EventStore a m)
createMockEventStore = do
  TVar m [a]
tvar <- String -> [a] -> m (TVar m [a])
forall (m :: * -> *) a.
MonadLabelledSTM m =>
String -> a -> m (TVar m a)
newLabelledTVarIO String
"in-memory-source-sink" []
  let source :: EventSource a m
source =
        EventSource
          { $sel:sourceEvents:EventSource :: HasEventId a => ConduitT () a (ResourceT m) ()
sourceEvents = do
              [a]
es <- ResourceT m [a] -> ConduitT () a (ResourceT m) [a]
forall (m :: * -> *) a. Monad m => m a -> ConduitT () a m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ResourceT m [a] -> ConduitT () a (ResourceT m) [a])
-> (m [a] -> ResourceT m [a])
-> m [a]
-> ConduitT () a (ResourceT m) [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m [a] -> ResourceT m [a]
forall (m :: * -> *) a. Monad m => m a -> ResourceT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m [a] -> ConduitT () a (ResourceT m) [a])
-> m [a] -> ConduitT () a (ResourceT m) [a]
forall a b. (a -> b) -> a -> b
$ 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
              [a] -> ConduitT () (Element [a]) (ResourceT m) ()
forall (m :: * -> *) mono i.
(Monad m, MonoFoldable mono) =>
mono -> ConduitT i (Element mono) m ()
yieldMany [a]
es
          }
      sink :: EventSink a m
sink =
        (HasEventId a => a -> m ()) -> EventSink a m
forall (m :: * -> *) e.
Monad m =>
(HasEventId e => e -> m ()) -> EventSink e m
mkEventSink
          ( \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])
          )
      rotate :: EventId -> a -> m ()
rotate EventId
_ a
checkpoint = 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] -> STM m ()
forall a. TVar m a -> a -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m [a]
tvar [a
checkpoint]
  EventStore a m -> m (EventStore a m)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EventSource a m
-> EventSink a m -> (EventId -> a -> m ()) -> EventStore a m
forall e (m :: * -> *).
EventSource e m
-> EventSink e m -> (EventId -> e -> m ()) -> EventStore e m
EventStore EventSource a m
source EventSink a m
sink EventId -> a -> m ()
rotate)

-- | Synthetic inputs that simulate a head opening. The head will be empty
-- though and this test hardness can not reliably simulate deposits. Use
-- 'aValidTx' to create utxos out of thin air instead.
--
-- Explanation why we can't just emualte OnDepositTx and OnIncrementTx here:
-- While the deposit will be seen as finalized, there is no ConfirmedSnapshot
-- here that could be adopted and thus the confirmed utxo (legder state).
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
  ]
 where
  parties :: [Party]
parties = [Party
alice, Party
bob, Party
carol]
  headParameters :: HeadParameters
headParameters = ContestationPeriod -> DepositPeriod -> [Party] -> HeadParameters
HeadParameters ContestationPeriod
cperiod DepositPeriod
defaultDepositPeriod [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

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 = ChainStateType SimpleTx
SimpleChainState
0
          }
    }

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}, $sel:nodeStateHandler:HydraNode :: forall tx (m :: * -> *). HydraNode tx m -> NodeStateHandler tx m
nodeStateHandler = NodeStateHandler{STM IO (NodeState tx)
$sel:queryNodeState:NodeStateHandler :: forall tx (m :: * -> *).
NodeStateHandler tx m -> STM m (NodeState tx)
queryNodeState :: STM IO (NodeState tx)
queryNodeState}} = 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
$ do
      UTCTime
knownChainTime <- ChainPointTime -> UTCTime
currentChainTime (ChainPointTime -> UTCTime)
-> (NodeState tx -> ChainPointTime) -> NodeState tx -> UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NodeState tx -> ChainPointTime
forall tx. NodeState tx -> ChainPointTime
chainPointTime (NodeState tx -> UTCTime) -> IO (NodeState tx) -> IO UTCTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM IO (NodeState tx) -> IO (NodeState tx)
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically STM IO (NodeState tx)
queryNodeState
      let nextChainTime :: UTCTime
nextChainTime = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
1 UTCTime
knownChainTime
      UTCTime -> HydraNode tx IO -> IO ()
forall (m :: * -> *) tx.
(MonadCatch m, MonadAsync m, MonadTime m, IsChainState tx) =>
UTCTime -> HydraNode tx m -> m ()
stepHydraNode UTCTime
nextChainTime 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 ::
  (MonadTime m, MonadDelay m, MonadAsync m, MonadLabelledSTM m, MonadThrow m, MonadUnliftIO m) =>
  Tracer m (HydraNodeLog SimpleTx) ->
  Secret (SigningKey HydraKey) ->
  [Party] ->
  ContestationPeriod ->
  [Input SimpleTx] ->
  m (HydraNode SimpleTx m)
testHydraNode :: forall (m :: * -> *).
(MonadTime m, MonadDelay m, MonadAsync m, MonadLabelledSTM m,
 MonadThrow m, MonadUnliftIO m) =>
Tracer m (HydraNodeLog SimpleTx)
-> Secret (SigningKey HydraKey)
-> [Party]
-> ContestationPeriod
-> [Input SimpleTx]
-> m (HydraNode SimpleTx m)
testHydraNode Tracer m (HydraNodeLog SimpleTx)
tracer Secret (SigningKey HydraKey)
signingKey [Party]
otherParties ContestationPeriod
contestationPeriod [Input SimpleTx]
inputs = do
  let eventStore :: Monad m => EventStore (StateEvent SimpleTx) m
      eventStore :: forall (m :: * -> *). Monad m => EventStore (StateEvent SimpleTx) m
eventStore = [StateEvent SimpleTx] -> EventStore (StateEvent SimpleTx) m
forall a (m :: * -> *). Monad m => [a] -> EventStore a m
mockEventStore []
  Tracer m (HydraNodeLog SimpleTx)
-> Environment
-> Ledger SimpleTx
-> ChainStateType SimpleTx
-> EventStore (StateEvent SimpleTx) m
-> [EventSink (StateEvent SimpleTx) m]
-> m (DraftHydraNode SimpleTx m)
forall tx (m :: * -> *).
(IsChainState tx, MonadDelay m, MonadLabelledSTM m, MonadAsync m,
 MonadThrow m, MonadUnliftIO m) =>
Tracer m (HydraNodeLog tx)
-> Environment
-> Ledger tx
-> ChainStateType tx
-> EventStore (StateEvent tx) m
-> [EventSink (StateEvent tx) m]
-> m (DraftHydraNode tx m)
hydrate Tracer m (HydraNodeLog SimpleTx)
tracer Environment
env Ledger SimpleTx
simpleLedger ChainStateType SimpleTx
SimpleChainState
0 EventStore (StateEvent SimpleTx) m
forall (m :: * -> *). Monad m => EventStore (StateEvent SimpleTx) m
eventStore []
    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 :: * -> *) tx.
MonadThrow m =>
DraftHydraNode tx m -> m (HydraNode tx 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
>>= HydraNode SimpleTx m -> m (HydraNode SimpleTx m)
forall (m :: * -> *).
MonadSTM m =>
HydraNode SimpleTx m -> m (HydraNode SimpleTx m)
primeWithTime
    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 :: * -> *) tx.
MonadSTM m =>
[Input tx] -> HydraNode tx m -> m (HydraNode tx m)
primeWith [Input SimpleTx]
inputs
 where
  env :: Environment
env =
    Environment
      { Party
$sel:party:Environment :: Party
party :: Party
party
      , Secret (SigningKey HydraKey)
$sel:signingKey:Environment :: Secret (SigningKey HydraKey)
signingKey :: Secret (SigningKey HydraKey)
signingKey
      , [Party]
$sel:otherParties:Environment :: [Party]
otherParties :: [Party]
otherParties
      , ContestationPeriod
$sel:contestationPeriod:Environment :: ContestationPeriod
contestationPeriod :: ContestationPeriod
contestationPeriod
      , $sel:depositPeriod:Environment :: DepositPeriod
depositPeriod = DepositPeriod
defaultDepositPeriod
      , $sel:depositActivation:Environment :: DepositPeriod
depositActivation = DepositPeriod
defaultDepositActivation
      , $sel:unsyncedPeriod:Environment :: UnsyncedPeriod
unsyncedPeriod = ContestationPeriod -> UnsyncedPeriod
defaultUnsyncedPeriodFor ContestationPeriod
contestationPeriod
      , [OnChainId]
$sel:participants:Environment :: [OnChainId]
participants :: [OnChainId]
participants
      , $sel:configuredPeers:Environment :: Text
configuredPeers = Text
""
      }

  party :: Party
party = Secret (SigningKey HydraKey) -> Party
deriveParty Secret (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)

-- | A lot shorter than the real world ttl which requires to be long to overcome
-- some longer chain observation delays, but would just make tests longer.
testTTL :: TTL
testTTL :: TTL
testTTL = TTL
5

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 :: IsChainState tx => HydraNode tx IO -> IO (HydraNode tx IO, IO [Either (ServerOutput tx) (ClientMessage tx)])
recordServerOutputs :: forall tx.
IsChainState tx =>
HydraNode tx IO
-> IO
     (HydraNode tx IO, IO [Either (ServerOutput tx) (ClientMessage tx)])
recordServerOutputs HydraNode tx IO
node = do
  (Either (ServerOutput tx) (ClientMessage tx) -> IO ()
record, IO [Either (ServerOutput tx) (ClientMessage tx)]
query) <- IO
  (Either (ServerOutput tx) (ClientMessage tx) -> IO (),
   IO [Either (ServerOutput tx) (ClientMessage tx)])
forall msg. IO (msg -> IO (), IO [msg])
messageRecorder
  TVar (Maybe (Snapshot tx))
mSeenSnapshotVar <- Maybe (Snapshot tx) -> IO (TVar IO (Maybe (Snapshot tx)))
forall a. a -> IO (TVar IO a)
forall (m :: * -> *) a. MonadSTM m => a -> m (TVar m a)
newTVarIO Maybe (Snapshot tx)
forall a. Maybe a
Nothing
  let apiSink :: EventSink (StateEvent tx) IO
apiSink =
        (HasEventId (StateEvent tx) => StateEvent tx -> IO ())
-> EventSink (StateEvent tx) IO
forall (m :: * -> *) e.
Monad m =>
(HasEventId e => e -> m ()) -> EventSink e m
mkEventSink
          ( \StateEvent tx
event -> do
              Maybe (Snapshot tx)
mSeenSnapshot <- TVar IO (Maybe (Snapshot tx)) -> IO (Maybe (Snapshot tx))
forall a. TVar IO a -> IO a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> m a
readTVarIO TVar (Maybe (Snapshot tx))
TVar IO (Maybe (Snapshot tx))
mSeenSnapshotVar
              STM IO () -> IO ()
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM IO () -> IO ()) -> STM IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar IO (Maybe (Snapshot tx)) -> Maybe (Snapshot tx) -> STM IO ()
forall a. TVar IO a -> a -> STM IO ()
forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar (Maybe (Snapshot tx))
TVar IO (Maybe (Snapshot tx))
mSeenSnapshotVar (Maybe (Snapshot tx) -> StateChanged tx -> Maybe (Snapshot tx)
forall tx.
Maybe (Snapshot tx) -> StateChanged tx -> Maybe (Snapshot tx)
updateSeenSnapshot Maybe (Snapshot tx)
mSeenSnapshot (StateEvent tx -> StateChanged tx
forall tx. StateEvent tx -> StateChanged tx
stateChanged StateEvent tx
event))
              case Maybe (Snapshot tx)
-> StateEvent tx -> Maybe (TimedServerOutput tx)
forall tx.
IsChainState tx =>
Maybe (Snapshot tx)
-> StateEvent tx -> Maybe (TimedServerOutput tx)
mkTimedServerOutputFromStateEvent Maybe (Snapshot tx)
mSeenSnapshot StateEvent tx
event of
                Maybe (TimedServerOutput tx)
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                Just TimedServerOutput{ServerOutput tx
output :: ServerOutput tx
$sel:output:TimedServerOutput :: forall tx. TimedServerOutput tx -> ServerOutput tx
output} -> Either (ServerOutput tx) (ClientMessage tx) -> IO ()
record (Either (ServerOutput tx) (ClientMessage tx) -> IO ())
-> Either (ServerOutput tx) (ClientMessage tx) -> IO ()
forall a b. (a -> b) -> a -> b
$ ServerOutput tx -> Either (ServerOutput tx) (ClientMessage tx)
forall a b. a -> Either a b
Left ServerOutput tx
output
          )
  (HydraNode tx IO, IO [Either (ServerOutput tx) (ClientMessage tx)])
-> IO
     (HydraNode tx IO, IO [Either (ServerOutput tx) (ClientMessage tx)])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    ( HydraNode tx IO
node{eventSinks = apiSink : eventSinks node, server = Server{sendMessage = record . Right}}
    , IO [Either (ServerOutput tx) (ClientMessage 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 msg. IORef [msg] -> msg -> IO ()
appendMsg IORef [msg]
ref, IORef [msg] -> IO [msg]
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef [msg]
ref)
 where
  appendMsg :: IORef [msg] -> msg -> IO ()
  appendMsg :: forall msg. IORef [msg] -> msg -> IO ()
appendMsg IORef [msg]
ref msg
x = IORef [msg] -> ([msg] -> ([msg], ())) -> IO ()
forall (m :: * -> *) a b.
MonadIO m =>
IORef a -> (a -> (a, b)) -> m b
atomicModifyIORef' IORef [msg]
ref (([msg] -> ([msg], ())) -> IO ())
-> ([msg] -> ([msg], ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \[msg]
old -> ([msg]
old [msg] -> [msg] -> [msg]
forall a. Semigroup a => a -> a -> a
<> [msg
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
            , draftDepositTx = \HeadId
_ -> Text
-> PParams ConwayEra
-> ConfirmedSnapshot tx
-> CommitBlueprintTx tx
-> UTCTime
-> Maybe AddressInEra
-> 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"
            , checkNonADAAssets = \ConfirmedSnapshot tx
_ -> Text -> Either Value ()
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"checkNonADAAssets not implemented"
            }
      }