Fix recording of server outputs in TestHydraNode

input-output-hk · Jun 22, 2022 · 1cb03f8 · 1cb03f8
1 parent 139da3a
commit 1cb03f8
Show file tree

Hide file tree

Showing 3 changed files with 39 additions and 30 deletions.
diff --git a/hydra-node/test/Hydra/BehaviorSpec.hs b/hydra-node/test/Hydra/BehaviorSpec.hs
@@ -542,48 +542,45 @@ withHydraNode ::
   IOSim s a
 withHydraNode signingKey otherParties connectToChain action = do
   outputs <- atomically newTQueue
-  node <- createHydraNode simpleLedger signingKey otherParties outputs connectToChain
-
+  outputHistory <- newTVarIO mempty
+  node <- createHydraNode simpleLedger signingKey otherParties outputs outputHistory connectToChain
   withAsync (runHydraNode traceInIOSim node) $ \_ ->
-    createTestHydraNode outputs node connectToChain >>= action
+    action $ createTestHydraNode outputs outputHistory node connectToChain
 
 createTestHydraNode ::
   (MonadSTM m, MonadThrow m) =>
   TQueue m (ServerOutput tx) ->
+  TVar m [ServerOutput tx] ->
   HydraNode tx m ->
   ConnectToChain tx m ->
-  m (TestHydraNode tx m)
-createTestHydraNode outputs node ConnectToChain{history} = do
-  outputHistory <- newTVarIO mempty
-  pure
-    TestHydraNode
-      { send = handleClientInput node
-      , chainEvent = \e -> do
-          toReplay <- case e of
-            Rollback (fromIntegral -> n) -> do
-              atomically $ do
-                (toReplay, kept) <- splitAt n <$> readTVar history
-                toReplay <$ writeTVar history kept
-            _ ->
-              pure []
-          handleChainTx node e
-          mapM_ (postTx (oc node)) (reverse toReplay)
-      , waitForNext = atomically $ do
-          out <- readTQueue outputs
-          modifyTVar' outputHistory (out :)
-          pure out
-      , serverOutputs = reverse <$> readTVarIO outputHistory
-      }
+  TestHydraNode tx m
+createTestHydraNode outputs outputHistory node ConnectToChain{history} =
+  TestHydraNode
+    { send = handleClientInput node
+    , chainEvent = \e -> do
+        toReplay <- case e of
+          Rollback (fromIntegral -> n) -> do
+            atomically $ do
+              (toReplay, kept) <- splitAt n <$> readTVar history
+              toReplay <$ writeTVar history kept
+          _ ->
+            pure []
+        handleChainTx node e
+        mapM_ (postTx (oc node)) (reverse toReplay)
+    , waitForNext = atomically (readTQueue outputs)
+    , serverOutputs = reverse <$> readTVarIO outputHistory
+    }
 
 createHydraNode ::
   (MonadDelay m, MonadAsync m) =>
   Ledger tx ->
   Hydra.SigningKey ->
   [Party] ->
   TQueue m (ServerOutput tx) ->
+  TVar m [ServerOutput tx] ->
   ConnectToChain tx m ->
   m (HydraNode tx m)
-createHydraNode ledger signingKey otherParties outputs connectToChain = do
+createHydraNode ledger signingKey otherParties outputs outputHistory connectToChain = do
   eq <- createEventQueue
   hh <- createHydraHead IdleState ledger
   chainComponent connectToChain $
@@ -592,7 +589,12 @@ createHydraNode ledger signingKey otherParties outputs connectToChain = do
       , hn = Network{broadcast = const $ pure ()}
       , hh
       , oc = Chain (const $ pure ())
-      , server = Server{sendOutput = atomically . writeTQueue outputs}
+      , server =
+          Server
+            { sendOutput = \out -> atomically $ do
+                writeTQueue outputs out
+                modifyTVar' outputHistory (out :)
+            }
       , env =
           Environment
             { party = deriveParty signingKey

diff --git a/hydra-node/test/Hydra/Model.hs b/hydra-node/test/Hydra/Model.hs
@@ -237,8 +237,9 @@ instance
       connectToChain <- simulatedChainAndNetwork
       forM seedKeys $ \(sk, _csk) -> do
         outputs <- atomically newTQueue
-        node <- createHydraNode ledger sk parties outputs connectToChain
-        testNode <- createTestHydraNode outputs node connectToChain
+        outputHistory <- newTVarIO []
+        node <- createHydraNode ledger sk parties outputs outputHistory connectToChain
+        let testNode = createTestHydraNode outputs outputHistory node connectToChain
         void $ async $ runHydraNode (traceInTVar tvar) node
         pure (deriveParty sk, testNode)
 

diff --git a/hydra-node/test/Hydra/ModelSpec.hs b/hydra-node/test/Hydra/ModelSpec.hs
@@ -67,16 +67,22 @@ instance Arbitrary AnyActions where
 unsafeCoerceActions :: Actions (WorldState (IOSim s)) -> Actions (WorldState (IOSim s'))
 unsafeCoerceActions = unsafeCoerce
 
+-- NOTE: This is only sound to run in IOSim, because delays are instant. It
+-- allows to make sure we wait long-enough for remaining asynchronous actions /
+-- events to complete before we make any test assertion.
+waitUntilTheEndOfTime :: MonadDelay m => m ()
+waitUntilTheEndOfTime = threadDelay 1000000000000
+
 prop_checkModel :: AnyActions -> Property
 prop_checkModel (AnyActions actions) =
   property $
     runIOSimProp $
       monadic' $ do
         (WorldState world, _symEnv) <- runActions' actions
+        run $ lift waitUntilTheEndOfTime
         let parties = Map.keysSet world
         nodes <- run get
         assert (parties == Map.keysSet nodes)
-
         forM_ parties $ \p -> do
           let st = world ! p
           let node = nodes ! p