From f9f190ee03810e13acf43347638f2ca08cb3f84b Mon Sep 17 00:00:00 2001 From: Sasha Bogicevic Date: Mon, 3 Jun 2024 15:28:36 +0200 Subject: [PATCH] TxSpec: Mutate snapshots and utxo to produce expected errors --- hydra-node/test/Hydra/Chain/Direct/TxSpec.hs | 116 +++++++++++-------- 1 file changed, 67 insertions(+), 49 deletions(-) diff --git a/hydra-node/test/Hydra/Chain/Direct/TxSpec.hs b/hydra-node/test/Hydra/Chain/Direct/TxSpec.hs index aff5a786690..8cf06b6bc45 100644 --- a/hydra-node/test/Hydra/Chain/Direct/TxSpec.hs +++ b/hydra-node/test/Hydra/Chain/Direct/TxSpec.hs @@ -41,7 +41,7 @@ import Data.Time.Clock.POSIX (posixSecondsToUTCTime) import GHC.Natural (naturalFromInteger) import Hydra.Cardano.Api.Pretty (renderTx, renderTxWithUTxO) import Hydra.Chain (CommitBlueprintTx (..), HeadParameters (..)) -import Hydra.Chain.Direct.Contract.Close (healthyContestationPeriodSeconds, healthyOpenHeadDatum, healthyOpenHeadTxOut) +import Hydra.Chain.Direct.Contract.Close (healthyContestationDeadline, healthyContestationPeriodSeconds, healthyOpenHeadDatum, healthyOpenHeadTxOut) import Hydra.Chain.Direct.Contract.Commit (commitSigningKey, healthyInitialTxIn, healthyInitialTxOut) import Hydra.Chain.Direct.Fixture ( epochInfo, @@ -52,8 +52,8 @@ import Hydra.Chain.Direct.Fixture ( testSeedInput, ) import Hydra.Chain.Direct.Fixture qualified as Fixture -import Hydra.Chain.Direct.ScriptRegistry (ScriptRegistry, genScriptRegistry, registryUTxO) -import Hydra.Chain.Direct.State (ChainContext (..), HasKnownUTxO (getKnownUTxO), close, contest, decrement, fanout, genChainStateWithTx) +import Hydra.Chain.Direct.ScriptRegistry (genScriptRegistry, registryUTxO) +import Hydra.Chain.Direct.State (ChainContext (..), HasKnownUTxO (getKnownUTxO), close, contest, decrement, fanout, genChainStateWithTx, utxoOfThisHead) import Hydra.Chain.Direct.State qualified as Transition import Hydra.Chain.Direct.Tx ( HeadObservation (..), @@ -78,16 +78,19 @@ import Hydra.Chain.Direct.Wallet (ErrCoverFee (..), coverFee_) import Hydra.ContestationPeriod (ContestationPeriod (..)) import Hydra.Contract.Commit qualified as Commit import Hydra.Contract.Error (toErrorCode) +import Hydra.Contract.Head qualified as Head import Hydra.Contract.HeadError (HeadError (SnapshotNumberMismatch, TooOldSnapshot)) -import Hydra.Contract.HeadState (utxoHash) +import Hydra.Contract.HeadState qualified as HeadState import Hydra.Contract.HeadTokens (headPolicyId, mkHeadTokenScript) import Hydra.Contract.Initial qualified as Initial import Hydra.Crypto (aggregate, sign) +import Hydra.Data.ContestationPeriod (contestationPeriodFromDiffTime) import Hydra.HeadId (HeadId (..)) import Hydra.Ledger (hashUTxO) import Hydra.Ledger.Cardano (adaOnly, addInputs, addReferenceInputs, addVkInputs, emptyTxBody, genOneUTxOFor, genTxOutWithReferenceScript, genUTxO1, genUTxOAdaOnlyOfSize, genValue, genVerificationKey, unsafeBuildTransaction) import Hydra.Ledger.Cardano.Evaluate (EvaluationReport, evaluateTx, maxTxExecutionUnits, propTransactionEvaluates) -import Hydra.Party (Party) +import Hydra.Party (Party, partyToChain) +import Hydra.Plutus.Extras (posixFromUTCTime) import Hydra.Snapshot (ConfirmedSnapshot (..), Snapshot (..), SnapshotNumber) import PlutusLedgerApi.Test.Examples qualified as Plutus import PlutusLedgerApi.V2 (toBuiltin) @@ -263,7 +266,7 @@ spec = forAllBlind genPerfectModelSnapshot $ \modelSnapshot -> do let (utxo', utxoToDecommit') = generateUTxOFromModelSnapshot modelSnapshot let headId' = mkHeadId Fixture.testPolicyId - let datum = toUTxOContext (mkTxOutDatumInline $ healthyOpenHeadDatum{utxoHash = toBuiltin $ hashUTxO @Tx utxo'}) + let datum = toUTxOContext (mkTxOutDatumInline $ healthyOpenHeadDatum{HeadState.utxoHash = toBuiltin $ hashUTxO @Tx utxo'}) let decommitValue = foldMap (txOutValue . snd) (UTxO.pairs utxoToDecommit') let headTxIn = generateWith arbitrary 42 let spendableUTxO = @@ -274,33 +277,53 @@ spec = let parameters = HeadParameters (UnsafeContestationPeriod $ naturalFromInteger healthyContestationPeriodSeconds) [alice, bob, carol] + let createCloseDatumFromOpen (snapshot, spendable) = + let headScript = fromPlutusScript @PlutusScriptV2 Head.validatorScript + in case UTxO.find (isScriptTxOut headScript) (utxoOfThisHead Fixture.testPolicyId spendable) of + Nothing -> error "Missing head output" + Just (headIn, headOut) -> + UTxO.singleton (headIn, modifyTxOutDatum (const closeDatum) headOut) <> registryUTxO scriptRegistry + where + Snapshot{utxo, utxoToDecommit} = snapshot + closeDatum = + mkTxOutDatumInline + HeadState.Closed + { parties = partyToChain <$> [alice, bob, carol] + , snapshotNumber = 2 + , utxoHash = toBuiltin $ hashUTxO @Tx utxo + , utxoToDecommitHash = toBuiltin $ hashUTxO @Tx (fromMaybe mempty utxoToDecommit) + , contestationDeadline = posixFromUTCTime healthyContestationDeadline + , contestationPeriod = contestationPeriodFromDiffTime 0 + , headId = headIdToCurrencySymbol headId' + , contesters = [] + } + let decrementSnapshots = - [ (decrementSnapshot, decrementSnapshot, Nothing) - , (mutateSnapshotNumber (\a -> abs $ a - 1) decrementSnapshot, decrementSnapshot, Just SnapshotNumberMismatch) + [ (decrementSnapshot, snd, Nothing) + , (mutateSnapshotNumber (\a -> abs $ a - 1) decrementSnapshot, snd, Just SnapshotNumberMismatch) ] let closeSnapshots = - [ (decrementSnapshot, decrementSnapshot, Nothing) - , (mutateSnapshotNumber (\a -> abs $ a - 1) decrementSnapshot, decrementSnapshot, Just SnapshotNumberMismatch) + [ (decrementSnapshot, snd, Nothing) + , (mutateSnapshotNumber (const 0) decrementSnapshot, snd, Just TooOldSnapshot) ] - let decrementAction = produceDecrement ctx scriptRegistry headId' parameters - let closeAction = produceClose ctx scriptRegistry headId' parameters - -- let contestAction = produceContest ctx scriptRegistry headId' - -- let fanoutAction = produceFanout ctx headTxIn - - fst $ flip runState spendableUTxO $ do - mapM_ - ( \(decrementSn, _, expectedDecrementErr) -> do - decrementAction decrementSn expectedDecrementErr - ) - decrementSnapshots + let contestSnapshots = + [ (mutateSnapshotNumber (+ 1) decrementSnapshot, createCloseDatumFromOpen, Nothing) + ] - mapM_ - ( \(closeSn, _, expectedCloseErr) -> do - closeAction closeSn expectedCloseErr - ) - closeSnapshots + flip evalState spendableUTxO $ do + decrementResults <- mapM (produceDecrement ctx headId' parameters) decrementSnapshots + closeResults <- mapM (produceClose ctx headId' parameters) closeSnapshots + contestResults <- mapM (produceContest ctx headId') contestSnapshots + pure $ + conjoin $ + ( \case + Left err -> counterexample err $ property False + Right (tx, utxo, mHeadError) -> + evaluateAndMatchError tx utxo mHeadError + ) + <$> (decrementResults <> closeResults <> contestResults) mutateSnapshotNumber :: (SnapshotNumber -> SnapshotNumber) -> Snapshot Tx -> Snapshot Tx mutateSnapshotNumber fn snapshot = @@ -312,41 +335,36 @@ mutateUTxOToDecommit fn snapshot = let toDecommit = fn (utxoToDecommit snapshot) in snapshot{utxoToDecommit = toDecommit} -produceDecrement :: ChainContext -> ScriptRegistry -> HeadId -> HeadParameters -> Snapshot Tx -> Maybe HeadError -> State UTxO Property -produceDecrement ctx scriptRegistry headId parameters snapshot expectedError = do +produceDecrement :: ChainContext -> HeadId -> HeadParameters -> (Snapshot Tx, (Snapshot Tx, UTxO) -> UTxO, Maybe HeadError) -> State UTxO (Either String (Tx, UTxO, Maybe HeadError)) +produceDecrement ctx headId parameters (snapshot, mutateSpendableUTxO, expectedError) = do spendableUTxO <- get - let decommitValue = foldMap (txOutValue . snd) (UTxO.pairs $ fromMaybe mempty $ utxoToDecommit snapshot) - case decrement ctx headId parameters spendableUTxO snapshot signatures of - Left err -> pure (counterexample ("Decrement tx:" <> show err) $ property False) + let newSpendableUTxO = mutateSpendableUTxO (snapshot, spendableUTxO) + case decrement ctx headId parameters newSpendableUTxO snapshot signatures of + Left err -> pure $ Left $ show err Right tx -> do - let spendableUTxO' = - foldMap (\(txin, txout) -> UTxO.singleton (txin, modifyTxOutValue (<> decommitValue) txout)) (UTxO.pairs (utxoFromTx tx)) - <> registryUTxO scriptRegistry - put spendableUTxO' - pure $ evaluateAndMatchError tx spendableUTxO' expectedError + pure $ Right (tx, newSpendableUTxO, expectedError) where signatures = aggregate [sign sk snapshot | sk <- [aliceSk, bobSk, carolSk]] -produceClose :: ChainContext -> ScriptRegistry -> HeadId -> HeadParameters -> Snapshot Tx -> Maybe HeadError -> State UTxO Property -produceClose ctx scriptRegistry headId parameters snapshot expectedError = do +produceClose :: ChainContext -> HeadId -> HeadParameters -> (Snapshot Tx, (Snapshot Tx, UTxO) -> UTxO, Maybe HeadError) -> State UTxO (Either String (Tx, UTxO, Maybe HeadError)) +produceClose ctx headId parameters (snapshot, mutateSpendableUTxO, expectedError) = do spendableUTxO <- get - case close ctx spendableUTxO headId parameters ConfirmedSnapshot{snapshot, signatures} 0 (0, posixSecondsToUTCTime 0) of - Left err -> pure (counterexample ("Close tx: " <> show err) $ property False) + let newSpendableUTxO = mutateSpendableUTxO (snapshot, spendableUTxO) + case close ctx newSpendableUTxO headId parameters ConfirmedSnapshot{snapshot, signatures} 0 (0, posixSecondsToUTCTime 0) of + Left err -> pure $ Left (show err) Right tx -> do - let spendableUTxO' = utxoFromTx tx <> registryUTxO scriptRegistry - put spendableUTxO' - pure $ evaluateAndMatchError tx spendableUTxO' expectedError + pure $ Right (tx, newSpendableUTxO, expectedError) where signatures = aggregate [sign sk snapshot | sk <- [aliceSk, bobSk, carolSk]] -produceContest :: ChainContext -> ScriptRegistry -> HeadId -> Snapshot Tx -> State UTxO (Either String Tx) -produceContest ctx scriptRegistry headId snapshot = do +produceContest :: ChainContext -> HeadId -> (Snapshot Tx, (Snapshot Tx, UTxO) -> UTxO, Maybe HeadError) -> State UTxO (Either String (Tx, UTxO, Maybe HeadError)) +produceContest ctx headId (snapshot, mutateSpendableUTxO, expectedError) = do spendableUTxO <- get - case contest ctx spendableUTxO headId (UnsafeContestationPeriod 0) ConfirmedSnapshot{snapshot, signatures} (0, posixSecondsToUTCTime 0) of - Left err -> pure (Left $ "Contest tx: " <> show err) + let newSpendableUTxO = mutateSpendableUTxO (snapshot, spendableUTxO) + case contest ctx newSpendableUTxO headId (UnsafeContestationPeriod 0) ConfirmedSnapshot{snapshot, signatures} (0, posixSecondsToUTCTime 0) of + Left err -> pure $ Left $ show err Right tx -> do - put $ utxoFromTx tx <> registryUTxO scriptRegistry - pure $ Right tx + pure $ Right (tx, newSpendableUTxO, expectedError) where signatures = aggregate [sign sk snapshot | sk <- [aliceSk, bobSk, carolSk]]