Refactor minting in cluster tests

hydra-cluster/src/Hydra/Cluster/Faucet.hs

@@ -19,7 +19,7 @@ import Control.Tracer (Tracer, traceWith)
 import Data.Set qualified as Set
 import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
 import GHC.IO.Exception (IOErrorType (ResourceExhausted), IOException (ioe_type))
-import Hydra.Chain.Backend (ChainBackend, buildTransaction, buildTransactionWithPParams')
+import Hydra.Chain.Backend (ChainBackend, buildTransaction, buildTransactionWithMintingScript, buildTransactionWithPParams')
 import Hydra.Chain.Backend qualified as Backend
 import Hydra.Chain.Blockfrost.Client qualified as Blockfrost
 import Hydra.Chain.ScriptRegistry (
@@ -44,8 +44,6 @@ data FaucetLog
   deriving stock (Eq, Show, Generic)
   deriving anyclass (ToJSON)
 
--- | Create a specially marked "seed" UTXO containing requested 'Value' by
--- redeeming funds available to the well-known faucet.
 seedFromFaucet ::
   ChainBackend backend =>
   backend ->
@@ -56,6 +54,21 @@ seedFromFaucet ::
   Tracer IO FaucetLog ->
   IO UTxO
 seedFromFaucet backend receivingVerificationKey val tracer = do
+  seedFromFaucetWithMinting backend receivingVerificationKey val tracer Nothing
+
+-- | Create a specially marked "seed" UTXO containing requested 'Value' by
+-- redeeming funds available to the well-known faucet.
+seedFromFaucetWithMinting ::
+  ChainBackend backend =>
+  backend ->
+  -- | Recipient of the funds
+  VerificationKey PaymentKey ->
+  -- | Value to get from faucet
+  Value ->
+  Tracer IO FaucetLog ->
+  Maybe PlutusScript ->
+  IO UTxO
+seedFromFaucetWithMinting backend receivingVerificationKey val tracer mintingScript = do
   (faucetVk, faucetSk) <- keysFor Faucet
   networkId <- Backend.queryNetworkId backend
   seedTx <- retryOnExceptions tracer $ submitSeedTx faucetVk faucetSk networkId
@@ -66,7 +79,7 @@ seedFromFaucet backend receivingVerificationKey val tracer = do
     faucetUTxO <- findFaucetUTxO networkId backend (selectLovelace val)
     let changeAddress = mkVkAddress networkId faucetVk
 
-    buildTransaction backend changeAddress faucetUTxO (toList $ UTxO.inputSet faucetUTxO) [theOutput networkId] >>= \case
+    buildTransactionWithMintingScript backend changeAddress faucetUTxO (toList $ UTxO.inputSet faucetUTxO) [theOutput networkId] mintingScript >>= \case
       Left e -> throwIO $ FaucetFailedToBuildTx{reason = e}
       Right tx -> do
         let signedTx = sign faucetSk $ getTxBody tx
@@ -121,7 +134,7 @@ seedFromFaucetBlockfrost receivingVerificationKey lovelace = do
   let systemStart = SystemStart $ posixSecondsToUTCTime systemStart'
   eraHistory <- Blockfrost.queryEraHistory
   foundUTxO <- findUTxO networkId changeAddress lovelace
-  case buildTransactionWithPParams' pparams systemStart eraHistory stakePools (mkVkAddress networkId faucetVk) foundUTxO [] [theOutput] of
+  case buildTransactionWithPParams' pparams systemStart eraHistory stakePools (mkVkAddress networkId faucetVk) foundUTxO [] [theOutput] Nothing of
     Left e -> liftIO $ throwIO $ FaucetFailedToBuildTx{reason = e}
     Right tx -> do
       let signedTx = signTx faucetSk tx

hydra-cluster/src/Hydra/Cluster/Scenarios.hs

@@ -101,7 +101,7 @@ import Hydra.Cardano.Api.TxOut (modifyTxOutValue)
 import Hydra.Chain (PostTxError (..))
 import Hydra.Chain.Backend (ChainBackend, buildTransaction, buildTransactionWithPParams, buildTransactionWithPParams')
 import Hydra.Chain.Backend qualified as Backend
-import Hydra.Cluster.Faucet (FaucetLog, createOutputAtAddress, seedFromFaucet, seedFromFaucet_)
+import Hydra.Cluster.Faucet (FaucetLog, createOutputAtAddress, seedFromFaucet, seedFromFaucetWithMinting, seedFromFaucet_)
 import Hydra.Cluster.Faucet qualified as Faucet
 import Hydra.Cluster.Fixture (Actor (..), actorName, alice, aliceSk, aliceVk, bob, bobSk, bobVk, carol, carolSk, carolVk)
 import Hydra.Cluster.Mithril (MithrilLog)
@@ -647,7 +647,7 @@ singlePartyUsesScriptOnL2 tracer workDir backend hydraScriptsTxId =
         systemStart <- Backend.querySystemStart backend QueryTip
         eraHistory <- Backend.queryEraHistory backend QueryTip
         stakePools <- Backend.queryStakePools backend QueryTip
-        case buildTransactionWithPParams' pparams systemStart eraHistory stakePools (mkVkAddress networkId walletVk) utxoToCommit [] [scriptOutput] of
+        case buildTransactionWithPParams' pparams systemStart eraHistory stakePools (mkVkAddress networkId walletVk) utxoToCommit [] [scriptOutput] Nothing of
           Left e -> error $ show e
           Right tx -> do
             let signedL2tx = signTx walletSk tx
@@ -745,7 +745,7 @@ singlePartyUsesWithdrawZeroTrick tracer workDir backend hydraScriptsTxId =
           -- Prepare a tx that re-spends everything owned by walletVk
           pparams <- getProtocolParameters n1
           let change = mkVkAddress networkId walletVk
-          Right tx <- buildTransactionWithPParams pparams backend change utxoToCommit [] []
+          Right tx <- buildTransactionWithPParams pparams backend change utxoToCommit [] [] Nothing
 
           -- Modify the tx to run a script via the withdraw 0 trick
           let redeemer = toLedgerData $ toScriptData ()
@@ -1356,7 +1356,7 @@ canDepositPartially tracer workDir blockTime backend hydraScriptsTxId =
           -- and some ADA is added to it after balancing in the wallet, then we have problems matching on the 'CommitApproved' etc.
           let commitAmount = 5_000_000
           commitUTxOWithoutTokens <- seedFromFaucet backend walletVk (lovelaceToValue seedAmount) (contramap FromFaucet tracer)
-          commitUTxOWithTokens <- seedFromFaucet backend walletVk (lovelaceToValue seedAmount <> tokenAssetValue) (contramap FromFaucet tracer)
+          commitUTxOWithTokens <- seedFromFaucetWithMinting backend walletVk (lovelaceToValue seedAmount <> tokenAssetValue) (contramap FromFaucet tracer) (Just dummyMintingScript)
           -- This one is expected to fail since there is not enough ADA value
           (requestCommitTx' n1 commitUTxOWithoutTokens (Just 10_000_001) Nothing <&> toJSON)
             `shouldThrow` expectErrorStatus 400 (Just "AmountTooLow")

hydra-node/src/Hydra/Chain/Backend.hs

@@ -44,7 +44,24 @@ buildTransaction ::
   IO (Either (TxBodyErrorAutoBalance Era) Tx)
 buildTransaction backend changeAddress body utxoToSpend outs = do
   pparams <- queryProtocolParameters backend CardanoClient.QueryTip
-  buildTransactionWithPParams pparams backend changeAddress body utxoToSpend outs
+  buildTransactionWithPParams pparams backend changeAddress body utxoToSpend outs Nothing
+
+buildTransactionWithMintingScript ::
+  ChainBackend backend =>
+  backend ->
+  -- | Change address to send
+  AddressInEra ->
+  -- | Unspent transaction outputs to spend.
+  UTxO ->
+  -- | Collateral inputs.
+  [TxIn] ->
+  -- | Outputs to create.
+  [TxOut CtxTx] ->
+  Maybe PlutusScript ->
+  IO (Either (TxBodyErrorAutoBalance Era) Tx)
+buildTransactionWithMintingScript backend changeAddress body utxoToSpend outs mintingScript = do
+  pparams <- queryProtocolParameters backend CardanoClient.QueryTip
+  buildTransactionWithPParams pparams backend changeAddress body utxoToSpend outs mintingScript
 
 -- | Construct a simple payment consuming some inputs and producing some
 -- outputs (no certificates or withdrawals involved).
@@ -64,15 +81,17 @@ buildTransactionWithPParams ::
   [TxIn] ->
   -- | Outputs to create.
   [TxOut CtxTx] ->
+  Maybe PlutusScript ->
   IO (Either (TxBodyErrorAutoBalance Era) Tx)
-buildTransactionWithPParams pparams backend changeAddress utxoToSpend collateral outs = do
+buildTransactionWithPParams pparams backend changeAddress utxoToSpend collateral outs mintingScript = do
   systemStart <- querySystemStart backend CardanoClient.QueryTip
   eraHistory <- queryEraHistory backend CardanoClient.QueryTip
   stakePools <- queryStakePools backend CardanoClient.QueryTip
-  pure $ buildTransactionWithPParams' pparams systemStart eraHistory stakePools changeAddress utxoToSpend collateral outs
+  pure $ buildTransactionWithPParams' pparams systemStart eraHistory stakePools changeAddress utxoToSpend collateral outs mintingScript
 
--- | NOTE: If there are any non ADA assets present in the output 'Value'
--- this function will mint them using 'dummyValidatorScript' as the script witness.
+-- | NOTE: If there are any non ADA assets present in the output 'Value' and
+-- minting scrips is specified this function will mint them using provided
+-- script as the script witness.
 buildTransactionWithPParams' ::
   -- | Protocol parameters
   PParams LedgerEra ->
@@ -87,30 +106,45 @@ buildTransactionWithPParams' ::
   [TxIn] ->
   -- | Outputs to create.
   [TxOut CtxTx] ->
+  Maybe PlutusScript ->
   Either (TxBodyErrorAutoBalance Era) Tx
-buildTransactionWithPParams' pparams systemStart eraHistory stakePools changeAddress utxoToSpend collateral outs = do
+buildTransactionWithPParams' pparams systemStart eraHistory stakePools changeAddress utxoToSpend collateral outs mintingScript = do
   buildTransactionWithBody pparams systemStart eraHistory stakePools changeAddress bodyContent utxoToSpend
  where
-  dummyMintingWitness :: ScriptWitness WitCtxMint
-  dummyMintingWitness =
-    mkScriptWitness dummyMintingScript NoScriptDatumForMint (toScriptData ())
-
-  setMintValue =
-    let toMint = valueToPolicyAssets (foldMap txOutValue outs)
-     in if null toMint
-          then TxMintValueNone
-          else
-            TxMintValue $
-              Map.fromList $
-                ( \(pid, assets) ->
-                    ( pid
-                    ,
-                      ( assets
-                      , BuildTxWith dummyMintingWitness
-                      )
+  mintValue =
+    case mintingScript of
+      Nothing -> TxMintValueNone
+      Just _ ->
+        let mintingWitness =
+              mkScriptWitness dummyMintingScript NoScriptDatumForMint (toScriptData ())
+            toMint = valueToPolicyAssets (foldMap txOutValue outs)
+         in if null toMint
+              then TxMintValueNone
+              else
+                TxMintValue $
+                  Map.fromList $
+                    ( \(pid, assets) ->
+                        ( pid
+                        ,
+                          ( assets
+                          , BuildTxWith mintingWitness
+                          )
+                        )
                     )
+                      <$> Map.toList toMint
+  auxScripts =
+    if mintValue == TxMintValueNone
+      then TxAuxScriptsNone
+      else
+        TxAuxScripts
+          ( maybeToList $
+              toScriptInEra
+                ShelleyBasedEraConway
+                ( toScriptInAnyLang $
+                    PlutusScript $
+                      fromMaybe dummyMintingScript mintingScript
                 )
-                  <$> Map.toList toMint
+          )
   -- NOTE: 'makeTransactionBodyAutoBalance' overwrites this.
   bodyContent =
     TxBodyContent
@@ -124,16 +158,13 @@ buildTransactionWithPParams' pparams systemStart eraHistory stakePools changeAdd
       , txValidityLowerBound = TxValidityNoLowerBound
       , txValidityUpperBound = TxValidityNoUpperBound
       , txMetadata = TxMetadataNone
-      , txAuxScripts =
-          if setMintValue == TxMintValueNone
-            then TxAuxScriptsNone
-            else TxAuxScripts (maybeToList $ toScriptInEra ShelleyBasedEraConway (toScriptInAnyLang $ PlutusScript dummyMintingScript))
+      , txAuxScripts = auxScripts
       , txExtraKeyWits = TxExtraKeyWitnessesNone
       , txProtocolParams = BuildTxWith $ Just $ LedgerProtocolParameters pparams
       , txWithdrawals = TxWithdrawalsNone
       , txCertificates = TxCertificatesNone
       , txUpdateProposal = TxUpdateProposalNone
-      , txMintValue = setMintValue
+      , txMintValue = mintValue
       , txScriptValidity = TxScriptValidityNone
       , txProposalProcedures = Nothing
       , txVotingProcedures = Nothing

hydra-node/src/Hydra/Chain/ScriptRegistry.hs

@@ -117,7 +117,7 @@ buildScriptPublishingTxs pparams systemStart networkId eraHistory stakePools ava
   -- Note that we spend the entire UTxO set to cover the deposit scripts, resulting in a squashed UTxO at the end.
   go _ [] = pure []
   go utxo (out : rest) = do
-    tx <- case buildTransactionWithPParams' pparams systemStart eraHistory stakePools changeAddress utxo [] [out] of
+    tx <- case buildTransactionWithPParams' pparams systemStart eraHistory stakePools changeAddress utxo [] [out] Nothing of
       Left err -> throwIO $ FailedToBuildPublishingTx err
       Right tx -> pure $ signTx sk tx