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.