diff --git a/hydra-node/hydra-node.cabal b/hydra-node/hydra-node.cabal index 3f0055b1024..4c8503a057d 100644 --- a/hydra-node/hydra-node.cabal +++ b/hydra-node/hydra-node.cabal @@ -368,6 +368,7 @@ test-suite tests , regex-tdfa , req , silently + , temporary , text , time , typed-protocols-examples >=0.1.0.0 diff --git a/hydra-node/src/Hydra/Ledger.hs b/hydra-node/src/Hydra/Ledger.hs index d2ac62a3d8d..5d05db9179d 100644 --- a/hydra-node/src/Hydra/Ledger.hs +++ b/hydra-node/src/Hydra/Ledger.hs @@ -74,13 +74,13 @@ data Ledger tx = Ledger UTxOType tx -> [tx] -> Either (tx, ValidationError) (UTxOType tx) - -- ^ Apply a set of transaction to a given UTXO set. Returns the new UTXO or + -- ^ Apply a set of transaction to a given UTxO set. Returns the new UTxO or -- validation failures returned from the ledger. -- TODO: 'ValidationError' should also include the UTxO, which is not -- necessarily the same as the given UTxO after some transactions , initUTxO :: UTxOType tx - -- ^ Generates an initial UTXO set. This is only temporary as it does not - -- allow to initialize the UTXO. + -- ^ Generates an initial UTxO set. This is only temporary as it does not + -- allow to initialize the UTxO. -- -- TODO: This seems redundant with the `Monoid (UTxOType tx)` constraints -- coming with `IsTx`. We probably want to dry this out. @@ -90,6 +90,17 @@ canApply :: Ledger tx -> ChainSlot -> UTxOType tx -> tx -> ValidationResult canApply ledger slot utxo tx = either (Invalid . snd) (const Valid) $ applyTransactions ledger slot utxo (pure tx) +-- | Collect applicable transactions and resulting UTxO. In contrast to +-- 'applyTransactions', this functions continues on validation errors. +collectTransactions :: Ledger tx -> ChainSlot -> UTxOType tx -> [tx] -> ([tx], UTxOType tx) +collectTransactions Ledger{applyTransactions} slot utxo = + foldr go ([], utxo) + where + go tx (applicableTxs, u) = + case applyTransactions slot u [tx] of + Left _ -> (applicableTxs, u) + Right u' -> (applicableTxs <> [tx], u') + -- | Either valid or an error which we get from the ledger-specs tx validation. data ValidationResult = Valid diff --git a/hydra-node/test/Hydra/Ledger/CardanoSpec.hs b/hydra-node/test/Hydra/Ledger/CardanoSpec.hs index 7d5add2d3fa..b1bd3e38ae1 100644 --- a/hydra-node/test/Hydra/Ledger/CardanoSpec.hs +++ b/hydra-node/test/Hydra/Ledger/CardanoSpec.hs @@ -2,6 +2,7 @@ module Hydra.Ledger.CardanoSpec where +import Cardano.Api.UTxO (fromApi, toApi) import Hydra.Cardano.Api import Hydra.Prelude import Test.Hydra.Prelude @@ -56,6 +57,8 @@ spec = \ \"value\":{\"lovelace\":14}}}" shouldParseJSONAs @UTxO bs + prop "Roundtrip to and from Api" roundtripFromAndToApi + describe "ProtocolParameters" $ prop "Roundtrip JSON encoding" roundtripProtocolParameters @@ -107,6 +110,10 @@ shouldParseJSONAs bs = Left err -> failure err Right (_ :: a) -> pure () +roundtripFromAndToApi :: UTxO -> Property +roundtripFromAndToApi utxo = + fromApi (toApi utxo) === utxo + -- | Test that the 'ProtocolParameters' To/FromJSON instances to roundtrip. Note -- that we use the ledger 'PParams' type to generate values, but the cardano-api -- type 'ProtocolParameters' is used for the serialization. diff --git a/hydra-node/test/Hydra/Model.hs b/hydra-node/test/Hydra/Model.hs index 51c13ba2275..a871f1abb72 100644 --- a/hydra-node/test/Hydra/Model.hs +++ b/hydra-node/test/Hydra/Model.hs @@ -223,12 +223,12 @@ instance StateModel WorldState where precondition WorldState{hydraState = Start} Seed{} = True - precondition WorldState{hydraState = Idle{}} Init{} = - True - precondition WorldState{hydraState = hydraState@Initial{}} (Commit party _) = - isPendingCommitFrom party hydraState - precondition WorldState{hydraState = Initial{}} Abort{} = - True + precondition WorldState{hydraState = Idle{idleParties}} (Init p) = + p `elem` idleParties + precondition WorldState{hydraState = Initial{pendingCommits}} (Commit party _) = + party `Map.member` pendingCommits + precondition WorldState{hydraState = Initial{commits, pendingCommits}} (Abort party) = + party `Set.member` (Map.keysSet pendingCommits <> Map.keysSet commits) precondition WorldState{hydraState = Open{}} (Close _) = True precondition WorldState{hydraState = Open{offChainState}} (NewTx _ tx) = @@ -347,6 +347,14 @@ instance StateModel WorldState where ObserveHeadIsOpen -> s StopTheWorld -> s + shrinkAction _ctx _st = \case + seed@Seed{seedKeys, toCommit} -> + [ Some seed{seedKeys = seedKeys', toCommit = toCommit'} + | seedKeys' <- shrink seedKeys + , let toCommit' = Map.filterWithKey (\p _ -> p `elem` (deriveParty . fst <$> seedKeys')) toCommit + ] + _other -> [] + instance HasVariables WorldState where getAllVariables _ = mempty @@ -383,16 +391,6 @@ genInit hydraParties = do let party = deriveParty key pure $ Init party -genCommit' :: - [(SigningKey HydraKey, CardanoSigningKey)] -> - (SigningKey HydraKey, CardanoSigningKey) -> - Gen (Action WorldState [(CardanoSigningKey, Value)]) -genCommit' hydraParties hydraParty = do - let (_, sk) = fromJust $ find (== hydraParty) hydraParties - value <- genAdaValue - let utxo = [(sk, value)] - pure $ Commit (deriveParty . fst $ hydraParty) utxo - genPayment :: WorldState -> Gen (Party, Payment) genPayment WorldState{hydraParties, hydraState} = case hydraState of @@ -609,17 +607,18 @@ performCommit parties party paymentUTxO = do SimulatedChainNetwork{simulateCommit} <- gets chain case Map.lookup party nodes of Nothing -> throwIO $ UnexpectedParty party - Just actorNode -> do + Just{} -> do let realUTxO = toRealUTxO paymentUTxO lift $ simulateCommit (party, realUTxO) observedUTxO <- lift $ - waitMatch actorNode $ \case - Committed{party = cp, utxo = committedUTxO} - | cp == party -> Just committedUTxO - err@CommandFailed{} -> error $ show err - _ -> Nothing - pure $ fromUtxo observedUTxO + forM nodes $ \n -> + waitMatch n $ \case + Committed{party = cp, utxo = committedUTxO} + | cp == party, committedUTxO == realUTxO -> Just committedUTxO + err@CommandFailed{} -> error $ show err + _ -> Nothing + pure $ fromUtxo $ List.head $ toList observedUTxO where fromUtxo :: UTxO -> [(CardanoSigningKey, Value)] fromUtxo utxo = findSigningKey . (txOutAddress &&& txOutValue) . snd <$> pairs utxo diff --git a/hydra-node/test/Hydra/Model/MockChain.hs b/hydra-node/test/Hydra/Model/MockChain.hs index 421a45369e3..fc62f74e010 100644 --- a/hydra-node/test/Hydra/Model/MockChain.hs +++ b/hydra-node/test/Hydra/Model/MockChain.hs @@ -5,7 +5,7 @@ module Hydra.Model.MockChain where import Hydra.Cardano.Api import Hydra.Prelude hiding (Any, label) -import Cardano.Api.UTxO (fromPairs, pairs) +import Cardano.Api.UTxO (fromPairs) import Control.Concurrent.Class.MonadSTM ( MonadLabelledSTM, MonadSTM (newTVarIO, writeTVar), @@ -15,6 +15,7 @@ import Control.Concurrent.Class.MonadSTM ( newTQueueIO, newTVarIO, readTVarIO, + throwSTM, tryReadTQueue, writeTQueue, writeTVar, @@ -25,9 +26,11 @@ 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 (..), ) +import Hydra.Cardano.Api.Pretty (renderTxWithUTxO) import Hydra.Chain (Chain (..), initHistory) import Hydra.Chain.Direct.Fixture (testNetworkId) import Hydra.Chain.Direct.Handlers ( @@ -52,8 +55,14 @@ import Hydra.HeadLogic ( Event (..), defaultTTL, ) -import Hydra.HeadLogic.State (ClosedState (..), HeadState (..), IdleState (..), InitialState (..), OpenState (..)) -import Hydra.Ledger (ChainSlot (..), Ledger (..), txId) +import Hydra.HeadLogic.State ( + ClosedState (..), + HeadState (..), + IdleState (..), + InitialState (..), + OpenState (..), + ) +import Hydra.Ledger (ChainSlot (..), Ledger (..), ValidationError (..), collectTransactions) import Hydra.Ledger.Cardano (adjustUTxO, fromChainSlot, genTxOutAdaOnly) import Hydra.Ledger.Cardano.Evaluate (eraHistoryWithoutHorizon, evaluateTx) import Hydra.Logging (Tracer) @@ -92,7 +101,7 @@ mockChainAndNetwork tr seedKeys commits = do link tickThread pure SimulatedChainNetwork - { connectNode = connectNode nodes queue + { connectNode = connectNode nodes chain queue , tickThread , rollbackAndForward = rollbackAndForward nodes chain , simulateCommit = simulateCommit nodes @@ -117,7 +126,7 @@ mockChainAndNetwork tr seedKeys commits = do let vks = getVerificationKey . signingKey . snd <$> seedKeys env{participants = verificationKeyToOnChainId <$> vks} - connectNode nodes queue node = do + connectNode nodes chain queue node = do localChainState <- newLocalChainState (initHistory initialChainState) let Environment{party = ownParty} = env node let vkey = fst $ findOwnCardanoKey ownParty seedKeys @@ -130,12 +139,25 @@ mockChainAndNetwork tr seedKeys commits = do } let getTimeHandle = pure $ fixedTimeHandleIndefiniteHorizon `generateWith` 42 let HydraNode{eq = EventQueue{putEvent}} = node - let - -- NOTE: this very simple function put the transaction in a queue for - -- inclusion into the chain. We could want to simulate the local - -- submission of a transaction and the possible failures it introduces, - -- perhaps caused by the node lagging behind - submitTx = atomically . writeTQueue queue + -- Validate transactions on submission and queue them for inclusion if valid. + let submitTx tx = + atomically $ do + -- NOTE: Determine the current "view" on the chain (important while + -- rolled back, before new roll forwards were issued) + (slot, position, blocks, globalUTxO) <- readTVar chain + let utxo = case Seq.lookup (fromIntegral position) blocks of + Nothing -> globalUTxO + Just (_, _, blockUTxO) -> blockUTxO + case applyTransactions slot utxo [tx] of + Left (_tx, err) -> + throwSTM . userError . toString $ + unlines + [ "MockChain: Invalid tx submitted" + , "Tx: " <> toText (renderTxWithUTxO utxo tx) + , "Error: " <> show err + ] + Right _utxo' -> + writeTQueue queue tx let chainHandle = createMockChain tr @@ -202,12 +224,20 @@ 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 + -- NOTE: Need to reset the mocked chain ledger to this utxo before + -- calling the node handlers (as they might submit transactions + -- directly). + atomically $ writeTVar chain (slotNum, position', blocks, utxo) forM_ allHandlers (\h -> onRollForward h header txs) - atomically $ writeTVar chain (slotNum, position + 1, blocks, utxo) Nothing -> pure () + -- XXX: This should actually work more like a chain fork / switch to longer + -- chain. That is, the ledger switches to the longer chain state right away + -- and we issue rollback and forwards to synchronize clients. However, + -- submission will already validate against the new ledger state. rollbackAndForward nodes chain numberOfBlocks = do doRollBackward nodes chain numberOfBlocks replicateM_ (fromIntegral numberOfBlocks) $ @@ -217,29 +247,25 @@ 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 + atomically $ writeTVar chain (slotNum, position', blocks, utxo) forM_ allHandlers (`onRollBackward` point) - atomically $ writeTVar chain (slotNum, position - nbBlocks + 1, blocks, utxo) Nothing -> pure () addNewBlockToChain chain transactions = - modifyTVar chain $ \(slotNum, position, blocks, utxo) -> + modifyTVar chain $ \(slotNum, position, blocks, utxo) -> do -- NOTE: Assumes 1 slot = 1 second let newSlot = slotNum + ChainSlot (truncate blockTime) header = genBlockHeaderAt (fromChainSlot newSlot) `generateWith` 42 - in case applyTransactions newSlot utxo transactions of - Left err -> - error $ - toText $ - "On-chain transactions are not supposed to fail: " - <> show err - <> "\nTx:\n" - <> (show @String $ txId <$> transactions) - <> "\nUTxO:\n" - <> show (fst <$> pairs utxo) - Right utxo' -> (newSlot, position, blocks :|> (header, transactions, utxo), utxo') + -- NOTE: Transactions that do not apply to the current state (eg. + -- UTxO) are silently dropped which emulates the chain behaviour that + -- only the client is potentially witnessing the failure, and no + -- invalid transaction will ever be included in the chain. + (txs', utxo') = collectTransactions ledger newSlot utxo transactions + in (newSlot, position, blocks :|> (header, txs', utxo'), utxo') -- | Construct fixed 'TimeHandle' that starts from 0 and has the era horizon far in the future. -- This is used in our 'Model' tests and we want to make sure the tests finish before @@ -264,19 +290,20 @@ scriptLedger seedInput = where initUTxO = fromPairs [(seedInput, (arbitrary >>= genTxOutAdaOnly) `generateWith` 42)] - applyTransactions slot utxo = \case + -- XXX: We could easily add 'slot' validation here and this would already + -- emulate the dropping of outdated transactions from the cardano-node + -- mempool. + applyTransactions !slot utxo = \case [] -> Right utxo (tx : txs) -> case evaluateTx tx utxo of - Left _ -> - -- Transactions that do not apply to the current state (eg. UTxO) are - -- silently dropped which emulates the chain behaviour that only the - -- client is potentially witnessing the failure, and no invalid - -- transaction will ever be included in the chain - applyTransactions slot utxo txs - Right _ -> - let utxo' = adjustUTxO tx utxo - in applyTransactions slot utxo' txs + Left err -> + Left (tx, ValidationError{reason = show err}) + Right report + | any isLeft report -> + Left (tx, ValidationError{reason = show . lefts $ toList report}) + | otherwise -> + applyTransactions slot (adjustUTxO tx utxo) txs -- | Find Cardano vkey corresponding to our Hydra vkey using signing keys lookup. -- This is a bit cumbersome and a tribute to the fact the `HydraNode` itself has no diff --git a/hydra-node/test/Hydra/ModelSpec.hs b/hydra-node/test/Hydra/ModelSpec.hs index d7940889c1c..614edc867a4 100644 --- a/hydra-node/test/Hydra/ModelSpec.hs +++ b/hydra-node/test/Hydra/ModelSpec.hs @@ -121,6 +121,7 @@ import Control.Monad.IOSim (Failure (FailureException), IOSim, runSimTrace, trac import Data.Map ((!)) import Data.Map qualified as Map import Data.Set qualified as Set +import GHC.IO (unsafePerformIO) import Hydra.API.ClientInput (ClientInput (..)) import Hydra.API.ServerOutput (ServerOutput (..)) import Hydra.BehaviorSpec (TestHydraClient (..), dummySimulatedChainNetwork) @@ -134,7 +135,6 @@ import Hydra.Model ( RunMonad, RunState (..), WorldState (..), - genCommit', genInit, genPayment, genSeed, @@ -145,7 +145,8 @@ import Hydra.Model ( import Hydra.Model qualified as Model import Hydra.Model.Payment qualified as Payment import Hydra.Party (Party (..), deriveParty) -import Test.QuickCheck (Property, Testable, counterexample, forAll, property, withMaxSuccess, within) +import System.IO.Temp (writeSystemTempFile) +import Test.QuickCheck (Property, Testable, counterexample, forAllShrink, property, withMaxSuccess, within) import Test.QuickCheck.DynamicLogic ( DL, Quantification, @@ -179,7 +180,7 @@ spec = do -- See https://github.com/input-output-hk/cardano-ledger/blob/master/doc/explanations/min-utxo-mary.rst prop "model should not generate 0 Ada UTxO" $ withMaxSuccess 10000 prop_doesNotGenerate0AdaUTxO prop "model generates consistent traces" $ withMaxSuccess 10000 prop_generateTraces - prop "implementation respects model" $ forAll arbitrary prop_checkModel + prop "implementation respects model" prop_checkModel prop "check conflict-free liveness" prop_checkConflictFreeLiveness prop "check head opens if all participants commit" prop_checkHeadOpensIfAllPartiesCommit prop "fanout contains whole confirmed UTxO" prop_fanoutContainsWholeConfirmedUTxO @@ -219,20 +220,30 @@ prop_checkHeadOpensIfAllPartiesCommit = headOpensIfAllPartiesCommit :: DL WorldState () headOpensIfAllPartiesCommit = do - _ <- seedTheWorld - _ <- initHead + seedTheWorld + initHead everybodyCommit - void $ eventually' ObserveHeadIsOpen + eventually' ObserveHeadIsOpen where - eventually' a = action (Wait 1000) >> action a - seedTheWorld = forAllQ (withGenQ genSeed (const [])) >>= action + eventually' a = action (Wait 1000) >> action_ a + + seedTheWorld = forAllNonVariableQ (withGenQ genSeed (const [])) >>= action_ + initHead = do WorldState{hydraParties} <- getModelStateDL - forAllQ (withGenQ (genInit hydraParties) (const [])) >>= action + forAllQ (withGenQ (genInit hydraParties) (const [])) >>= action_ + everybodyCommit = do - WorldState{hydraParties} <- getModelStateDL - forM_ hydraParties $ \party -> - forAllQ (withGenQ (genCommit' hydraParties party) (const [])) >>= action + WorldState{hydraParties, hydraState} <- getModelStateDL + case hydraState of + Initial{pendingCommits} -> + forM_ hydraParties $ \p -> do + let party = deriveParty (fst p) + case Map.lookup party pendingCommits of + Nothing -> pure () + Just utxo -> + void $ action $ Model.Commit party utxo + _ -> pure () prop_checkConflictFreeLiveness :: Property prop_checkConflictFreeLiveness = @@ -282,22 +293,23 @@ prop_doesNotGenerate0AdaUTxO (Actions actions) = _anyOtherStep -> False contains0Ada = (== lovelaceToValue 0) . snd -prop_checkModel :: Actions WorldState -> Property -prop_checkModel actions = +prop_checkModel :: Property +prop_checkModel = within 30000000 $ - runIOSimProp $ do - (metadata, _symEnv) <- runActions actions - let WorldState{hydraParties, hydraState} = underlyingState metadata - -- XXX: This wait time is arbitrary and corresponds to 3 "blocks" from - -- the underlying simulated chain which produces a block every 20s. It - -- should be enough to ensure all nodes' threads terminate their actions - -- and those gets picked up by the chain - run $ lift waitForAMinute - let parties = Set.fromList $ deriveParty . fst <$> hydraParties - nodes <- run $ gets nodes - assert (parties == Map.keysSet nodes) - forM_ parties $ \p -> do - assertBalancesInOpenHeadAreConsistent hydraState nodes p + forAllShrink arbitrary shrink $ \actions -> + runIOSimProp $ do + (metadata, _symEnv) <- runActions actions + let WorldState{hydraParties, hydraState} = underlyingState metadata + -- XXX: This wait time is arbitrary and corresponds to 3 "blocks" from + -- the underlying simulated chain which produces a block every 20s. It + -- should be enough to ensure all nodes' threads terminate their actions + -- and those gets picked up by the chain + run $ lift waitForAMinute + let parties = Set.fromList $ deriveParty . fst <$> hydraParties + nodes <- run $ gets nodes + assert (parties == Map.keysSet nodes) + forM_ parties $ \p -> do + assertBalancesInOpenHeadAreConsistent hydraState nodes p where waitForAMinute :: MonadDelay m => m () waitForAMinute = threadDelay 60 @@ -368,16 +380,22 @@ runRunMonadIOSimGen :: runRunMonadIOSimGen f = do Capture eval <- capture let tr = runSimTrace (sim eval) - return - ( case traceResult False tr of - Right a -> logsOnError tr a + return $ + logsOnError tr $ + case traceResult False tr of + Right a -> property a Left (FailureException (SomeException ex)) -> - counterexample (show ex) $ logsOnError tr False + counterexample (show ex) False Left ex -> - counterexample (show ex) $ logsOnError tr False - ) + counterexample (show ex) False where - logsOnError tr = counterexample ("trace:\n" <> toString traceDump) + -- NOTE: Store trace dump in file when showing the counterexample. Behavior of + -- this during shrinking is not 100% confirmed, show the trace directly if you + -- want to be sure. + logsOnError tr = + counterexample . unsafePerformIO $ do + fn <- writeSystemTempFile "io-sim-trace" $ toString traceDump + pure $ "IOSim trace stored in: " <> toString fn where traceDump = printTrace (Proxy :: Proxy (HydraLog Tx ())) tr