From 18c761b22a0bb42230349b254151569ca89ac4cd Mon Sep 17 00:00:00 2001
From: Sebastian Nagel <sebastian.nagel@ncoding.at>
Date: Fri, 21 Apr 2023 16:26:51 +0200
Subject: [PATCH] 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           | 43 ++++++++++++++++++------
 hydra-node/test/Hydra/Model/MockChain.hs | 23 ++++++-------
 2 files changed, 42 insertions(+), 24 deletions(-)

diff --git a/hydra-node/test/Hydra/Model.hs b/hydra-node/test/Hydra/Model.hs
index a15776e6f74..f114324689e 100644
--- a/hydra-node/test/Hydra/Model.hs
+++ b/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
diff --git a/hydra-node/test/Hydra/Model/MockChain.hs b/hydra-node/test/Hydra/Model/MockChain.hs
index f91fc905d10..3345dc25ac8 100644
--- a/hydra-node/test/Hydra/Model/MockChain.hs
+++ b/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)