[DEBUG] Add traces and improve error output

Uses throwSTM to actually throw an exception and not to error when
showing the trace.

hydra-node/test/Hydra/Model.hs

@@ -186,7 +186,7 @@ instance StateModel WorldState where
           ]
       Open{} ->
         frequency
-          [ (5, genNewTx)
+          [ (1, genNewTx)
           , (1, genClose)
           , (1, genRollbackAndForward)
           ]

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

@@ -15,6 +15,7 @@ import Control.Concurrent.Class.MonadSTM (
   newTQueueIO,
   newTVarIO,
   readTVarIO,
+  throwSTM,
   tryReadTQueue,
   writeTQueue,
   writeTVar,
@@ -25,6 +26,7 @@ import Data.Sequence (Seq (Empty, (:|>)))
 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 (..),
  )
@@ -45,7 +47,7 @@ import Hydra.Chain.Direct.Handlers (
 import Hydra.Chain.Direct.ScriptRegistry (genScriptRegistry, registryUTxO)
 import Hydra.Chain.Direct.State (ChainContext (..), initialChainState)
 import Hydra.Chain.Direct.TimeHandle (TimeHandle, mkTimeHandle)
-import Hydra.Chain.Direct.Tx (verificationKeyToOnChainId)
+import Hydra.Chain.Direct.Tx (getHydraHeadV1TxName, verificationKeyToOnChainId)
 import Hydra.Chain.Direct.Wallet (TinyWallet (..))
 import Hydra.Crypto (HydraKey)
 import Hydra.HeadLogic (
@@ -145,17 +147,19 @@ mockChainAndNetwork tr seedKeys commits = do
             -- TODO: dry with block tx validation
             case evaluateTx tx utxo of
               Left err ->
-                error $
+                throwSTM . userError . toString $
                   unlines
-                    [ "Invalid tx submitted: " <> show err
+                    [ "Invalid tx submitted"
                     , "Tx: " <> toText (renderTxWithUTxO utxo tx)
+                    , "Error: " <> show err
                     ]
               Right report
                 | any isLeft report ->
-                    error $
+                    throwSTM . userError . toString $
                       unlines
-                        [ "Invalid tx submitted: " <> show (lefts . toList $ report)
+                        [ "Invalid tx submitted"
                         , "Tx: " <> toText (renderTxWithUTxO utxo tx)
+                        , "Error: " <> show (lefts . toList $ report)
                         ]
                 | otherwise ->
                     writeTQueue queue tx
@@ -212,7 +216,7 @@ mockChainAndNetwork tr seedKeys commits = do
   blockTime = 20
 
   simulateChain nodes chain queue =
-    forever $ rollForward nodes chain queue
+    trace "====================================" forever $ rollForward nodes chain queue
 
   rollForward nodes chain queue = do
     threadDelay blockTime
@@ -225,9 +229,11 @@ mockChainAndNetwork tr seedKeys commits = do
     (slotNum, position, blocks, _) <- readTVarIO chain
     case Seq.lookup (fromIntegral position) blocks of
       Just (header, txs, utxo) -> do
+        let position' = position + 1
         allHandlers <- fmap chainHandler <$> readTVarIO nodes
-        forM_ allHandlers (\h -> onRollForward h header txs)
-        atomically $ writeTVar chain (slotNum, position + 1, blocks, utxo)
+        trace ("forward: " <> show position <> " -> " <> show position' <> ", " <> show (txs <&> getHydraHeadV1TxName)) $
+          forM_ allHandlers (\h -> onRollForward h header txs)
+        atomically $ writeTVar chain (slotNum, position', blocks, utxo)
       Nothing ->
         pure ()
 
@@ -240,10 +246,12 @@ mockChainAndNetwork tr seedKeys commits = do
     (slotNum, position, blocks, _) <- readTVarIO chain
     case Seq.lookup (fromIntegral $ position - nbBlocks) blocks of
       Just (header, _, utxo) -> do
+        let position' = position - nbBlocks + 1
         allHandlers <- fmap chainHandler <$> readTVarIO nodes
         let point = getChainPoint header
-        forM_ allHandlers (`onRollBackward` point)
-        atomically $ writeTVar chain (slotNum, position - nbBlocks + 1, blocks, utxo)
+        trace ("backward: " <> show position <> " -> " <> show position') $
+          forM_ allHandlers (`onRollBackward` point)
+        atomically $ writeTVar chain (slotNum, position', blocks, utxo)
       Nothing ->
         pure ()
 
@@ -263,6 +271,8 @@ mockChainAndNetwork tr seedKeys commits = do
                     <> "\nUTxO:\n"
                     <> show (fst <$> pairs utxo)
             Right utxo' ->
+              -- FIXME: this includes all transactions even if only one of them
+              -- would apply (e.g. concurrent collect transactions in Hydra)
               (newSlot, position, blocks :|> (header, transactions, utxo'), utxo')
 
 -- | Construct fixed 'TimeHandle' that starts from 0 and has the era horizon far in the future.