Merge pull request #1368 from input-output-hk/use-hydrate-in-tests

Refactor BehaviorSpec and MockChain to use hydrate

hydra-node/src/Hydra/Environment.hs

@@ -5,7 +5,7 @@ import Hydra.Prelude
 import Hydra.ContestationPeriod (ContestationPeriod)
 import Hydra.Crypto (HydraKey, SigningKey)
 import Hydra.OnChainId (OnChainId)
-import Hydra.Party (Party, deriveParty)
+import Hydra.Party (HasParty (..), Party, deriveParty)
 
 data Environment = Environment
   { party :: Party
@@ -34,3 +34,6 @@ instance Arbitrary Environment where
         , contestationPeriod
         , participants
         }
+
+instance HasParty Environment where
+  getParty = party

hydra-node/src/Hydra/Node.hs

@@ -57,7 +57,7 @@ import Hydra.Network.Message (Message)
 import Hydra.Node.InputQueue (InputQueue (..), Queued (..), createInputQueue)
 import Hydra.Node.ParameterMismatch (ParamMismatch (..), ParameterMismatch (..))
 import Hydra.Options (ChainConfig (..), DirectChainConfig (..), RunOptions (..), defaultContestationPeriod)
-import Hydra.Party (Party (..), deriveParty)
+import Hydra.Party (HasParty (..), Party (..), deriveParty)
 
 -- * Environment Handling
 
@@ -152,6 +152,9 @@ data DraftHydraNode tx m = DraftHydraNode
     chainStateHistory :: ChainStateHistory tx
   }
 
+instance HasParty (DraftHydraNode tx m) where
+  getParty DraftHydraNode{env} = getParty env
+
 -- | Hydrate a 'DraftHydraNode' by loading events from source, re-aggregate node
 -- state and sending events to sinks while doing so.
 hydrate ::
@@ -233,6 +236,9 @@ data HydraNode tx m = HydraNode
   , server :: Server tx m
   }
 
+instance HasParty (HydraNode tx m) where
+  getParty HydraNode{env} = getParty env
+
 runHydraNode ::
   ( MonadCatch m
   , MonadAsync m

hydra-node/src/Hydra/Party.hs

@@ -72,3 +72,7 @@ partyFromChain =
   either (\e -> fail $ "partyFromChain failed: " <> show e) (pure . Party)
     . deserialiseFromRawBytes (AsVerificationKey AsHydraKey)
     . OnChain.partyToVerficationKeyBytes
+
+-- | Type class to retrieve the 'Party' from some type.
+class HasParty a where
+  getParty :: a -> Party

hydra-node/test/Hydra/BehaviorSpec.hs

@@ -43,7 +43,6 @@ import Hydra.Events.FileBased (eventPairFromPersistenceIncremental)
 import Hydra.HeadLogic (
   Effect (..),
   HeadState (..),
-  IdleState (..),
   Input (..),
   defaultTTL,
  )
@@ -53,18 +52,10 @@ import Hydra.Ledger.Simple (SimpleChainState (..), SimpleTx (..), aValidTx, simp
 import Hydra.Logging (Tracer)
 import Hydra.Network (Network (..))
 import Hydra.Network.Message (Message)
-import Hydra.Node (
-  HydraNode (..),
-  HydraNodeLog (..),
-  NodeState,
-  createNodeState,
-  queryHeadState,
-  runHydraNode,
-  waitDelay,
- )
-import Hydra.Node.InputQueue (InputQueue (enqueue), createInputQueue)
+import Hydra.Node (DraftHydraNode (..), HydraNode (..), HydraNodeLog (..), connect, hydrate, queryHeadState, runHydraNode, waitDelay)
+import Hydra.Node.InputQueue (InputQueue (enqueue))
 import Hydra.NodeSpec (createPersistenceInMemory)
-import Hydra.Party (Party (..), deriveParty)
+import Hydra.Party (Party (..), deriveParty, getParty)
 import Hydra.Snapshot (Snapshot (..), SnapshotNumber, getSnapshot)
 import Test.Hydra.Fixture (alice, aliceSk, bob, bobSk, deriveOnChainId, testHeadId, testHeadSeed)
 import Test.Util (shouldBe, shouldNotBe, shouldRunInSim, traceInIOSim)
@@ -545,7 +536,7 @@ data TestHydraClient tx m = TestHydraClient
 -- 'OnChainTx' onto all connected nodes. It can also 'rollbackAndForward' any
 -- number of these "transactions".
 data SimulatedChainNetwork tx m = SimulatedChainNetwork
-  { connectNode :: HydraNode tx m -> m (HydraNode tx m)
+  { connectNode :: DraftHydraNode tx m -> m (HydraNode tx m)
   , tickThread :: Async m ()
   , rollbackAndForward :: Natural -> m ()
   , simulateCommit :: (Party, UTxOType tx) -> m ()
@@ -607,20 +598,20 @@ simulatedChainAndNetwork initialChainState = do
   tickThread <- async $ simulateTicks nodes localChainState
   pure $
     SimulatedChainNetwork
-      { connectNode = \node -> do
+      { connectNode = \draftNode -> do
+          let mockChain =
+                Chain
+                  { postTx = \tx -> do
+                      now <- getCurrentTime
+                      createAndYieldEvent nodes history localChainState $ toOnChainTx now tx
+                  , draftCommitTx = \_ -> error "unexpected call to draftCommitTx"
+                  , submitTx = \_ -> error "unexpected call to submitTx"
+                  }
+              mockNetwork = createMockNetwork draftNode nodes
+              mockServer = Server{sendOutput = const $ pure ()}
+          node <- connect mockChain mockNetwork mockServer draftNode
           atomically $ modifyTVar nodes (node :)
-          pure $
-            node
-              { oc =
-                  Chain
-                    { postTx = \tx -> do
-                        now <- getCurrentTime
-                        createAndYieldEvent nodes history localChainState $ toOnChainTx now tx
-                    , draftCommitTx = \_ -> error "unexpected call to draftCommitTx"
-                    , submitTx = \_ -> error "unexpected call to submitTx"
-                    }
-              , hn = createMockNetwork node nodes
-              }
+          pure node
       , tickThread
       , rollbackAndForward = rollbackAndForward nodes history localChainState
       , simulateCommit = \(party, committed) ->
@@ -685,18 +676,16 @@ simulatedChainAndNetwork initialChainState = do
 handleChainEvent :: HydraNode tx m -> ChainEvent tx -> m ()
 handleChainEvent HydraNode{inputQueue} = enqueue inputQueue . ChainInput
 
-createMockNetwork :: MonadSTM m => HydraNode tx m -> TVar m [HydraNode tx m] -> Network m (Message tx)
+createMockNetwork :: MonadSTM m => DraftHydraNode tx m -> TVar m [HydraNode tx m] -> Network m (Message tx)
 createMockNetwork node nodes =
   Network{broadcast}
  where
   broadcast msg = do
     allNodes <- readTVarIO nodes
-    let otherNodes = filter (\n -> getNodeId n /= getNodeId node) allNodes
+    let otherNodes = filter (\n -> getParty n /= getParty node) allNodes
     mapM_ (`handleMessage` msg) otherNodes
 
-  handleMessage HydraNode{inputQueue} = enqueue inputQueue . NetworkInput defaultTTL (getNodeId node)
-
-  getNodeId HydraNode{env = Environment{party}} = party
+  handleMessage HydraNode{inputQueue} = enqueue inputQueue . NetworkInput defaultTTL (getParty node)
 
 -- | Derive an 'OnChainTx' from 'PostChainTx' to simulate a "perfect" chain.
 -- NOTE: This implementation announces hard-coded contestationDeadlines. Also,
@@ -746,19 +735,18 @@ withHydraNode ::
 withHydraNode signingKey otherParties chain action = do
   outputs <- atomically newTQueue
   outputHistory <- newTVarIO mempty
-  nodeState <- createNodeState Nothing $ Idle IdleState{chainState = SimpleChainState{slot = ChainSlot 0}}
-  node <- createHydraNode traceInIOSim simpleLedger nodeState signingKey otherParties outputs outputHistory chain testContestationPeriod
+  let initialChainState = SimpleChainState{slot = ChainSlot 0}
+  node <- createHydraNode traceInIOSim simpleLedger initialChainState signingKey otherParties outputs outputHistory chain testContestationPeriod
   withAsync (runHydraNode node) $ \_ ->
-    action (createTestHydraClient outputs outputHistory node nodeState)
+    action (createTestHydraClient outputs outputHistory node)
 
 createTestHydraClient ::
   MonadSTM m =>
   TQueue m (ServerOutput tx) ->
   TVar m [ServerOutput tx] ->
   HydraNode tx m ->
-  NodeState tx m ->
   TestHydraClient tx m
-createTestHydraClient outputs outputHistory HydraNode{inputQueue} nodeState =
+createTestHydraClient outputs outputHistory HydraNode{inputQueue, nodeState} =
   TestHydraClient
     { send = enqueue inputQueue . ClientInput
     , waitForNext = atomically (readTQueue outputs)
@@ -768,54 +756,39 @@ createTestHydraClient outputs outputHistory HydraNode{inputQueue} nodeState =
     }
 
 createHydraNode ::
-  (MonadDelay m, MonadAsync m, MonadLabelledSTM m, IsChainState tx) =>
+  (MonadDelay m, MonadAsync m, MonadLabelledSTM m, IsChainState tx, MonadThrow m) =>
   Tracer m (HydraNodeLog tx) ->
   Ledger tx ->
-  NodeState tx m ->
+  ChainStateType tx ->
   SigningKey HydraKey ->
   [Party] ->
   TQueue m (ServerOutput tx) ->
   TVar m [ServerOutput tx] ->
   SimulatedChainNetwork tx m ->
   ContestationPeriod ->
   m (HydraNode tx m)
-createHydraNode tracer ledger nodeState signingKey otherParties outputs outputHistory chain cp = do
-  -- TODO: refactor using 'hydrate'
-  inputQueue <- createInputQueue
+createHydraNode tracer ledger chainState signingKey otherParties outputs outputHistory chain cp = do
   persistence <- createPersistenceInMemory
   (eventSource, eventSink) <- eventPairFromPersistenceIncremental persistence
-
-  connectNode chain $
-    HydraNode
-      { tracer
-      , inputQueue
-      , hn = Network{broadcast = \_ -> pure ()}
-      , nodeState
-      , ledger
-      , oc =
-          Chain
-            { postTx = \_ -> pure ()
-            , draftCommitTx = \_ -> error "unexpected call to draftCommitTx"
-            , submitTx = \_ -> error "unexpected call to submitTx"
-            }
-      , server =
+  node <- connectNode chain =<< hydrate tracer env ledger chainState eventSource [eventSink]
+  pure $
+    node
+      { server =
           Server
             { sendOutput = \out -> atomically $ do
                 writeTQueue outputs out
                 modifyTVar' outputHistory (out :)
             }
-      , env =
-          Environment
-            { party
-            , signingKey
-            , otherParties
-            , contestationPeriod = cp
-            , participants
-            }
-      , eventSource
-      , eventSinks = [eventSink]
       }
  where
+  env =
+    Environment
+      { party
+      , signingKey
+      , otherParties
+      , contestationPeriod = cp
+      , participants
+      }
   party = deriveParty signingKey
 
   -- NOTE: We use the hydra-keys as on-chain identities directly. This is fine

hydra-node/test/Hydra/Model.hs

@@ -59,18 +59,14 @@ import Hydra.Chain.Direct.Fixture (defaultGlobals, defaultLedgerEnv, testNetwork
 import Hydra.Chain.Direct.State (initialChainState)
 import Hydra.ContestationPeriod (ContestationPeriod (UnsafeContestationPeriod))
 import Hydra.Crypto (HydraKey)
-import Hydra.HeadLogic (
-  Committed (),
-  IdleState (..),
- )
-import Hydra.HeadLogic qualified as HeadState
+import Hydra.HeadLogic (Committed ())
 import Hydra.Ledger (IsTx (..))
 import Hydra.Ledger.Cardano (cardanoLedger, genSigningKey, mkSimpleTx)
 import Hydra.Logging (Tracer)
 import Hydra.Logging.Messages (HydraLog (DirectChain, Node))
 import Hydra.Model.MockChain (mockChainAndNetwork)
 import Hydra.Model.Payment (CardanoSigningKey (..), Payment (..), applyTx, genAdaValue)
-import Hydra.Node (createNodeState, runHydraNode)
+import Hydra.Node (runHydraNode)
 import Hydra.Party (Party (..), deriveParty)
 import Hydra.Snapshot qualified as Snapshot
 import Test.Hydra.Prelude (failure)
@@ -587,9 +583,8 @@ seedWorld seedKeys seedCP futureCommits = do
       labelTQueueIO outputs ("outputs-" <> shortLabel hsk)
       outputHistory <- newTVarIO []
       labelTVarIO outputHistory ("history-" <> shortLabel hsk)
-      nodeState <- createNodeState Nothing $ HeadState.Idle IdleState{chainState = initialChainState}
-      node <- createHydraNode (contramap Node tr) ledger nodeState hsk otherParties outputs outputHistory mockChain seedCP
-      let testClient = createTestHydraClient outputs outputHistory node nodeState
+      node <- createHydraNode (contramap Node tr) ledger initialChainState hsk otherParties outputs outputHistory mockChain seedCP
+      let testClient = createTestHydraClient outputs outputHistory node
       nodeThread <- async $ labelThisThread ("node-" <> shortLabel hsk) >> runHydraNode node
       link nodeThread
       pure (testClient, nodeThread)

hydra-node/test/Hydra/Model/MockChain.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# OPTIONS_GHC -Wno-ambiguous-fields #-}
 
 module Hydra.Model.MockChain where
 
@@ -27,9 +28,8 @@ import Data.Sequence qualified as Seq
 import Data.Time (secondsToNominalDiffTime)
 import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
 import GHC.IO.Exception (userError)
-import Hydra.BehaviorSpec (
-  SimulatedChainNetwork (..),
- )
+import Hydra.API.Server (Server (..))
+import Hydra.BehaviorSpec (SimulatedChainNetwork (..))
 import Hydra.Cardano.Api.Pretty (renderTxWithUTxO)
 import Hydra.Chain (
   Chain (..),
@@ -71,9 +71,9 @@ import Hydra.Logging (Tracer)
 import Hydra.Model.Payment (CardanoSigningKey (..))
 import Hydra.Network (Network (..))
 import Hydra.Network.Message (Message)
-import Hydra.Node (HydraNode (..), NodeState (..))
+import Hydra.Node (DraftHydraNode (..), HydraNode (..), NodeState (..), connect)
 import Hydra.Node.InputQueue (InputQueue (..))
-import Hydra.Party (Party (..), deriveParty)
+import Hydra.Party (Party (..), deriveParty, getParty)
 import Hydra.Snapshot (ConfirmedSnapshot (..))
 import Test.QuickCheck (getPositive)
 
@@ -128,13 +128,14 @@ mockChainAndNetwork tr seedKeys commits = do
   -- validating transactions and need to be signing with proper keys.
   -- Consequently the identifiers of participants need to be derived from
   -- the real keys.
-  updateEnvironment HydraNode{env} = do
+  updateEnvironment env = do
     let vks = getVerificationKey . signingKey . snd <$> seedKeys
     env{participants = verificationKeyToOnChainId <$> vks}
 
-  connectNode nodes chain queue node = do
+  connectNode nodes chain queue draftNode = do
     localChainState <- newLocalChainState (initHistory initialChainState)
-    let Environment{party = ownParty} = env node
+    let DraftHydraNode{env} = draftNode
+        Environment{party = ownParty} = env
     let vkey = fst $ findOwnCardanoKey ownParty seedKeys
     let ctx =
           ChainContext
@@ -144,7 +145,7 @@ mockChainAndNetwork tr seedKeys commits = do
             , scriptRegistry
             }
     let getTimeHandle = pure $ fixedTimeHandleIndefiniteHorizon `generateWith` 42
-    let HydraNode{inputQueue = InputQueue{enqueue}} = node
+    let DraftHydraNode{inputQueue = InputQueue{enqueue}} = draftNode
     -- Validate transactions on submission and queue them for inclusion if valid.
     let submitTx tx =
           atomically $ do
@@ -165,28 +166,28 @@ mockChainAndNetwork tr seedKeys commits = do
                     ]
               Right _utxo' ->
                 writeTQueue queue tx
-    let chainHandle =
+    let mockChain =
           createMockChain
             tr
             ctx
             submitTx
             getTimeHandle
             seedInput
             localChainState
-    let chainHandler =
-          chainSyncHandler
-            tr
-            (enqueue . ChainInput)
-            getTimeHandle
-            ctx
-            localChainState
-    let node' =
-          node
-            { hn = createMockNetwork node nodes
-            , oc = chainHandle
-            , env = updateEnvironment node
+        mockServer = Server{sendOutput = const $ pure ()}
+    node <- connect mockChain (createMockNetwork draftNode nodes) mockServer draftNode
+    let node' = (node :: HydraNode Tx m){env = updateEnvironment env}
+    let mockNode =
+          MockHydraNode
+            { node = node'
+            , chainHandler =
+                chainSyncHandler
+                  tr
+                  (enqueue . ChainInput)
+                  getTimeHandle
+                  ctx
+                  localChainState
             }
-    let mockNode = MockHydraNode{node = node', chainHandler}
     atomically $ modifyTVar nodes (mockNode :)
     pure node'
 
@@ -335,18 +336,16 @@ findOwnCardanoKey me seedKeys = fromMaybe (error $ "cannot find cardano key for
   pure (csk, filter (/= csk) $ map (getVerificationKey . signingKey . snd) seedKeys)
 
 -- TODO: unify with BehaviorSpec's ?
-createMockNetwork :: MonadSTM m => HydraNode Tx m -> TVar m [MockHydraNode m] -> Network m (Message Tx)
-createMockNetwork myNode nodes =
+createMockNetwork :: MonadSTM m => DraftHydraNode Tx m -> TVar m [MockHydraNode m] -> Network m (Message Tx)
+createMockNetwork draftNode nodes =
   Network{broadcast}
  where
   broadcast msg = do
     allNodes <- fmap node <$> readTVarIO nodes
-    let otherNodes = filter (\n -> getNodeId n /= getNodeId myNode) allNodes
+    let otherNodes = filter (\n -> getParty n /= getParty draftNode) allNodes
     mapM_ (`handleMessage` msg) otherNodes
 
-  handleMessage HydraNode{inputQueue} = enqueue inputQueue . NetworkInput defaultTTL (getNodeId myNode)
-
-  getNodeId HydraNode{env = Environment{party}} = party
+  handleMessage HydraNode{inputQueue} = enqueue inputQueue . NetworkInput defaultTTL (getParty draftNode)
 
 data MockHydraNode m = MockHydraNode
   { node :: HydraNode Tx m