diff --git a/hydra-node/test/Hydra/Model.hs b/hydra-node/test/Hydra/Model.hs index 44940623a7b..c1aa7fedd03 100644 --- a/hydra-node/test/Hydra/Model.hs +++ b/hydra-node/test/Hydra/Model.hs @@ -186,7 +186,7 @@ instance StateModel WorldState where ] Open{} -> frequency - [ (5, genNewTx) + [ (1, genNewTx) , (1, genClose) , (1, genRollbackAndForward) ] diff --git a/hydra-node/test/Hydra/Model/MockChain.hs b/hydra-node/test/Hydra/Model/MockChain.hs index c35eaf60aef..f5ea6d1b666 100644 --- a/hydra-node/test/Hydra/Model/MockChain.hs +++ b/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.