Adjust UTxO set when building publish script txs (#1961)

Currently, Hydra needs to build 3 txs to publish scripts. Each is built
using the faucet UTxO.

This logic was adjusting the first selected UTxO repeatedly, causing the
following [CI
failure](https://github.com/cardano-scaling/hydra/actions/runs/14612733559/job/41012379950):
```
hydra-cluster: Illegal Value in TxOut: MaryValue (Coin (-64520700)) (MultiAsset (fromList []))
```

Now:
- we adjust the entire UTxO set on every tx build iteration, and then
- we select all outputs associated with the key address (instead of just
the first matching one).

<!-- Describe your change here -->

---

<!-- Consider each and tick it off one way or the other -->
* [ ] CHANGELOG updated or not needed
* [x] Documentation updated or not needed
* [x] Haddocks updated or not needed
* [x] No new TODOs introduced or explained herafter

Author: ch1bo

hydra-cluster/test/Test/Hydra/Cluster/FaucetSpec.hs

@@ -8,21 +8,21 @@ import CardanoNode (withCardanoNodeDevnet)
 import Control.Concurrent.Async (replicateConcurrently)
 import Hydra.Cardano.Api (Coin (..), selectLovelace, txOutValue)
 import Hydra.Chain.CardanoClient (QueryPoint (..), queryUTxOFor)
-import Hydra.Cluster.Faucet (returnFundsToFaucet, seedFromFaucet)
+import Hydra.Cluster.Faucet (FaucetLog, publishHydraScriptsAs, returnFundsToFaucet, seedFromFaucet)
 import Hydra.Cluster.Fixture (Actor (..))
 import Hydra.Cluster.Scenarios (EndToEndLog (..))
 import Hydra.Cluster.Util (keysFor)
 import Hydra.Logging (Tracer, showLogsOnFailure)
 import Test.Hydra.Tx.Gen (genVerificationKey)
 import Test.QuickCheck (choose, elements, forAll, generate, withMaxSuccess)
 
-setupDevnet :: ((Tracer IO EndToEndLog, RunningNode) -> IO a) -> IO a
+setupDevnet :: ((Tracer IO FaucetLog, RunningNode) -> IO a) -> IO a
 setupDevnet action =
   failAfter 30 $
     showLogsOnFailure "FaucetSpec" $ \tracer ->
       withTempDir "hydra-cluster" $ \tmpDir ->
         withCardanoNodeDevnet (contramap FromCardanoNode tracer) tmpDir $ \node ->
-          action (tracer, node)
+          action (contramap FromFaucet tracer, node)
 
 spec :: Spec
 spec =
@@ -31,24 +31,23 @@ spec =
       it "should work concurrently when called multiple times with the same amount of lovelace" $ \(tracer, node) -> do
         utxos <- replicateConcurrently 10 $ do
           vk <- generate genVerificationKey
-          seedFromFaucet node vk 1_000_000 (contramap FromFaucet tracer)
+          seedFromFaucet node vk 1_000_000 tracer
         -- 10 unique outputs
         length (fold utxos) `shouldBe` 10
 
     describe "returnFundsToFaucet" $ do
       it "does nothing if nothing to return" $ \(tracer, node) -> do
-        returnFundsToFaucet (contramap FromFaucet tracer) node Alice
+        returnFundsToFaucet tracer node Alice
 
       it "seedFromFaucet and returnFundsToFaucet should work together" $ \(tracer, node@RunningNode{networkId, nodeSocket}) -> do
         withMaxSuccess 10 $
           forAll (Coin <$> choose (1000000, 10000000000)) $ \coin ->
             forAll (elements [Alice, Bob, Carol]) $ \actor -> do
-              let faucetTracer = contramap FromFaucet tracer
               (vk, _) <- keysFor actor
               (faucetVk, _) <- keysFor Faucet
               initialFaucetFunds <- queryUTxOFor networkId nodeSocket QueryTip faucetVk
-              void $ seedFromFaucet node vk coin faucetTracer
-              returnFundsToFaucet faucetTracer node actor
+              void $ seedFromFaucet node vk coin tracer
+              returnFundsToFaucet tracer node actor
               remaining <- queryUTxOFor networkId nodeSocket QueryTip vk
               finalFaucetFunds <- queryUTxOFor networkId nodeSocket QueryTip faucetVk
               foldMap txOutValue remaining `shouldBe` mempty
@@ -62,3 +61,17 @@ spec =
               -- difference between starting faucet amount and final one should
               -- just be the amount of paid fees
               difference `shouldSatisfy` (< 400_000)
+
+    describe "publishHydraScriptsAs" $ do
+      it "selects a suitable output" $ \(tracer, node@RunningNode{networkId, nodeSocket}) -> do
+        -- NOTE: Note use 'Faucet' as this has a very big initial amount
+        (vk, _) <- keysFor Alice
+        -- NOTE: 83 ADA is just enough to pay for reference scripts deposits.
+        forM_ [1_000_000, 2_000_000, 83_000_000] $ \c -> seedFromFaucet node vk c tracer
+        utxoBefore <- queryUTxOFor networkId nodeSocket QueryTip vk
+
+        void $ publishHydraScriptsAs node Alice
+
+        -- Also, does not squash UTxO
+        utxoAfter <- queryUTxOFor networkId nodeSocket QueryTip vk
+        length utxoAfter `shouldBe` length utxoBefore

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

@@ -5,42 +5,40 @@ module Hydra.Chain.ScriptRegistry where
 import Hydra.Prelude
 
 import Cardano.Api.UTxO qualified as UTxO
+import Data.List ((!!))
 import Hydra.Cardano.Api (
-  AddressInEra,
+  Coin,
+  Era,
   EraHistory,
   Key (..),
   LedgerEra,
   NetworkId,
   PParams,
   PaymentKey,
-  PlutusScript,
   PoolId,
-  ShelleyWitnessSigningKey (WitnessPaymentKey),
   SigningKey,
   SocketPath,
   SystemStart,
   Tx,
-  TxBody,
+  TxBodyErrorAutoBalance,
   TxId,
   TxIn (..),
   TxIx (..),
   UTxO,
   WitCtx (..),
   examplePlutusScriptAlwaysFails,
-  getTxBody,
-  isKeyAddress,
-  makeShelleyKeyWitness,
-  makeSignedTransaction,
   mkScriptAddress,
   mkScriptRef,
+  mkTxIn,
   mkTxOutAutoBalance,
   mkVkAddress,
   selectLovelace,
-  throwErrorAsException,
-  txOutAddress,
+  toCtxUTxOTxOut,
   txOutValue,
+  txOuts',
   pattern TxOutDatumNone,
  )
+import Hydra.Cardano.Api.Tx (signTx)
 import Hydra.Chain.CardanoClient (
   QueryPoint (..),
   awaitTransaction,
@@ -54,7 +52,6 @@ import Hydra.Chain.CardanoClient (
   submitTransaction,
  )
 import Hydra.Contract.Head qualified as Head
-import Hydra.Ledger.Cardano (adjustUTxO)
 import Hydra.Plutus (commitValidatorScript, initialValidatorScript)
 import Hydra.Tx (txId)
 import Hydra.Tx.ScriptRegistry (ScriptRegistry (..), newScriptRegistry)
@@ -105,54 +102,56 @@ publishHydraScripts networkId socketPath sk = do
  where
   vk = getVerificationKey sk
 
+-- | Exception raised when building the script publishing transactions.
+data PublishScriptException
+  = FailedToBuildPublishingTx (TxBodyErrorAutoBalance Era)
+  | FailedToFindUTxOToCoverDeposit {totalDeposit :: Coin}
+  deriving (Show)
+  deriving anyclass (Exception)
+
+-- | Builds a chain of script publishing transactions.
+-- Throws: PublishScriptException
 buildScriptPublishingTxs ::
+  MonadThrow m =>
   PParams LedgerEra ->
   SystemStart ->
   NetworkId ->
   EraHistory ->
   Set PoolId ->
+  -- | Outputs that can be spent by signing key.
   UTxO ->
+  -- | Key owning funds to pay deposit and fees.
   SigningKey PaymentKey ->
-  IO [Tx]
-buildScriptPublishingTxs pparams systemStart networkId eraHistory stakePools startUTxO sk =
-  flip evalStateT (startUTxO, []) $
-    forM scripts $ \script -> do
-      (nextUTxO, _) <- get
-      (tx, _, spentUTxO) <- liftIO $ buildScriptPublishingTx pparams systemStart networkId eraHistory stakePools changeAddress sk script nextUTxO
-      modify' (\(_, existingTxs) -> (pickKeyAddressUTxO $ adjustUTxO tx spentUTxO, tx : existingTxs))
-      pure tx
+  m [Tx]
+buildScriptPublishingTxs pparams systemStart networkId eraHistory stakePools availableUTxO sk = do
+  startUTxO <- findUTxO
+  go startUTxO scriptOutputs
  where
-  pickKeyAddressUTxO utxo = maybe mempty UTxO.singleton $ UTxO.findBy (\(_, txOut) -> isKeyAddress (txOutAddress txOut)) utxo
+  -- Find a suitable utxo that covers at least the total deposit
+  findUTxO =
+    case UTxO.find (\o -> selectLovelace (txOutValue o) > totalDeposit) availableUTxO of
+      Nothing -> throwIO FailedToFindUTxOToCoverDeposit{totalDeposit}
+      Just (i, o) -> pure $ UTxO.singleton (i, o)
 
-  scripts = [initialValidatorScript, commitValidatorScript, Head.validatorScript]
+  totalDeposit = sum $ selectLovelace . txOutValue <$> scriptOutputs
 
-  vk = getVerificationKey sk
+  scriptOutputs =
+    mkScriptTxOut . mkScriptRef
+      <$> [initialValidatorScript, commitValidatorScript, Head.validatorScript]
 
-  changeAddress = mkVkAddress networkId vk
+  -- Loop over all script outputs to create while re-spending the change output
+  go _ [] = pure []
+  go utxo (out : rest) = do
+    tx <- case buildTransactionWithPParams' pparams systemStart eraHistory stakePools changeAddress utxo [] [out] of
+      Left err -> throwIO $ FailedToBuildPublishingTx err
+      Right tx -> pure $ signTx sk tx
+
+    let changeOutput = txOuts' tx !! 1
+        utxo' = UTxO.singleton (mkTxIn tx 1, toCtxUTxOTxOut changeOutput)
+    (tx :) <$> go utxo' rest
+
+  changeAddress = mkVkAddress networkId (getVerificationKey sk)
 
-buildScriptPublishingTx ::
-  PParams LedgerEra ->
-  SystemStart ->
-  NetworkId ->
-  EraHistory ->
-  Set PoolId ->
-  AddressInEra ->
-  SigningKey PaymentKey ->
-  PlutusScript ->
-  UTxO.UTxO ->
-  IO (Tx, TxBody, UTxO.UTxO)
-buildScriptPublishingTx pparams systemStart networkId eraHistory stakePools changeAddress sk script utxo =
-  let output = mkScriptTxOut <$> [mkScriptRef script]
-      totalDeposit = sum (selectLovelace . txOutValue <$> output)
-      utxoToSpend =
-        maybe mempty UTxO.singleton $
-          UTxO.find (\o -> selectLovelace (txOutValue o) > totalDeposit) utxo
-   in case buildTransactionWithPParams' pparams systemStart eraHistory stakePools changeAddress utxoToSpend [] output of
-        Left e -> throwErrorAsException e
-        Right rawTx -> do
-          let body = getTxBody rawTx
-          pure (makeSignedTransaction [makeShelleyKeyWitness body (WitnessPaymentKey sk)] body, body, utxoToSpend)
- where
   mkScriptTxOut =
     mkTxOutAutoBalance
       pparams