Enable intermittent rollbacks in MockChain

This only passes the Model based tests as we disable arbitrary
generation of NewTx payments in an open head. The rollbacks would trip
the model when the hydra-node purges its state when rolling back "past
open".

However, we can still have basic conflict-free liveness tested and
exercise the rollback handling code in between Init/Commit/Open states.

hydra-node/test/Hydra/Model.hs

@@ -191,7 +191,12 @@ instance StateModel WorldState where
           [ (5, genCommit pendingCommits)
           , (1, genAbort)
           ]
-      Open{} -> genNewTx
+      Open{} -> do
+        -- FIXME: Generation of arbitrary NewTx disabled as we don't control
+        -- rollbacks in the MockChain and the hydra-node purges L2 state when
+        -- rolling back "past open".
+        void genNewTx
+        pure $ Error "NewTx disabled because of rollbacks past open"
       _ -> fmap Some genSeed
    where
     genCommit pending = do
@@ -587,16 +592,7 @@ performNewTx party tx = do
   nodes <- gets nodes
   let thisNode = nodes ! party
 
-  let waitForOpen = do
-        outs <- lift $ serverOutputs thisNode
-        -- TODO refactor with headIsOpen
-        let matchHeadIsOpen = \case
-              HeadIsOpen{} -> True
-              _ -> False
-        case find matchHeadIsOpen outs of
-          Nothing -> lift (threadDelay 0.1) >> waitForOpen
-          Just{} -> pure ()
-  waitForOpen
+  waitForOpen thisNode
 
   (i, o) <-
     lift (waitForUTxOToSpend mempty (from tx) (value tx) thisNode) >>= \case
@@ -618,6 +614,31 @@ performNewTx party tx = do
       err@TxInvalid{} -> error ("expected tx to be valid: " <> show err)
       _ -> False
 
+-- | Wait for the head to be open. Search from the beginning of history and make
+-- sure there is no RolledBack after the last HeadIsOpen. Wait and retry forever
+-- otherwise.
+waitForOpen :: MonadDelay m => TestHydraNode tx m -> RunMonad m ()
+waitForOpen node = do
+  outs <- lift $ serverOutputs node
+  go outs
+ where
+  go = \case
+    [] -> waitAndRetry
+    (x : xs) -> case x of
+      HeadIsOpen{}
+        | not $ containsRolledBack xs -> found
+      _ -> go xs
+
+  containsRolledBack = any matchRolledBack
+
+  found = pure ()
+
+  waitAndRetry = lift (threadDelay 0.1) >> waitForOpen node
+
+  matchRolledBack = \case
+    RolledBack{} -> True
+    _ -> False
+
 sendsInput :: (MonadSTM m, MonadThrow m) => Party -> ClientInput Tx -> RunMonad m ()
 sendsInput party command = do
   nodes <- gets nodes

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

@@ -175,19 +175,16 @@ mockChainAndNetwork tr seedKeys nodes cp = do
         atomically $ writeTVar chain (slotNum, position + 1, blocks)
       Nothing ->
         pure ()
-  sendRollBackward chain nbBlocks =
-    if False --inhibiting the rollback until we can support it in the code
-      then do
-        (slotNum, position, blocks) <- atomically $ readTVar chain
-        case Seq.lookup (position - nbBlocks) blocks of
-          Just block -> do
-            allHandlers <- fmap chainHandler <$> readTVarIO nodes
-            let point = blockPoint block
-            forM_ allHandlers (`onRollBackward` point)
-            atomically $ writeTVar chain (slotNum, position - nbBlocks + 1, blocks)
-          Nothing ->
-            pure ()
-      else pure ()
+  sendRollBackward chain nbBlocks = do
+    (slotNum, position, blocks) <- atomically $ readTVar chain
+    case Seq.lookup (position - nbBlocks) blocks of
+      Just block -> do
+        allHandlers <- fmap chainHandler <$> readTVarIO nodes
+        let point = blockPoint block
+        forM_ allHandlers (`onRollBackward` point)
+        atomically $ writeTVar chain (slotNum, position - nbBlocks + 1, blocks)
+      Nothing ->
+        pure ()
 
   addNewBlockToChain chain transactions =
     atomically $ modifyTVar chain $ \(slotNum, position, blocks) -> appendToChain (mkBlock transactions (fromIntegral $ slotNum + blockTime) (fromIntegral position)) (slotNum + blockTime, position, blocks)