Add PostCloseTx Model action

hydra-node/test/Hydra/Model.hs

@@ -166,6 +166,7 @@ instance StateModel WorldState where
     -- Check that all parties have observed the head as open
     ObserveHeadIsOpen :: Action WorldState ()
     RollbackAndForward :: Natural -> Action WorldState ()
+    PostCloseTx :: Party -> Action WorldState ()
     StopTheWorld :: Action WorldState ()
 
   initialState =
@@ -186,8 +187,8 @@ instance StateModel WorldState where
           ]
       Open{} ->
         frequency
-          [ (5, genNewTx)
-          , (1, genClose)
+          [ (10, genNewTx)
+          , (1, frequency [(5, genClose), (5, genPostCloseTx)])
           , (1, genRollbackAndForward)
           ]
       Closed{} ->
@@ -202,17 +203,13 @@ instance StateModel WorldState where
       (party, commits) <- elements $ Map.toList pending
       pure . Some $ Commit party commits
 
-    genAbort = do
-      (key, _) <- elements hydraParties
-      let party = deriveParty key
-      pure . Some $ Abort party
+    genAbort =
+      Some . Abort . deriveParty . fst <$> elements hydraParties
 
     genNewTx = genPayment st >>= \(party, transaction) -> pure . Some $ NewTx party transaction
 
-    genClose = do
-      (key, _) <- elements hydraParties
-      let party = deriveParty key
-      pure . Some $ Close party
+    genClose =
+      Some . Close . deriveParty . fst <$> elements hydraParties
 
     genFanout =
       Some . Fanout . deriveParty . fst <$> elements hydraParties
@@ -221,6 +218,9 @@ instance StateModel WorldState where
       numberOfBlocks <- choose (1, 2)
       pure . Some $ RollbackAndForward (wordToNatural numberOfBlocks)
 
+    genPostCloseTx =
+      Some . PostCloseTx . deriveParty . fst <$> elements hydraParties
+
   precondition WorldState{hydraState = Start} Seed{} =
     True
   precondition WorldState{hydraState = Idle{idleParties}} (Init p) =
@@ -241,6 +241,8 @@ instance StateModel WorldState where
     True
   precondition WorldState{hydraState = Closed{}} (Fanout _) =
     True
+  precondition WorldState{hydraState = Open{}} (PostCloseTx _) =
+    True
   precondition WorldState{hydraState} (RollbackAndForward _) =
     case hydraState of
       Start{} -> False
@@ -341,6 +343,12 @@ instance StateModel WorldState where
                     }
               }
           _ -> error "unexpected state"
+      PostCloseTx _ ->
+        WorldState{hydraParties, hydraState = updateWithClose hydraState}
+       where
+        updateWithClose = \case
+          Open{offChainState = OffChainState{confirmedUTxO}} -> Closed confirmedUTxO
+          _ -> error "unexpected state"
       RollbackAndForward _numberOfBlocks -> s
       Wait _ -> s
       ObserveConfirmedTx _ -> s
@@ -541,6 +549,8 @@ instance
           case find headIsOpen outputs of
             Just _ -> pure ()
             Nothing -> error "The head is not open for node"
+      PostCloseTx party ->
+        performCloseTx party
       RollbackAndForward numberOfBlocks ->
         performRollbackAndForward numberOfBlocks
       StopTheWorld ->
@@ -744,6 +754,18 @@ performFanout party = do
     HeadIsFinalized{} -> True
     _otherwise -> False
 
+performCloseTx :: (MonadThrow m, MonadTimer m, MonadDelay m, MonadAsync m) => Party -> RunMonad m ()
+performCloseTx party = do
+  nodes <- gets nodes
+  let thisNode = nodes ! party
+  waitForOpen thisNode
+  SimulatedChainNetwork{postCloseTx} <- gets chain
+  lift $ postCloseTx party
+  lift $
+    waitUntilMatch (toList nodes) $ \case
+      HeadIsClosed{} -> True
+      err@CommandFailed{} -> error $ show err
+      _ -> False
 performRollbackAndForward :: (MonadThrow m, MonadTimer m) => Natural -> RunMonad m ()
 performRollbackAndForward numberOfBlocks = do
   SimulatedChainNetwork{rollbackAndForward} <- gets chain
@@ -802,6 +824,7 @@ showFromAction k = \case
   NewTx{} -> k
   Wait{} -> k
   ObserveConfirmedTx{} -> k
+  PostCloseTx{} -> k
   RollbackAndForward{} -> k
   StopTheWorld -> k
   ObserveHeadIsOpen -> k

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

@@ -221,7 +221,7 @@ mockChainAndNetwork tr seedKeys commits = do
           } -> do
           hs <- atomically queryHeadState
           case hs of
-            Idle IdleState{} -> error "Cannot post Close tx when in Initial state"
+            Idle IdleState{} -> error "Cannot post Close tx when in Idle state"
             Initial InitialState{} -> error "Cannot post Close tx when in Initial state"
             Open OpenState{headId = openHeadId, parameters = headParameters, coordinatedHeadState = CoordinatedHeadState{confirmedSnapshot}} -> do
               let closeTx = CloseTx{headId = openHeadId, headParameters, confirmedSnapshot}