From 8bcf0017c30fb253ddb4ab85952af6581f19ef16 Mon Sep 17 00:00:00 2001 From: Sebastian Nagel Date: Wed, 9 Oct 2024 08:27:12 +0200 Subject: [PATCH] Move / deduplicate genAbortableOutputs This function is not only hard to read, but was even twice in our codebase. Moved it to Abort mutation tests as its the only location where it is used. --- hydra-node/test/Hydra/Chain/Direct/TxSpec.hs | 89 +------------------- hydra-tx/test/Hydra/Tx/Contract/Abort.hs | 89 +++++++++++++++++++- hydra-tx/testlib/Test/Hydra/Tx/Gen.hs | 85 +------------------ 3 files changed, 89 insertions(+), 174 deletions(-) diff --git a/hydra-node/test/Hydra/Chain/Direct/TxSpec.hs b/hydra-node/test/Hydra/Chain/Direct/TxSpec.hs index fbcdca7670d..a7ec55a3f3b 100644 --- a/hydra-node/test/Hydra/Chain/Direct/TxSpec.hs +++ b/hydra-node/test/Hydra/Chain/Direct/TxSpec.hs @@ -43,36 +43,28 @@ import Hydra.Chain.Direct.Tx ( txInToHeadSeed, ) import Hydra.Contract.HeadTokens (headPolicyId) -import Hydra.Contract.Initial qualified as Initial import Hydra.Ledger.Cardano.Builder (addInputs, addReferenceInputs, addVkInputs, emptyTxBody, unsafeBuildTransaction) import Hydra.Ledger.Cardano.Evaluate (propTransactionEvaluates) -import Hydra.Plutus (commitValidatorScript) import Hydra.Tx.BlueprintTx (CommitBlueprintTx (..)) -import Hydra.Tx.Commit (commitTx, mkCommitDatum) +import Hydra.Tx.Commit (commitTx) import Hydra.Tx.HeadId (headIdToCurrencySymbol, mkHeadId) import Hydra.Tx.Init (mkInitialOutput) -import Hydra.Tx.Party (Party) import Hydra.Tx.ScriptRegistry (registryUTxO) -import Hydra.Tx.Utils (adaOnly, verificationKeyToOnChainId) +import Hydra.Tx.Utils (verificationKeyToOnChainId) import PlutusLedgerApi.Test.Examples qualified as Plutus import Test.Cardano.Ledger.Shelley.Arbitrary (genMetadata') import Test.Hydra.Prelude import Test.Hydra.Tx.Fixture ( pparams, testNetworkId, - testPolicyId, ) import Test.Hydra.Tx.Fixture qualified as Fixture import Test.Hydra.Tx.Gen ( - assetNameFromVerificationKey, - genForParty, - genOneUTxOFor, genSigningKey, genTxOutWithReferenceScript, genUTxO1, genUTxOAdaOnlyOfSize, genValue, - genVerificationKey, ) import Test.QuickCheck ( Property, @@ -85,7 +77,6 @@ import Test.QuickCheck ( forAllBlind, oneof, property, - vectorOf, (.&&.), (===), ) @@ -379,79 +370,3 @@ prop_interestingBlueprintTx = do . unRedeemers $ toLedgerTx @Era tx ^. witsTxL . rdmrsTxWitsL ) - --- | Generate a UTXO representing /commit/ outputs for a given list of `Party`. --- NOTE: Uses 'testPolicyId' for the datum. --- NOTE: We don't generate empty commits and it is used only at one place so perhaps move it? --- FIXME: This function is very complicated and it's hard to understand it after a while -generateCommitUTxOs :: [Party] -> Gen (Map.Map TxIn (TxOut CtxUTxO, UTxO)) -generateCommitUTxOs parties = do - txins <- vectorOf (length parties) (arbitrary @TxIn) - let vks = (\p -> (genVerificationKey `genForParty` p, p)) <$> parties - committedUTxO <- - vectorOf (length parties) $ - fmap adaOnly <$> (genOneUTxOFor =<< arbitrary) - let commitUTxO = - zip txins $ - uncurry mkCommitUTxO <$> zip vks committedUTxO - pure $ Map.fromList commitUTxO - where - mkCommitUTxO :: (VerificationKey PaymentKey, Party) -> UTxO -> (TxOut CtxUTxO, UTxO) - mkCommitUTxO (vk, party) utxo = - ( toUTxOContext $ - TxOut - (mkScriptAddress testNetworkId commitScript) - commitValue - (mkTxOutDatumInline commitDatum) - ReferenceScriptNone - , utxo - ) - where - commitValue = - mconcat - [ lovelaceToValue (Coin 2000000) - , foldMap txOutValue utxo - , fromList - [ (AssetId testPolicyId (assetNameFromVerificationKey vk), 1) - ] - ] - - commitScript = fromPlutusScript @PlutusScriptV3 commitValidatorScript - - commitDatum = mkCommitDatum party utxo (toPlutusCurrencySymbol testPolicyId) - --- NOTE: Uses 'testPolicyId' for the datum. -genAbortableOutputs :: [Party] -> Gen ([(TxIn, TxOut CtxUTxO)], [(TxIn, TxOut CtxUTxO, UTxO)]) -genAbortableOutputs parties = - go - where - go = do - (initParties, commitParties) <- (`splitAt` parties) <$> choose (0, length parties) - initials <- mapM genInitial initParties - commits <- fmap (\(a, (b, c)) -> (a, b, c)) . Map.toList <$> generateCommitUTxOs commitParties - pure (initials, commits) - - genInitial p = - mkInitial (genVerificationKey `genForParty` p) <$> arbitrary - - mkInitial :: - VerificationKey PaymentKey -> - TxIn -> - (TxIn, TxOut CtxUTxO) - mkInitial vk txin = - ( txin - , initialTxOut vk - ) - - initialTxOut :: VerificationKey PaymentKey -> TxOut CtxUTxO - initialTxOut vk = - toUTxOContext $ - TxOut - (mkScriptAddress @PlutusScriptV2 testNetworkId initialScript) - (fromList [(AssetId testPolicyId (assetNameFromVerificationKey vk), 1)]) - (mkTxOutDatumInline initialDatum) - ReferenceScriptNone - - initialScript = fromPlutusScript Initial.validatorScript - - initialDatum = Initial.datum (toPlutusCurrencySymbol testPolicyId) diff --git a/hydra-tx/test/Hydra/Tx/Contract/Abort.hs b/hydra-tx/test/Hydra/Tx/Contract/Abort.hs index 96484edc6f3..2743510c854 100644 --- a/hydra-tx/test/Hydra/Tx/Contract/Abort.hs +++ b/hydra-tx/test/Hydra/Tx/Contract/Abort.hs @@ -26,9 +26,10 @@ import Hydra.Tx ( registryUTxO, ) import Hydra.Tx.Abort (abortTx) +import Hydra.Tx.Commit (mkCommitDatum) import Hydra.Tx.ContestationPeriod (toChain) import Hydra.Tx.Init (mkHeadOutputInitial) -import Hydra.Tx.Utils (hydraHeadV1AssetName) +import Hydra.Tx.Utils (adaOnly, hydraHeadV1AssetName, onChainIdToAssetName, verificationKeyToOnChainId) import Test.Hydra.Tx.Fixture ( cperiod, testNetworkId, @@ -36,9 +37,9 @@ import Test.Hydra.Tx.Fixture ( testSeedInput, ) import Test.Hydra.Tx.Gen ( - genAbortableOutputs, genAddressInEra, genForParty, + genOneUTxOFor, genScriptRegistry, genVerificationKey, ) @@ -52,7 +53,7 @@ import Test.Hydra.Tx.Mutation ( removePTFromMintedValue, replacePolicyIdWith, ) -import Test.QuickCheck (Property, choose, counterexample, elements, oneof, shuffle, suchThat) +import Test.QuickCheck (Property, choose, counterexample, elements, oneof, shuffle, suchThat, vectorOf) -- -- AbortTx @@ -257,3 +258,85 @@ genAbortMutation (tx, utxo) = , SomeMutation (pure $ toErrorCode STNotBurned) DoNotBurnSTInitial <$> changeMintedTokens tx (fromList [(AssetId (headPolicyId testSeedInput) hydraHeadV1AssetName, 1)]) ] + +-- * Generators + +-- NOTE: Uses 'testPolicyId' for the datum. +genAbortableOutputs :: [Party] -> Gen ([(TxIn, TxOut CtxUTxO)], [(TxIn, TxOut CtxUTxO, UTxO)]) +genAbortableOutputs parties = + go + where + go = do + (initParties, commitParties) <- (`splitAt` parties) <$> choose (0, length parties) + initials <- mapM genInitial initParties + commits <- fmap (\(a, (b, c)) -> (a, b, c)) . Map.toList <$> generateCommitUTxOs commitParties + pure (initials, commits) + + genInitial p = + mkInitial (genVerificationKey `genForParty` p) <$> arbitrary + + mkInitial :: + VerificationKey PaymentKey -> + TxIn -> + (TxIn, TxOut CtxUTxO) + mkInitial vk txin = + ( txin + , initialTxOut vk + ) + + initialTxOut :: VerificationKey PaymentKey -> TxOut CtxUTxO + initialTxOut vk = + toUTxOContext $ + TxOut + (mkScriptAddress testNetworkId initialScript) + (fromList [(AssetId testPolicyId (assetNameFromVerificationKey vk), 1)]) + (mkTxOutDatumInline initialDatum) + ReferenceScriptNone + + initialScript = fromPlutusScript @PlutusScriptV2 Initial.validatorScript + + initialDatum = Initial.datum (toPlutusCurrencySymbol testPolicyId) + +-- | Generate a UTXO representing /commit/ outputs for a given list of `Party`. +-- NOTE: Uses 'testPolicyId' for the datum. +-- NOTE: We don't generate empty commits and it is used only at one place so perhaps move it? +-- FIXME: This function is very complicated and it's hard to understand it after a while +generateCommitUTxOs :: [Party] -> Gen (Map.Map TxIn (TxOut CtxUTxO, UTxO)) +generateCommitUTxOs parties = do + txins <- vectorOf (length parties) (arbitrary @TxIn) + let vks = (\p -> (genVerificationKey `genForParty` p, p)) <$> parties + committedUTxO <- + vectorOf (length parties) $ + fmap adaOnly <$> (genOneUTxOFor =<< arbitrary) + let commitUTxO = + zip txins $ + uncurry mkCommitUTxO <$> zip vks committedUTxO + pure $ Map.fromList commitUTxO + where + mkCommitUTxO :: (VerificationKey PaymentKey, Party) -> UTxO -> (TxOut CtxUTxO, UTxO) + mkCommitUTxO (vk, party) utxo = + ( toUTxOContext $ + TxOut + (mkScriptAddress testNetworkId commitScript) + commitValue + (mkTxOutDatumInline commitDatum) + ReferenceScriptNone + , utxo + ) + where + commitValue = + mconcat + [ lovelaceToValue (Coin 2000000) + , foldMap txOutValue utxo + , fromList + [ (AssetId testPolicyId (assetNameFromVerificationKey vk), 1) + ] + ] + + commitScript = fromPlutusScript @PlutusScriptV3 commitValidatorScript + + commitDatum = mkCommitDatum party utxo (toPlutusCurrencySymbol testPolicyId) + +assetNameFromVerificationKey :: VerificationKey PaymentKey -> AssetName +assetNameFromVerificationKey = + onChainIdToAssetName . verificationKeyToOnChainId diff --git a/hydra-tx/testlib/Test/Hydra/Tx/Gen.hs b/hydra-tx/testlib/Test/Hydra/Tx/Gen.hs index 400a6419732..5dbde22a6ae 100644 --- a/hydra-tx/testlib/Test/Hydra/Tx/Gen.hs +++ b/hydra-tx/testlib/Test/Hydra/Tx/Gen.hs @@ -24,18 +24,15 @@ import Hydra.Contract.Util (hydraHeadV1) import Hydra.Plutus (commitValidatorScript) import Hydra.Tx (ScriptRegistry (..)) import Hydra.Tx.Close (OpenThreadOutput) -import Hydra.Tx.Commit (mkCommitDatum) import Hydra.Tx.Contest (ClosedThreadOutput) import Hydra.Tx.Crypto (Hash (..)) import Hydra.Tx.Deposit (DepositObservation) import Hydra.Tx.Party (Party (..)) import Hydra.Tx.Recover (RecoverObservation) -import Hydra.Tx.Utils (adaOnly, onChainIdToAssetName, verificationKeyToOnChainId) import PlutusTx.Builtins (fromBuiltin) import Test.Cardano.Ledger.Conway.Arbitrary () -import Test.Hydra.Tx.Fixture (testNetworkId, testPolicyId) import Test.Hydra.Tx.Fixture qualified as Fixtures -import Test.QuickCheck (choose, listOf, oneof, scale, shrinkList, shrinkMapBy, suchThat, vector, vectorOf) +import Test.QuickCheck (listOf, oneof, scale, shrinkList, shrinkMapBy, suchThat, vector, vectorOf) instance Arbitrary AssetName where arbitrary = AssetName . BS.take 32 <$> arbitrary @@ -275,86 +272,6 @@ genMintedOrBurnedValue = do quantity <- arbitrary `suchThat` (/= 0) pure $ fromList [(AssetId policyId tokenName, Quantity quantity)] --- NOTE: Uses 'testPolicyId' for the datum. -genAbortableOutputs :: [Party] -> Gen ([(TxIn, TxOut CtxUTxO)], [(TxIn, TxOut CtxUTxO, UTxO)]) -genAbortableOutputs parties = - go - where - go = do - (initParties, commitParties) <- (`splitAt` parties) <$> choose (0, length parties) - initials <- mapM genInitial initParties - commits <- fmap (\(a, (b, c)) -> (a, b, c)) . Map.toList <$> generateCommitUTxOs commitParties - pure (initials, commits) - - genInitial p = - mkInitial (genVerificationKey `genForParty` p) <$> arbitrary - - mkInitial :: - VerificationKey PaymentKey -> - TxIn -> - (TxIn, TxOut CtxUTxO) - mkInitial vk txin = - ( txin - , initialTxOut vk - ) - - initialTxOut :: VerificationKey PaymentKey -> TxOut CtxUTxO - initialTxOut vk = - toUTxOContext $ - TxOut - (mkScriptAddress testNetworkId initialScript) - (fromList [(AssetId testPolicyId (assetNameFromVerificationKey vk), 1)]) - (mkTxOutDatumInline initialDatum) - ReferenceScriptNone - - initialScript = fromPlutusScript @PlutusScriptV2 Initial.validatorScript - - initialDatum = Initial.datum (toPlutusCurrencySymbol testPolicyId) - --- | Generate a UTXO representing /commit/ outputs for a given list of `Party`. --- NOTE: Uses 'testPolicyId' for the datum. --- NOTE: We don't generate empty commits and it is used only at one place so perhaps move it? --- FIXME: This function is very complicated and it's hard to understand it after a while -generateCommitUTxOs :: [Party] -> Gen (Map.Map TxIn (TxOut CtxUTxO, UTxO)) -generateCommitUTxOs parties = do - txins <- vectorOf (length parties) (arbitrary @TxIn) - let vks = (\p -> (genVerificationKey `genForParty` p, p)) <$> parties - committedUTxO <- - vectorOf (length parties) $ - fmap adaOnly <$> (genOneUTxOFor =<< arbitrary) - let commitUTxO = - zip txins $ - uncurry mkCommitUTxO <$> zip vks committedUTxO - pure $ Map.fromList commitUTxO - where - mkCommitUTxO :: (VerificationKey PaymentKey, Party) -> UTxO -> (TxOut CtxUTxO, UTxO) - mkCommitUTxO (vk, party) utxo = - ( toUTxOContext $ - TxOut - (mkScriptAddress testNetworkId commitScript) - commitValue - (mkTxOutDatumInline commitDatum) - ReferenceScriptNone - , utxo - ) - where - commitValue = - mconcat - [ lovelaceToValue (Coin 2000000) - , foldMap txOutValue utxo - , fromList - [ (AssetId testPolicyId (assetNameFromVerificationKey vk), 1) - ] - ] - - commitScript = fromPlutusScript @PlutusScriptV3 commitValidatorScript - - commitDatum = mkCommitDatum party utxo (toPlutusCurrencySymbol testPolicyId) - -assetNameFromVerificationKey :: VerificationKey PaymentKey -> AssetName -assetNameFromVerificationKey = - onChainIdToAssetName . verificationKeyToOnChainId - -- | Generate a 'TxOut' with a reference script. The standard 'genTxOut' is not -- including reference scripts, use this generator if you are interested in -- these cases.