Move / deduplicate genAbortableOutputs (#1694)

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.

---

* [x] CHANGELOG updated not needed
* [x] Documentation updated not needed
* [x] Haddocks update not needed
* [x] No new TODOs introduced

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)

hydra-tx/test/Hydra/Tx/Contract/Abort.hs

@@ -26,19 +26,20 @@ 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,
   testPolicyId,
   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

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.