Generate compatible state change events when testing hydrate

This is unfortunately very "white-boxy" and the testing code needs to
know that the generated events must be using parameters consistent with
the environment.

The alternative would be to move checkHeadState outside of hydrate, but
then 'WetHydraNode's can exist without this check happening.

Author: ch1bo

hydra-node/src/Hydra/Chain.hs

@@ -27,6 +27,7 @@ import Hydra.Cardano.Api (
   Witness,
  )
 import Hydra.ContestationPeriod (ContestationPeriod)
+import Hydra.Environment (Environment (..))
 import Hydra.HeadId (HeadId, HeadSeed)
 import Hydra.Ledger (ChainSlot, IsTx, UTxOType)
 import Hydra.OnChainId (OnChainId)
@@ -60,6 +61,11 @@ instance Arbitrary HeadParameters where
     dedupParties HeadParameters{contestationPeriod, parties} =
       HeadParameters{contestationPeriod, parties = nub parties}
 
+-- | Make 'HeadParameters' that are consistent with the given 'Environment'.
+mkHeadParameters :: Environment -> HeadParameters
+mkHeadParameters Environment{party, otherParties, contestationPeriod} =
+  HeadParameters{contestationPeriod, parties = party : otherParties}
+
 -- | Data type used to post transactions on chain. It holds everything to
 -- construct corresponding Head protocol transactions.
 data PostChainTx tx

hydra-node/src/Hydra/Environment.hs

@@ -18,7 +18,7 @@ data Environment = Environment
     participants :: [OnChainId]
   , contestationPeriod :: ContestationPeriod
   }
-  deriving stock (Show)
+  deriving stock (Show, Eq)
 
 instance Arbitrary Environment where
   arbitrary = do

hydra-node/src/Hydra/HeadLogic.hs

@@ -37,6 +37,7 @@ import Hydra.Chain (
   OnChainTx (..),
   PostChainTx (..),
   initHistory,
+  mkHeadParameters,
   pushNewState,
   rollbackHistory,
  )
@@ -109,13 +110,9 @@ onIdleClientInit ::
 onIdleClientInit env =
   cause OnChainEffect{postChainTx = InitTx{participants, headParameters}}
  where
-  headParameters =
-    HeadParameters
-      { contestationPeriod
-      , parties = party : otherParties
-      }
+  headParameters = mkHeadParameters env
 
-  Environment{party, otherParties, contestationPeriod, participants} = env
+  Environment{participants} = env
 
 -- | Observe an init transaction, initialize parameters in an 'InitialState' and
 -- notify clients that they can now commit.

hydra-node/src/Hydra/HeadLogic/Outcome.hs

@@ -6,7 +6,7 @@ module Hydra.HeadLogic.Outcome where
 import Hydra.Prelude
 
 import Hydra.API.ServerOutput (ServerOutput)
-import Hydra.Chain (ChainStateType, HeadParameters, IsChainState, PostChainTx)
+import Hydra.Chain (ChainStateType, HeadParameters, IsChainState, PostChainTx, mkHeadParameters)
 import Hydra.Crypto (MultiSignature, Signature)
 import Hydra.Environment (Environment (..))
 import Hydra.Events (HasEventId (..))
@@ -17,6 +17,7 @@ import Hydra.Ledger (ChainSlot, IsTx, TxIdType, UTxOType, ValidationError)
 import Hydra.Network.Message (Message)
 import Hydra.Party (Party)
 import Hydra.Snapshot (Snapshot, SnapshotNumber)
+import Test.QuickCheck (oneof)
 
 -- | Analogous to inputs, the pure head logic "core" can have effects emited to
 -- the "shell" layers and we distinguish the same: effects onto the client, the
@@ -105,14 +106,37 @@ instance HasEventId (StateChanged tx) where
 -- FIXME(Elaine): these stateChangeID fields were added in an attempt to make every StateChanged keep track of its ID
 -- it's not clear how to handle the state for this. but for now the field is kept so that the type of putEvent can be kept simple, and shouldn't do harm
 
-instance (IsTx tx, Arbitrary (HeadState tx), Arbitrary (ChainStateType tx)) => Arbitrary (StateChanged tx) where
-  arbitrary = genericArbitrary
-
 deriving stock instance (IsTx tx, Eq (HeadState tx), Eq (ChainStateType tx)) => Eq (StateChanged tx)
 deriving stock instance (IsTx tx, Show (HeadState tx), Show (ChainStateType tx)) => Show (StateChanged tx)
 deriving anyclass instance (IsTx tx, ToJSON (ChainStateType tx)) => ToJSON (StateChanged tx)
 deriving anyclass instance (IsTx tx, FromJSON (HeadState tx), FromJSON (ChainStateType tx)) => FromJSON (StateChanged tx)
 
+instance IsChainState tx => Arbitrary (StateChanged tx) where
+  arbitrary = arbitrary >>= genStateChanged
+
+genStateChanged :: IsChainState tx => Environment -> Gen (StateChanged tx)
+genStateChanged env =
+  oneof
+    [ HeadInitialized (mkHeadParameters env) <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
+    , CommittedUTxO party <$> arbitrary <*> arbitrary <*> arbitrary
+    , HeadAborted <$> arbitrary <*> arbitrary
+    , HeadOpened <$> arbitrary <*> arbitrary <*> arbitrary
+    , TransactionAppliedToLocalUTxO <$> arbitrary <*> arbitrary <*> arbitrary
+    , SnapshotRequestDecided <$> arbitrary <*> arbitrary
+    , SnapshotRequested <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
+    , TransactionReceived <$> arbitrary <*> arbitrary
+    , PartySignedSnapshot <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
+    , SnapshotConfirmed <$> arbitrary <*> arbitrary <*> arbitrary
+    , HeadClosed <$> arbitrary <*> arbitrary <*> arbitrary
+    , HeadContested <$> arbitrary <*> arbitrary <*> arbitrary
+    , HeadIsReadyToFanout <$> arbitrary
+    , HeadFannedOut <$> arbitrary <*> arbitrary
+    , ChainRolledBack <$> arbitrary <*> arbitrary
+    , TickObserved <$> arbitrary <*> arbitrary
+    ]
+ where
+  Environment{party} = env
+
 data Outcome tx
   = -- | Continue with the given state updates and side effects.
     Continue {events :: [StateChanged tx], effects :: [Effect tx]}

hydra-node/src/Hydra/Node.hs

@@ -177,19 +177,17 @@ hydrate ::
   EventSource (StateChanged tx) m ->
   [EventSink (StateChanged tx) m] ->
   DryHydraNode tx m ->
-  m
-    ( WetHydraNode tx m
-    )
+  m (WetHydraNode tx m)
 hydrate eventSource eventSinks dryNode = do
   events <- getEvents eventSource
   traceWith tracer LoadedState{numberOfEvents = fromIntegral $ length events}
   let headState = recoverState initialState events
       chainStateHistory = recoverChainStateHistory initialChainState events
+  -- Check whether the loaded state matches our configuration (env)
+  checkHeadState tracer env headState
   -- deliver to sinks per spec, deduplication is handled by the sinks
   -- FIXME(Elaine): persistence currently not handling duplication, so this relies on not providing the eventSource's sink as an arg here
   putEventsToSinks eventSinks events
-  -- FIXME: move this outside (how access headstate?)
-  -- checkHeadState tracer env hs
   nodeState <- createNodeState headState
   inputQueue <- createInputQueue
   pure

hydra-node/test/Hydra/NodeSpec.hs

@@ -10,13 +10,14 @@ import Hydra.API.ClientInput (ClientInput (..))
 import Hydra.API.Server (Server (..))
 import Hydra.API.ServerOutput (ServerOutput (..))
 import Hydra.Cardano.Api (SigningKey)
-import Hydra.Chain (Chain (..), ChainEvent (..), HeadParameters (..), IsChainState, OnChainTx (..), PostTxError (NoSeedInput))
+import Hydra.Chain (Chain (..), ChainEvent (..), HeadParameters (..), IsChainState, OnChainTx (..), PostTxError (NoSeedInput), mkHeadParameters)
 import Hydra.ContestationPeriod (ContestationPeriod (..))
 import Hydra.Crypto (HydraKey, sign)
 import Hydra.Environment (Environment (..))
 import Hydra.Environment qualified as Environment
 import Hydra.Events (EventSink (..), EventSource (..))
 import Hydra.HeadLogic (Input (..), defaultTTL)
+import Hydra.HeadLogic.Outcome (StateChanged (HeadInitialized), genStateChanged)
 import Hydra.HeadLogicSpec (inInitialState, testSnapshot)
 import Hydra.Ledger (ChainSlot (ChainSlot))
 import Hydra.Ledger.Simple (SimpleChainState (..), SimpleTx (..), simpleLedger, utxoRef, utxoRefs)
@@ -41,8 +42,7 @@ import Hydra.Options (defaultContestationPeriod)
 import Hydra.Party (Party, deriveParty)
 import Hydra.Persistence (PersistenceIncremental (..), eventPairFromPersistenceIncremental)
 import Test.Hydra.Fixture (alice, aliceSk, bob, bobSk, carol, carolSk, cperiod, deriveOnChainId, testEnvironment, testHeadId, testHeadSeed)
-import Test.QuickCheck (NonEmptyList (..), listOf, oneof, property)
-import Test.QuickCheck.Property (forAllBlind)
+import Test.QuickCheck (elements, forAllBlind, forAllShrink, listOf, listOf1, (==>))
 
 spec :: Spec
 spec = parallel $ do
@@ -52,23 +52,35 @@ spec = parallel $ do
 
   describe "hydrate" $ do
     around setupDryNode $ do
-      it "loads events from source into all sinks" $ \node -> do
-        property $ \someEvents -> do
-          (mockSink1, getMockSinkEvents1) <- createRecordingSink
-          (mockSink2, getMockSinkEvents2) <- createRecordingSink
-
-          void $ hydrate (mockSource someEvents) [mockSink1, mockSink2] node
-
-          getMockSinkEvents1 `shouldReturn` someEvents
-          getMockSinkEvents2 `shouldReturn` someEvents
-
-      it "fails if one sink fails" $ \node -> do
-        property $ \(NonEmpty someEvents) -> do
-          let genSinks = oneof [pure mockSink, pure failingSink]
-              failingSink = EventSink{putEvent = \_ -> failure "failing sink called"}
-          forAllBlind (listOf genSinks) $ \sinks -> do
-            hydrate (mockSource someEvents) (sinks <> [failingSink]) node
-              `shouldThrow` \(_ :: HUnitFailure) -> True
+      it "loads events from source into all sinks" $ \node ->
+        forAllShrink (listOf $ genStateChanged testEnvironment) shrink $
+          \someEvents -> do
+            (mockSink1, getMockSinkEvents1) <- createRecordingSink
+            (mockSink2, getMockSinkEvents2) <- createRecordingSink
+
+            void $ hydrate (mockSource someEvents) [mockSink1, mockSink2] node
+
+            getMockSinkEvents1 `shouldReturn` someEvents
+            getMockSinkEvents2 `shouldReturn` someEvents
+
+      it "fails if one sink fails" $ \node ->
+        forAllShrink (listOf1 $ genStateChanged testEnvironment) shrink $
+          \someEvents -> do
+            let genSinks = elements [mockSink, failingSink]
+                failingSink = EventSink{putEvent = \_ -> failure "failing sink called"}
+            forAllBlind (listOf genSinks) $ \sinks ->
+              hydrate (mockSource someEvents) (sinks <> [failingSink]) node
+                `shouldThrow` \(_ :: HUnitFailure) -> True
+
+      it "checks head state" $ \node ->
+        forAllShrink arbitrary shrink $ \env ->
+          env /= testEnvironment ==> do
+            -- XXX: This is very tied to the fact that 'HeadInitialized' results in
+            -- a head state that gets checked by 'checkHeadState'
+            let genEvent = HeadInitialized (mkHeadParameters env) <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
+            forAllShrink genEvent shrink $ \incompatibleEvent ->
+              hydrate (mockSource [incompatibleEvent]) [] node
+                `shouldThrow` \(_ :: ParameterMismatch) -> True
 
   describe "stepHydraNode" $ do
     around setupDryNode $ do