From 90e18c4c462e455714068abb9ba25ad2d3ab98d3 Mon Sep 17 00:00:00 2001 From: Daniel Firth Date: Wed, 22 May 2024 09:09:58 +0000 Subject: [PATCH] Allow mutation tests to expect one of many error codes. This accounts for situations where mutation tests could fail for multiple reasons depending on the evaluation order of the validator. --- .../test/Hydra/Chain/Direct/Contract/Abort.hs | 26 ++++++------ .../test/Hydra/Chain/Direct/Contract/Close.hs | 42 +++++++++---------- .../Hydra/Chain/Direct/Contract/CollectCom.hs | 20 ++++----- .../Hydra/Chain/Direct/Contract/Commit.hs | 16 +++---- .../Hydra/Chain/Direct/Contract/Contest.hs | 40 +++++++++--------- .../Hydra/Chain/Direct/Contract/FanOut.hs | 8 ++-- .../test/Hydra/Chain/Direct/Contract/Init.hs | 16 +++---- .../Hydra/Chain/Direct/Contract/Mutation.hs | 17 ++++---- 8 files changed, 93 insertions(+), 92 deletions(-) diff --git a/hydra-node/test/Hydra/Chain/Direct/Contract/Abort.hs b/hydra-node/test/Hydra/Chain/Direct/Contract/Abort.hs index 3d7dee227f7..beaf037aead 100644 --- a/hydra-node/test/Hydra/Chain/Direct/Contract/Abort.hs +++ b/hydra-node/test/Hydra/Chain/Direct/Contract/Abort.hs @@ -161,7 +161,7 @@ data AbortMutation genAbortMutation :: (Tx, UTxO) -> Gen SomeMutation genAbortMutation (tx, utxo) = oneof - [ SomeMutation (Just $ toErrorCode BurntTokenNumberMismatch) MutateParties . ChangeInputHeadDatum <$> do + [ SomeMutation (pure $ toErrorCode BurntTokenNumberMismatch) MutateParties . ChangeInputHeadDatum <$> do moreParties <- (: healthyParties) <$> arbitrary c <- arbitrary pure $ @@ -170,7 +170,7 @@ genAbortMutation (tx, utxo) = (partyToChain <$> moreParties) (toPlutusCurrencySymbol $ headPolicyId testSeedInput) (toPlutusTxOutRef testSeedInput) - , SomeMutation (Just $ toErrorCode BurntTokenNumberMismatch) DropCollectedInput <$> do + , SomeMutation (pure $ toErrorCode BurntTokenNumberMismatch) DropCollectedInput <$> do let abortableInputs = UTxO.pairs $ UTxO.filter (not . isHeadOutput) (resolveInputsUTxO utxo tx) (toDropTxIn, toDropTxOut) <- elements abortableInputs pure $ @@ -178,13 +178,13 @@ genAbortMutation (tx, utxo) = [ RemoveInput toDropTxIn , ChangeMintedValue $ removePTFromMintedValue toDropTxOut tx ] - , SomeMutation (Just $ toErrorCode ReimbursedOutputsDontMatch) DropOneCommitOutput . RemoveOutput <$> choose (0, fromIntegral (length (txOuts' tx) - 1)) - , SomeMutation (Just $ toErrorCode BurntTokenNumberMismatch) MutateThreadTokenQuantity <$> changeMintedValueQuantityFrom tx (-1) - , SomeMutation (Just $ toErrorCode BurntTokenNumberMismatch) BurnOneTokenMore <$> addPTWithQuantity tx (-1) - , SomeMutation (Just $ toErrorCode SignerIsNotAParticipant) MutateRequiredSigner <$> do + , SomeMutation (pure $ toErrorCode ReimbursedOutputsDontMatch) DropOneCommitOutput . RemoveOutput <$> choose (0, fromIntegral (length (txOuts' tx) - 1)) + , SomeMutation (pure $ toErrorCode BurntTokenNumberMismatch) MutateThreadTokenQuantity <$> changeMintedValueQuantityFrom tx (-1) + , SomeMutation (pure $ toErrorCode BurntTokenNumberMismatch) BurnOneTokenMore <$> addPTWithQuantity tx (-1) + , SomeMutation (pure $ toErrorCode SignerIsNotAParticipant) MutateRequiredSigner <$> do newSigner <- verificationKeyHash <$> genVerificationKey pure $ ChangeRequiredSigners [newSigner] - , SomeMutation (Just $ toErrorCode BurntTokenNumberMismatch) MutateUseDifferentHeadToAbort <$> do + , SomeMutation (pure $ toErrorCode BurntTokenNumberMismatch) MutateUseDifferentHeadToAbort <$> do mutatedSeed <- arbitrary `suchThat` (/= testSeedInput) pure $ ChangeInputHeadDatum @@ -194,7 +194,7 @@ genAbortMutation (tx, utxo) = , Head.headId = toPlutusCurrencySymbol $ headPolicyId mutatedSeed , Head.seed = toPlutusTxOutRef mutatedSeed } - , SomeMutation (Just $ toErrorCode BurntTokenNumberMismatch) UseInputFromOtherHead <$> do + , SomeMutation (pure $ toErrorCode BurntTokenNumberMismatch) UseInputFromOtherHead <$> do (txIn, txOut) <- elements healthyInitials otherHeadId <- fmap headPolicyId (arbitrary `suchThat` (/= testSeedInput)) pure $ @@ -205,12 +205,12 @@ genAbortMutation (tx, utxo) = ChangeInput txIn (replacePolicyIdWith testPolicyId otherHeadId txOut) (Just $ toScriptData Initial.ViaAbort) , ChangeMintedValue (removePTFromMintedValue txOut tx) ] - , SomeMutation (Just $ toErrorCode ReimbursedOutputsDontMatch) ReorderCommitOutputs <$> do + , SomeMutation (pure $ toErrorCode ReimbursedOutputsDontMatch) ReorderCommitOutputs <$> do let outputs = txOuts' tx outputs' <- shuffle outputs `suchThat` (/= outputs) let reorderedOutputs = uncurry ChangeOutput <$> zip [0 ..] outputs' pure $ Changes reorderedOutputs - , SomeMutation (Just $ toErrorCode MintingNotAllowed) MintOnAbort <$> do + , SomeMutation (pure $ toErrorCode MintingNotAllowed) MintOnAbort <$> do mintAPT <- addPTWithQuantity tx 1 -- We need to also remove one party to make sure the vHead validator -- still thinks it's the right number of tokens getting burned. @@ -224,7 +224,7 @@ genAbortMutation (tx, utxo) = , Head.seed = toPlutusTxOutRef testSeedInput } pure $ Changes [mintAPT, removeOneParty] - , SomeMutation Nothing ExtractValue <$> do + , SomeMutation [] ExtractValue <$> do divertFunds <- do let allValue = foldMap txOutValue $ txOuts' tx extractionTxOut <- do @@ -242,8 +242,8 @@ genAbortMutation (tx, utxo) = , RemoveInput healthyHeadInput ] ++ divertFunds - , SomeMutation (Just $ toErrorCode STNotBurnedError) DoNotBurnST + , SomeMutation (pure $ toErrorCode STNotBurnedError) DoNotBurnST <$> changeMintedTokens tx (valueFromList [(AssetId (headPolicyId testSeedInput) hydraHeadV1AssetName, 1)]) - , SomeMutation (Just $ toErrorCode STNotBurned) DoNotBurnSTInitial + , SomeMutation (pure $ toErrorCode STNotBurned) DoNotBurnSTInitial <$> changeMintedTokens tx (valueFromList [(AssetId (headPolicyId testSeedInput) hydraHeadV1AssetName, 1)]) ] diff --git a/hydra-node/test/Hydra/Chain/Direct/Contract/Close.hs b/hydra-node/test/Hydra/Chain/Direct/Contract/Close.hs index e74301fc128..a59a58082e9 100644 --- a/hydra-node/test/Hydra/Chain/Direct/Contract/Close.hs +++ b/hydra-node/test/Hydra/Chain/Direct/Contract/Close.hs @@ -291,18 +291,18 @@ data CloseMutation genCloseMutation :: (Tx, UTxO) -> Gen SomeMutation genCloseMutation (tx, _utxo) = oneof - [ SomeMutation (Just $ toErrorCode NotPayingToHead) NotContinueContract <$> do + [ SomeMutation (pure $ toErrorCode NotPayingToHead) NotContinueContract <$> do mutatedAddress <- genAddressInEra Fixture.testNetworkId pure $ ChangeOutput 0 (modifyTxOutAddress (const mutatedAddress) headTxOut) - , SomeMutation (Just $ toErrorCode SignatureVerificationFailed) MutateSignatureButNotSnapshotNumber . ChangeHeadRedeemer <$> do + , SomeMutation (pure $ toErrorCode SignatureVerificationFailed) MutateSignatureButNotSnapshotNumber . ChangeHeadRedeemer <$> do Head.Close . toPlutusSignatures <$> (arbitrary :: Gen (MultiSignature (Snapshot Tx))) - , SomeMutation (Just $ toErrorCode ClosedWithNonInitialHash) MutateSnapshotNumberToLessThanEqualZero <$> do + , SomeMutation (pure $ toErrorCode ClosedWithNonInitialHash) MutateSnapshotNumberToLessThanEqualZero <$> do mutatedSnapshotNumber <- arbitrary `suchThat` (<= 0) pure $ ChangeOutput 0 $ modifyInlineDatum (replaceSnapshotNumber mutatedSnapshotNumber) headTxOut - , SomeMutation (Just $ toErrorCode SignatureVerificationFailed) MutateSnapshotNumberButNotSignature <$> do + , SomeMutation (pure $ toErrorCode SignatureVerificationFailed) MutateSnapshotNumberButNotSignature <$> do mutatedSnapshotNumber <- arbitrarySizedNatural `suchThat` (> healthyCloseSnapshotNumber) pure $ ChangeOutput 0 $ modifyInlineDatum (replaceSnapshotNumber $ toInteger mutatedSnapshotNumber) headTxOut - , SomeMutation (Just $ toErrorCode SignatureVerificationFailed) SnapshotNotSignedByAllParties . ChangeInputHeadDatum <$> do + , SomeMutation (pure $ toErrorCode SignatureVerificationFailed) SnapshotNotSignedByAllParties . ChangeInputHeadDatum <$> do mutatedParties <- arbitrary `suchThat` (/= healthyOnChainParties) pure $ Head.Open @@ -311,35 +311,35 @@ genCloseMutation (tx, _utxo) = , contestationPeriod = healthyContestationPeriod , headId = toPlutusCurrencySymbol Fixture.testPolicyId } - , SomeMutation (Just $ toErrorCode ChangedParameters) MutatePartiesInOutput <$> do + , SomeMutation (pure $ toErrorCode ChangedParameters) MutatePartiesInOutput <$> do mutatedParties <- arbitrary `suchThat` (/= healthyOnChainParties) pure $ ChangeOutput 0 $ modifyInlineDatum (replaceParties mutatedParties) headTxOut - , SomeMutation (Just $ toErrorCode ChangedParameters) MutateHeadIdInOutput <$> do + , SomeMutation (pure $ toErrorCode ChangedParameters) MutateHeadIdInOutput <$> do otherHeadId <- toPlutusCurrencySymbol . headPolicyId <$> arbitrary `suchThat` (/= Fixture.testSeedInput) pure $ ChangeOutput 0 $ modifyInlineDatum (replaceHeadId otherHeadId) headTxOut - , SomeMutation (Just $ toErrorCode SignerIsNotAParticipant) MutateRequiredSigner <$> do + , SomeMutation (pure $ toErrorCode SignerIsNotAParticipant) MutateRequiredSigner <$> do newSigner <- verificationKeyHash <$> genVerificationKey `suchThat` (/= somePartyCardanoVerificationKey) pure $ ChangeRequiredSigners [newSigner] - , SomeMutation (Just $ toErrorCode NoSigners) MutateNoRequiredSigner <$> do + , SomeMutation (pure $ toErrorCode NoSigners) MutateNoRequiredSigner <$> do pure $ ChangeRequiredSigners [] - , SomeMutation (Just $ toErrorCode TooManySigners) MutateMultipleRequiredSigner <$> do + , SomeMutation (pure $ toErrorCode TooManySigners) MutateMultipleRequiredSigner <$> do otherSigners <- listOf1 (genVerificationKey `suchThat` (/= somePartyCardanoVerificationKey)) let signerAndOthers = somePartyCardanoVerificationKey : otherSigners pure $ ChangeRequiredSigners (verificationKeyHash <$> signerAndOthers) - , SomeMutation (Just $ toErrorCode SignatureVerificationFailed) MutateCloseUTxOHash . ChangeOutput 0 <$> do + , SomeMutation (pure $ toErrorCode SignatureVerificationFailed) MutateCloseUTxOHash . ChangeOutput 0 <$> do mutatedUTxOHash <- genHash `suchThat` ((/= healthyClosedUTxOHash) . toBuiltin) pure $ modifyInlineDatum (replaceUtxoHash $ toBuiltin mutatedUTxOHash) headTxOut - , SomeMutation (Just $ toErrorCode IncorrectClosedContestationDeadline) MutateContestationDeadline <$> do + , SomeMutation (pure $ toErrorCode IncorrectClosedContestationDeadline) MutateContestationDeadline <$> do mutatedDeadline <- genMutatedDeadline pure $ ChangeOutput 0 $ modifyInlineDatum (replaceContestationDeadline mutatedDeadline) headTxOut - , SomeMutation (Just $ toErrorCode ChangedParameters) MutateContestationPeriod <$> do + , SomeMutation (pure $ toErrorCode ChangedParameters) MutateContestationPeriod <$> do mutatedPeriod <- arbitrary pure $ ChangeOutput 0 $ modifyInlineDatum (replaceContestationPeriod mutatedPeriod) headTxOut - , SomeMutation (Just $ toErrorCode InfiniteLowerBound) MutateInfiniteLowerBound . ChangeValidityLowerBound <$> do + , SomeMutation (pure $ toErrorCode InfiniteLowerBound) MutateInfiniteLowerBound . ChangeValidityLowerBound <$> do pure TxValidityNoLowerBound - , SomeMutation (Just $ toErrorCode InfiniteUpperBound) MutateInfiniteUpperBound . ChangeValidityUpperBound <$> do + , SomeMutation (pure $ toErrorCode InfiniteUpperBound) MutateInfiniteUpperBound . ChangeValidityUpperBound <$> do pure TxValidityNoUpperBound - , SomeMutation (Just $ toErrorCode HasBoundedValidityCheckFailed) MutateValidityInterval <$> do + , SomeMutation (pure $ toErrorCode HasBoundedValidityCheckFailed) MutateValidityInterval <$> do (lowerSlotNo, upperSlotNo, adjustedContestationDeadline) <- genOversizedTransactionValidity pure $ Changes @@ -348,7 +348,7 @@ genCloseMutation (tx, _utxo) = ] , -- XXX: This is a bit confusing and not giving much value. Maybe we can remove this. -- This also seems to be covered by MutateRequiredSigner - SomeMutation (Just $ toErrorCode SignerIsNotAParticipant) CloseFromDifferentHead <$> do + SomeMutation (pure $ toErrorCode SignerIsNotAParticipant) CloseFromDifferentHead <$> do otherHeadId <- headPolicyId <$> arbitrary `suchThat` (/= Fixture.testSeedInput) pure $ Changes @@ -366,12 +366,12 @@ genCloseMutation (tx, _utxo) = ) ) ] - , SomeMutation (Just $ toErrorCode MintingOrBurningIsForbidden) MutateTokenMintingOrBurning + , SomeMutation (pure $ toErrorCode MintingOrBurningIsForbidden) MutateTokenMintingOrBurning <$> (changeMintedTokens tx =<< genMintedOrBurnedValue) - , SomeMutation (Just $ toErrorCode ContestersNonEmpty) MutateContesters . ChangeOutput 0 <$> do + , SomeMutation (pure $ toErrorCode ContestersNonEmpty) MutateContesters . ChangeOutput 0 <$> do mutatedContesters <- listOf1 $ PubKeyHash . toBuiltin <$> genHash pure $ headTxOut & modifyInlineDatum (replaceContesters mutatedContesters) - , SomeMutation (Just $ toErrorCode HeadValueIsNotPreserved) MutateValueInOutput <$> do + , SomeMutation (pure $ toErrorCode HeadValueIsNotPreserved) MutateValueInOutput <$> do newValue <- genValue pure $ ChangeOutput 0 (headTxOut{txOutValue = newValue}) ] @@ -398,7 +398,7 @@ data CloseInitialMutation -- right away. genCloseInitialMutation :: (Tx, UTxO) -> Gen SomeMutation genCloseInitialMutation (tx, _utxo) = - SomeMutation (Just $ toErrorCode IncorrectClosedContestationDeadline) MutateCloseContestationDeadline' <$> do + SomeMutation (pure $ toErrorCode IncorrectClosedContestationDeadline) MutateCloseContestationDeadline' <$> do mutatedDeadline <- genMutatedDeadline pure $ ChangeOutput 0 $ modifyInlineDatum (replaceContestationDeadline mutatedDeadline) headTxOut where diff --git a/hydra-node/test/Hydra/Chain/Direct/Contract/CollectCom.hs b/hydra-node/test/Hydra/Chain/Direct/Contract/CollectCom.hs index 4dd0f143024..f32585cb27c 100644 --- a/hydra-node/test/Hydra/Chain/Direct/Contract/CollectCom.hs +++ b/hydra-node/test/Hydra/Chain/Direct/Contract/CollectCom.hs @@ -44,7 +44,7 @@ import Hydra.Contract.HeadError (HeadError (..)) import Hydra.Contract.HeadState qualified as Head import Hydra.Contract.HeadTokens (headPolicyId) import Hydra.Contract.Initial qualified as Initial -import Hydra.Contract.InitialError (InitialError (ExpectedSingleCommitOutput)) +import Hydra.Contract.InitialError (InitialError (ExpectedSingleCommitOutput, LockedValueDoesNotMatch)) import Hydra.Contract.Util (UtilError (MintingOrBurningIsForbidden)) import Hydra.Data.Party qualified as OnChain import Hydra.Ledger.Cardano (genAddressInEra, genUTxOAdaOnlyOfSize, genVerificationKey) @@ -204,10 +204,10 @@ data CollectComMutation genCollectComMutation :: (Tx, UTxO) -> Gen SomeMutation genCollectComMutation (tx, _utxo) = oneof - [ SomeMutation (Just $ toErrorCode NotPayingToHead) NotContinueContract <$> do + [ SomeMutation (pure $ toErrorCode NotPayingToHead) NotContinueContract <$> do mutatedAddress <- genAddressInEra testNetworkId pure $ ChangeOutput 0 (modifyTxOutAddress (const mutatedAddress) headTxOut) - , SomeMutation (Just $ toErrorCode NotAllValueCollected) ExtractSomeValue <$> do + , SomeMutation (pure $ toErrorCode NotAllValueCollected) ExtractSomeValue <$> do -- Remove a random asset and quantity from headOutput removedValue <- do let allAssets = valueToList $ txOutValue headTxOut @@ -228,15 +228,15 @@ genCollectComMutation (tx, _utxo) = [ ChangeOutput 0 $ modifyTxOutValue (\v -> v <> negateValue removedValue) headTxOut , AppendOutput extractionTxOut ] - , SomeMutation (Just $ toErrorCode IncorrectUtxoHash) MutateOpenUTxOHash . ChangeOutput 0 <$> mutateUTxOHash - , SomeMutation (Just $ toErrorCode MissingCommits) MutateNumberOfParties <$> do + , SomeMutation (pure $ toErrorCode IncorrectUtxoHash) MutateOpenUTxOHash . ChangeOutput 0 <$> mutateUTxOHash + , SomeMutation (pure $ toErrorCode MissingCommits) MutateNumberOfParties <$> do moreParties <- (: healthyOnChainParties) <$> arbitrary pure $ Changes [ ChangeInputHeadDatum $ replaceParties moreParties healthyCollectComInitialDatum , ChangeOutput 0 $ mutatedPartiesHeadTxOut moreParties headTxOut ] - , SomeMutation (Just $ toErrorCode STNotSpent) MutateHeadId <$> do + , SomeMutation (pure $ toErrorCode STNotSpent) MutateHeadId <$> do -- XXX: This mutation is unrealistic. It would only change the headId in -- the value, but not in the datum. This is not allowed by the protocol -- prior to this transaction. @@ -245,10 +245,10 @@ genCollectComMutation (tx, _utxo) = <$> fmap headPolicyId (arbitrary `suchThat` (/= testSeedInput)) <*> pure (toUTxOContext $ mkTxOutDatumInline healthyCollectComInitialDatum) return $ ChangeInput healthyHeadTxIn illedHeadResolvedInput (Just $ toScriptData Head.CollectCom) - , SomeMutation (Just $ toErrorCode SignerIsNotAParticipant) MutateRequiredSigner <$> do + , SomeMutation (pure $ toErrorCode SignerIsNotAParticipant) MutateRequiredSigner <$> do newSigner <- verificationKeyHash <$> genVerificationKey pure $ ChangeRequiredSigners [newSigner] - , SomeMutation (Just $ toErrorCode ExpectedSingleCommitOutput) MutateCommitToInitial <$> do + , SomeMutation (map toErrorCode [ExpectedSingleCommitOutput, LockedValueDoesNotMatch]) MutateCommitToInitial <$> do -- By changing a commit output to an initial, we simulate a situation -- where we do pretend to have collected every commit, but we just -- changed one back to be an initial. This should be caught by the @@ -262,9 +262,9 @@ genCollectComMutation (tx, _utxo) = (Just . toScriptData . Initial.redeemer $ Initial.ViaCommit [toPlutusTxOutRef txIn]) , AddScript $ fromPlutusScript Initial.validatorScript ] - , SomeMutation (Just $ toErrorCode MintingOrBurningIsForbidden) MutateTokenMintingOrBurning + , SomeMutation (pure $ toErrorCode MintingOrBurningIsForbidden) MutateTokenMintingOrBurning <$> (changeMintedTokens tx =<< genMintedOrBurnedValue) - , SomeMutation (Just $ toErrorCode STIsMissingInTheOutput) RemoveSTFromOutput <$> do + , SomeMutation (pure $ toErrorCode STIsMissingInTheOutput) RemoveSTFromOutput <$> do let out = List.head $ txOuts' tx let stAssetId = AssetId (headPolicyId testSeedInput) hydraHeadV1AssetName let newValue = filterValue (/= stAssetId) (txOutValue out) diff --git a/hydra-node/test/Hydra/Chain/Direct/Contract/Commit.hs b/hydra-node/test/Hydra/Chain/Direct/Contract/Commit.hs index c4680a4fda9..2cb21d721f7 100644 --- a/hydra-node/test/Hydra/Chain/Direct/Contract/Commit.hs +++ b/hydra-node/test/Hydra/Chain/Direct/Contract/Commit.hs @@ -125,25 +125,25 @@ data CommitMutation genCommitMutation :: (Tx, UTxO) -> Gen SomeMutation genCommitMutation (tx, _utxo) = oneof - [ SomeMutation (Just $ toErrorCode WrongHeadIdInCommitDatum) NonContinuousHeadId <$> do + [ SomeMutation (pure $ toErrorCode WrongHeadIdInCommitDatum) NonContinuousHeadId <$> do otherHeadId <- fmap headPolicyId (arbitrary `suchThat` (/= healthyInitialTxIn)) let mutateHeadId = modifyInlineDatum $ \((party, mCommit, _headId) :: Commit.DatumType) -> (party, mCommit, toPlutusCurrencySymbol otherHeadId) pure $ ChangeOutput 0 $ mutateHeadId commitTxOut - , SomeMutation (Just $ toErrorCode LockedValueDoesNotMatch) MutateCommitOutputValue . ChangeOutput 0 <$> do + , SomeMutation (pure $ toErrorCode LockedValueDoesNotMatch) MutateCommitOutputValue . ChangeOutput 0 <$> do mutatedValue <- scale (`div` 2) genValue `suchThat` (/= commitOutputValue) pure $ commitTxOut{txOutValue = mutatedValue} - , SomeMutation (Just $ toErrorCode LockedValueDoesNotMatch) MutateCommittedValue <$> do + , SomeMutation (pure $ toErrorCode LockedValueDoesNotMatch) MutateCommittedValue <$> do mutatedValue <- scale (`div` 2) genValue `suchThat` (/= aCommittedOutputValue) let mutatedOutput = modifyTxOutValue (const mutatedValue) aCommittedTxOut pure $ ChangeInput aCommittedTxIn mutatedOutput Nothing - , SomeMutation (Just $ toErrorCode MismatchCommittedTxOutInDatum) MutateCommittedAddress <$> do + , SomeMutation (pure $ toErrorCode MismatchCommittedTxOutInDatum) MutateCommittedAddress <$> do mutatedAddress <- genAddressInEra Fixture.testNetworkId `suchThat` (/= aCommittedAddress) let mutatedOutput = modifyTxOutAddress (const mutatedAddress) aCommittedTxOut pure $ ChangeInput aCommittedTxIn mutatedOutput Nothing - , SomeMutation (Just $ toErrorCode MissingCommittedTxOutInOutputDatum) RecordAllCommittedUTxO <$> do + , SomeMutation (map toErrorCode [MismatchCommittedTxOutInDatum, MissingCommittedTxOutInOutputDatum]) RecordAllCommittedUTxO <$> do (removedTxIn, removedTxOut) <- elements $ UTxO.pairs healthyCommittedUTxO -- Leave out not-committed value let mutatedCommitTxOut = modifyTxOutValue (\v -> negateValue (txOutValue removedTxOut) <> v) commitTxOut @@ -156,12 +156,12 @@ genCommitMutation (tx, _utxo) = (toUTxOContext healthyInitialTxOut) (Just $ toScriptData $ Initial.ViaCommit (removedTxIn `List.delete` allComittedTxIn <&> toPlutusTxOutRef)) ] - , SomeMutation (Just $ toErrorCode MissingOrInvalidCommitAuthor) MutateRequiredSigner <$> do + , SomeMutation (pure $ toErrorCode MissingOrInvalidCommitAuthor) MutateRequiredSigner <$> do newSigner <- verificationKeyHash <$> genVerificationKey pure $ ChangeRequiredSigners [newSigner] , -- XXX: This is a bit confusing and not giving much value. Maybe we can remove this. -- This also seems to be covered by MutateRequiredSigner - SomeMutation (Just $ toErrorCode CouldNotFindTheCorrectCurrencySymbolInTokens) UsePTFromDifferentHead <$> do + SomeMutation (pure $ toErrorCode CouldNotFindTheCorrectCurrencySymbolInTokens) UsePTFromDifferentHead <$> do otherHeadId <- fmap headPolicyId (arbitrary `suchThat` (/= healthyInitialTxIn)) pure $ Changes @@ -171,7 +171,7 @@ genCommitMutation (tx, _utxo) = (toUTxOContext $ replacePolicyIdWith Fixture.testPolicyId otherHeadId healthyInitialTxOut) (Just $ toScriptData $ Initial.ViaCommit (allComittedTxIn <&> toPlutusTxOutRef)) ] - , SomeMutation (Just $ toErrorCode MintingOrBurningIsForbidden) MutateTokenMintingOrBurning + , SomeMutation (pure $ toErrorCode MintingOrBurningIsForbidden) MutateTokenMintingOrBurning <$> (changeMintedTokens tx =<< genMintedOrBurnedValue) ] where diff --git a/hydra-node/test/Hydra/Chain/Direct/Contract/Contest.hs b/hydra-node/test/Hydra/Chain/Direct/Contract/Contest.hs index 360c9a113ff..4446bc92581 100644 --- a/hydra-node/test/Hydra/Chain/Direct/Contract/Contest.hs +++ b/hydra-node/test/Hydra/Chain/Direct/Contract/Contest.hs @@ -264,19 +264,19 @@ data ContestMutation genContestMutation :: (Tx, UTxO) -> Gen SomeMutation genContestMutation (tx, _utxo) = oneof - [ SomeMutation (Just $ toErrorCode NotPayingToHead) NotContinueContract <$> do + [ SomeMutation (pure $ toErrorCode NotPayingToHead) NotContinueContract <$> do mutatedAddress <- genAddressInEra testNetworkId pure $ ChangeOutput 0 (modifyTxOutAddress (const mutatedAddress) headTxOut) - , SomeMutation (Just $ toErrorCode SignatureVerificationFailed) MutateSignatureButNotSnapshotNumber . ChangeHeadRedeemer <$> do + , SomeMutation (pure $ toErrorCode SignatureVerificationFailed) MutateSignatureButNotSnapshotNumber . ChangeHeadRedeemer <$> do mutatedSignature <- arbitrary :: Gen (MultiSignature (Snapshot Tx)) pure $ Head.Contest { signature = toPlutusSignatures mutatedSignature } - , SomeMutation (Just $ toErrorCode SignatureVerificationFailed) MutateSnapshotNumberButNotSignature <$> do + , SomeMutation (pure $ toErrorCode SignatureVerificationFailed) MutateSnapshotNumberButNotSignature <$> do mutatedSnapshotNumber <- arbitrarySizedNatural `suchThat` (> healthyContestSnapshotNumber) pure $ ChangeOutput 0 $ modifyInlineDatum (replaceSnapshotNumber $ toInteger mutatedSnapshotNumber) headTxOut - , SomeMutation (Just $ toErrorCode TooOldSnapshot) MutateToNonNewerSnapshot <$> do + , SomeMutation (pure $ toErrorCode TooOldSnapshot) MutateToNonNewerSnapshot <$> do mutatedSnapshotNumber <- choose (toInteger healthyContestSnapshotNumber, toInteger healthyContestSnapshotNumber + 1) pure $ Changes @@ -289,32 +289,32 @@ genContestMutation (tx, _utxo) = healthySignature (fromInteger mutatedSnapshotNumber) } ] - , SomeMutation (Just $ toErrorCode SignerIsNotAParticipant) MutateRequiredSigner <$> do + , SomeMutation (pure $ toErrorCode SignerIsNotAParticipant) MutateRequiredSigner <$> do newSigner <- verificationKeyHash <$> genVerificationKey `suchThat` (/= healthyContesterVerificationKey) pure $ ChangeRequiredSigners [newSigner] - , SomeMutation (Just $ toErrorCode NoSigners) MutateNoRequiredSigner <$> do + , SomeMutation (pure $ toErrorCode NoSigners) MutateNoRequiredSigner <$> do pure $ ChangeRequiredSigners [] - , SomeMutation (Just $ toErrorCode TooManySigners) MutateMultipleRequiredSigner <$> do + , SomeMutation (pure $ toErrorCode TooManySigners) MutateMultipleRequiredSigner <$> do otherSigners <- listOf1 (genVerificationKey `suchThat` (/= healthyContesterVerificationKey)) let signerAndOthers = healthyContesterVerificationKey : otherSigners pure $ ChangeRequiredSigners (verificationKeyHash <$> signerAndOthers) - , SomeMutation (Just $ toErrorCode SignatureVerificationFailed) MutateContestUTxOHash . ChangeOutput 0 <$> do + , SomeMutation (pure $ toErrorCode SignatureVerificationFailed) MutateContestUTxOHash . ChangeOutput 0 <$> do mutatedUTxOHash <- genHash `suchThat` ((/= healthyContestUTxOHash) . toBuiltin) pure $ modifyInlineDatum (replaceUtxoHash (toBuiltin mutatedUTxOHash)) headTxOut - , SomeMutation (Just $ toErrorCode SignatureVerificationFailed) SnapshotNotSignedByAllParties . ChangeInputHeadDatum <$> do + , SomeMutation (pure $ toErrorCode SignatureVerificationFailed) SnapshotNotSignedByAllParties . ChangeInputHeadDatum <$> do mutatedParties <- arbitrary `suchThat` (/= healthyOnChainParties) pure $ healthyClosedState & replaceParties mutatedParties - , SomeMutation (Just $ toErrorCode UpperBoundBeyondContestationDeadline) MutateValidityPastDeadline . ChangeValidityInterval <$> do + , SomeMutation (pure $ toErrorCode UpperBoundBeyondContestationDeadline) MutateValidityPastDeadline . ChangeValidityInterval <$> do lb <- arbitrary ub <- TxValidityUpperBound <$> arbitrary `suchThat` slotOverContestationDeadline pure (lb, ub) , -- XXX: This is a bit confusing and not giving much value. Maybe we can remove this. -- This also seems to be covered by MutateRequiredSigner - SomeMutation (Just $ toErrorCode SignerIsNotAParticipant) ContestFromDifferentHead <$> do + SomeMutation (pure $ toErrorCode SignerIsNotAParticipant) ContestFromDifferentHead <$> do otherHeadId <- headPolicyId <$> arbitrary `suchThat` (/= healthyClosedHeadTxIn) pure $ Changes @@ -332,9 +332,9 @@ genContestMutation (tx, _utxo) = ) ) ] - , SomeMutation (Just $ toErrorCode MintingOrBurningIsForbidden) MutateTokenMintingOrBurning + , SomeMutation (pure $ toErrorCode MintingOrBurningIsForbidden) MutateTokenMintingOrBurning <$> (changeMintedTokens tx =<< genMintedOrBurnedValue) - , SomeMutation (Just $ toErrorCode SignerAlreadyContested) MutateInputContesters . ChangeInputHeadDatum <$> do + , SomeMutation (pure $ toErrorCode SignerAlreadyContested) MutateInputContesters . ChangeInputHeadDatum <$> do let contester = toPlutusKeyHash (verificationKeyHash healthyContesterVerificationKey) contesterAndSomeOthers = do contesters <- listOf $ Plutus.PubKeyHash . toBuiltin <$> genHash @@ -346,19 +346,19 @@ genContestMutation (tx, _utxo) = ] pure $ healthyClosedState & replaceContesters mutatedContesters - , SomeMutation (Just $ toErrorCode ContesterNotIncluded) MutateContesters . ChangeOutput 0 <$> do + , SomeMutation (pure $ toErrorCode ContesterNotIncluded) MutateContesters . ChangeOutput 0 <$> do hashes <- listOf genHash let mutatedContesters = Plutus.PubKeyHash . toBuiltin <$> hashes pure $ modifyInlineDatum (replaceContesters mutatedContesters) headTxOut - , SomeMutation (Just $ toErrorCode HeadValueIsNotPreserved) MutateValueInOutput <$> do + , SomeMutation (pure $ toErrorCode HeadValueIsNotPreserved) MutateValueInOutput <$> do newValue <- genValue pure $ ChangeOutput 0 (headTxOut{txOutValue = newValue}) - , SomeMutation (Just $ toErrorCode MustPushDeadline) NotUpdateDeadlineAlthoughItShould . ChangeOutput 0 <$> do + , SomeMutation (pure $ toErrorCode MustPushDeadline) NotUpdateDeadlineAlthoughItShould . ChangeOutput 0 <$> do let deadline = posixFromUTCTime healthyContestationDeadline -- Here we are replacing the contestationDeadline using the previous so we are not _pushing it_ further -- Remember the 'healthyContestTx' is already pushing out the deadline. pure $ headTxOut & modifyInlineDatum (replaceContestationDeadline deadline) - , SomeMutation (Just $ toErrorCode MustNotPushDeadline) PushDeadlineAlthoughItShouldNot <$> do + , SomeMutation (pure $ toErrorCode MustNotPushDeadline) PushDeadlineAlthoughItShouldNot <$> do alreadyContested <- vectorOf (length healthyParties - 1) $ Plutus.PubKeyHash . toBuiltin <$> genHash let contester = toPlutusKeyHash $ verificationKeyHash healthyContesterVerificationKey pure $ @@ -366,10 +366,10 @@ genContestMutation (tx, _utxo) = [ ChangeOutput 0 (headTxOut & modifyInlineDatum (replaceContesters (contester : alreadyContested))) , ChangeInputHeadDatum (healthyClosedState & replaceContesters alreadyContested) ] - , SomeMutation (Just $ toErrorCode ChangedParameters) MutateOutputContestationPeriod <$> do + , SomeMutation (pure $ toErrorCode ChangedParameters) MutateOutputContestationPeriod <$> do randomCP <- arbitrary `suchThat` (/= healthyOnChainContestationPeriod) pure $ ChangeOutput 0 (headTxOut & modifyInlineDatum (replaceContestationPeriod randomCP)) - , SomeMutation (Just $ toErrorCode ChangedParameters) MutatePartiesInOutput <$> do + , SomeMutation (pure $ toErrorCode ChangedParameters) MutatePartiesInOutput <$> do mutatedParties <- -- The length of mutatedParties must be the same as -- healthyOnChainParties so to not fail because of @@ -380,7 +380,7 @@ genContestMutation (tx, _utxo) = ) `suchThat` (/= healthyOnChainParties) pure $ ChangeOutput 0 $ modifyInlineDatum (replaceParties mutatedParties) headTxOut - , SomeMutation (Just $ toErrorCode ChangedParameters) MutateHeadIdInOutput <$> do + , SomeMutation (pure $ toErrorCode ChangedParameters) MutateHeadIdInOutput <$> do otherHeadId <- toPlutusCurrencySymbol . headPolicyId <$> arbitrary `suchThat` (/= Fixture.testSeedInput) pure $ ChangeOutput 0 $ modifyInlineDatum (replaceHeadId otherHeadId) headTxOut ] diff --git a/hydra-node/test/Hydra/Chain/Direct/Contract/FanOut.hs b/hydra-node/test/Hydra/Chain/Direct/Contract/FanOut.hs index 2f6eaabd48e..9f9670b32f4 100644 --- a/hydra-node/test/Hydra/Chain/Direct/Contract/FanOut.hs +++ b/hydra-node/test/Hydra/Chain/Direct/Contract/FanOut.hs @@ -110,9 +110,9 @@ data FanoutMutation genFanoutMutation :: (Tx, UTxO) -> Gen SomeMutation genFanoutMutation (tx, _utxo) = oneof - [ SomeMutation (Just $ toErrorCode FannedOutUtxoHashNotEqualToClosedUtxoHash) MutateAddUnexpectedOutput . PrependOutput <$> do + [ SomeMutation (pure $ toErrorCode FannedOutUtxoHashNotEqualToClosedUtxoHash) MutateAddUnexpectedOutput . PrependOutput <$> do arbitrary >>= genOutput - , SomeMutation (Just $ toErrorCode FannedOutUtxoHashNotEqualToClosedUtxoHash) MutateChangeOutputValue <$> do + , SomeMutation (pure $ toErrorCode FannedOutUtxoHashNotEqualToClosedUtxoHash) MutateChangeOutputValue <$> do let outs = txOuts' tx -- NOTE: Assumes the fanout transaction has non-empty outputs, which -- might not be always the case when testing unbalanced txs and we need @@ -120,10 +120,10 @@ genFanoutMutation (tx, _utxo) = (ix, out) <- elements (zip [0 .. length outs - 1] outs) value' <- genValue `suchThat` (/= txOutValue out) pure $ ChangeOutput (fromIntegral ix) (modifyTxOutValue (const value') out) - , SomeMutation (Just $ toErrorCode LowerBoundBeforeContestationDeadline) MutateValidityBeforeDeadline . ChangeValidityInterval <$> do + , SomeMutation (pure $ toErrorCode LowerBoundBeforeContestationDeadline) MutateValidityBeforeDeadline . ChangeValidityInterval <$> do lb <- genSlotBefore $ slotNoFromUTCTime systemStart slotLength healthyContestationDeadline pure (TxValidityLowerBound lb, TxValidityNoUpperBound) - , SomeMutation (Just $ toErrorCode BurntTokenNumberMismatch) MutateThreadTokenQuantity <$> do + , SomeMutation (pure $ toErrorCode BurntTokenNumberMismatch) MutateThreadTokenQuantity <$> do (token, _) <- elements burntTokens changeMintedTokens tx (valueFromList [(token, 1)]) ] diff --git a/hydra-node/test/Hydra/Chain/Direct/Contract/Init.hs b/hydra-node/test/Hydra/Chain/Direct/Contract/Init.hs index d376b47af08..fa5ddcae579 100644 --- a/hydra-node/test/Hydra/Chain/Direct/Contract/Init.hs +++ b/hydra-node/test/Hydra/Chain/Direct/Contract/Init.hs @@ -89,22 +89,22 @@ data ObserveInitMutation genInitMutation :: (Tx, UTxO) -> Gen SomeMutation genInitMutation (tx, _utxo) = oneof - [ SomeMutation (Just $ toErrorCode WrongNumberOfTokensMinted) MintTooManyTokens <$> changeMintedValueQuantityFrom tx 1 - , SomeMutation (Just $ toErrorCode WrongNumberOfTokensMinted) MutateAddAnotherPT <$> addPTWithQuantity tx 1 - , SomeMutation (Just $ toErrorCode NoPT) MutateInitialOutputValue <$> do + [ SomeMutation (pure $ toErrorCode WrongNumberOfTokensMinted) MintTooManyTokens <$> changeMintedValueQuantityFrom tx 1 + , SomeMutation (pure $ toErrorCode WrongNumberOfTokensMinted) MutateAddAnotherPT <$> addPTWithQuantity tx 1 + , SomeMutation (pure $ toErrorCode NoPT) MutateInitialOutputValue <$> do let outs = txOuts' tx (ix :: Int, out) <- elements (drop 1 $ zip [0 ..] outs) value' <- genValue `suchThat` (/= txOutValue out) pure $ ChangeOutput (fromIntegral ix) (modifyTxOutValue (const value') out) - , SomeMutation (Just $ toErrorCode WrongNumberOfInitialOutputs) MutateDropInitialOutput <$> do + , SomeMutation (pure $ toErrorCode WrongNumberOfInitialOutputs) MutateDropInitialOutput <$> do ix <- choose (1, length (txOuts' tx) - 1) pure $ RemoveOutput (fromIntegral ix) - , SomeMutation (Just $ toErrorCode SeedNotSpent) MutateDropSeedInput <$> do + , SomeMutation (pure $ toErrorCode SeedNotSpent) MutateDropSeedInput <$> do pure $ RemoveInput healthySeedInput - , SomeMutation (Just $ toErrorCode WrongDatum) MutateHeadIdInDatum <$> do + , SomeMutation (pure $ toErrorCode WrongDatum) MutateHeadIdInDatum <$> do mutatedHeadId <- arbitrary `suchThat` (/= toPlutusCurrencySymbol testPolicyId) pure $ ChangeOutput 0 $ modifyInlineDatum (replaceHeadId mutatedHeadId) headTxOut - , SomeMutation (Just $ toErrorCode WrongInitialDatum) MutateHeadIdInInitialDatum <$> do + , SomeMutation (pure $ toErrorCode WrongInitialDatum) MutateHeadIdInInitialDatum <$> do let outs = txOuts' tx (ix, out) <- elements (drop 1 $ zip [0 ..] outs) elements @@ -112,7 +112,7 @@ genInitMutation (tx, _utxo) = , removeInitialOutputDatum ix out , changeInitialOutputToNotAHeadId ix out ] - , SomeMutation (Just $ toErrorCode WrongDatum) MutateSeedInDatum <$> do + , SomeMutation (pure $ toErrorCode WrongDatum) MutateSeedInDatum <$> do mutatedSeed <- toPlutusTxOutRef <$> arbitrary `suchThat` (/= testSeedInput) pure $ ChangeOutput 0 $ diff --git a/hydra-node/test/Hydra/Chain/Direct/Contract/Mutation.hs b/hydra-node/test/Hydra/Chain/Direct/Contract/Mutation.hs index f00ec309a73..2b86a72cb14 100644 --- a/hydra-node/test/Hydra/Chain/Direct/Contract/Mutation.hs +++ b/hydra-node/test/Hydra/Chain/Direct/Contract/Mutation.hs @@ -180,15 +180,15 @@ import Test.QuickCheck.Instances () -- structurally valid and having passed "level 1" checks. propMutation :: (Tx, UTxO) -> ((Tx, UTxO) -> Gen SomeMutation) -> Property propMutation (tx, utxo) genMutation = - forAll @_ @Property (genMutation (tx, utxo)) $ \SomeMutation{label, mutation, expectedError} -> + forAll @_ @Property (genMutation (tx, utxo)) $ \SomeMutation{label, mutation, expectedErrors} -> (tx, utxo) & applyMutation mutation - & propTransactionFailsPhase2 expectedError + & propTransactionFailsPhase2 expectedErrors & genericCoverTable [label] & checkCoverage -- | Expect a phase-2 evaluation failure of given 'Tx' and 'UTxO'. -propTransactionFailsPhase2 :: Maybe Text -> (Tx, UTxO) -> Property +propTransactionFailsPhase2 :: [Text] -> (Tx, UTxO) -> Property propTransactionFailsPhase2 mExpectedError (tx, lookupUTxO) = case evaluateTx tx lookupUTxO of Left err -> @@ -198,17 +198,18 @@ propTransactionFailsPhase2 mExpectedError (tx, lookupUTxO) = Right redeemerReport -> let errors = lefts $ Map.elems redeemerReport in case mExpectedError of - Nothing -> + [] -> not (null errors) & counterexample ("Mutated transaction: " <> renderTxWithUTxO lookupUTxO tx) & counterexample ("Redeemer report: " <> show redeemerReport) & counterexample "Phase-2 validation should have failed" - Just expectedError -> - any (matchesErrorMessage expectedError) errors + expectedErrors -> + any (\x -> any (`matchesErrorMessage` x) expectedErrors) errors & counterexample ("Mutated transaction: " <> renderTxWithUTxO lookupUTxO tx) & counterexample ("Redeemer report: " <> show redeemerReport) - & counterexample ("Phase-2 validation should have failed with error message: " <> show expectedError) + & counterexample ("Phase-2 validation should have failed with one of error messages: " <> show expectedErrors) where + matchesErrorMessage :: Text -> ScriptExecutionError -> Bool matchesErrorMessage errMsg = \case ScriptErrorEvaluationFailed _ errList -> errMsg `elem` errList _otherScriptExecutionError -> False @@ -224,7 +225,7 @@ propTransactionFailsPhase2 mExpectedError (tx, lookupUTxO) = data SomeMutation = forall lbl. (Typeable lbl, Enum lbl, Bounded lbl, Show lbl) => SomeMutation - { expectedError :: Maybe Text + { expectedErrors :: [Text] , label :: lbl , mutation :: Mutation }