Improve fee estimation in internal wallet

CHANGELOG.md

@@ -23,11 +23,15 @@ changes.
 
 - Add `--sanchonet` option to `hydra-cluster` binary.
 
+- Reduce cost of transactions submitted by `hydra-node` by better estimating
+  fees in internal wallet
+  [#1315](https://github.com/input-output-hk/hydra/pull/1315).
+
 ## [0.15.0] - 2024-01-18
 
 - Tested with `cardano-node 8.7.3` and `cardano-cli 8.17.0.0`.
 
-- **BREAKING** Remove head state from `hydra-node` chain layer [1196](https://github.com/input-output-hk/hydra/pull/1196):
+- **BREAKING** Remove head state from `hydra-node` chain layer [#1196](https://github.com/input-output-hk/hydra/pull/1196):
   - Not maintain head state in the chain layer anymore and all decision making (whether it's "our" head) is now fully contained in the logic layer.
   - This is a breaking change on the persisted `state` file, which now only stores so-called `spendableUTxO`. This raises a `PersistenceException` if an incompatible `state` file is loaded.
   - Heads need to be closed before upgrade to this version, as wiping `state` in the `--persistence-dir` is needed.

hydra-node/src/Hydra/Chain/Direct/Wallet.hs

@@ -12,16 +12,28 @@ import Cardano.Crypto.Hash.Class
 import Cardano.Ledger.Address qualified as Ledger
 import Cardano.Ledger.Alonzo.Plutus.TxInfo (TranslationError)
 import Cardano.Ledger.Alonzo.PlutusScriptApi (language)
-import Cardano.Ledger.Alonzo.Scripts (ExUnits (ExUnits), Tag (Spend), txscriptfee)
+import Cardano.Ledger.Alonzo.Scripts (ExUnits (ExUnits), Tag (Spend))
 import Cardano.Ledger.Alonzo.TxWits (AlonzoTxWits (..), RdmrPtr (RdmrPtr), Redeemers (..), txdats, txscripts)
-import Cardano.Ledger.Api (TransactionScriptFailure, ensureMinCoinTxOut, evalTxExUnits, outputsTxBodyL, ppMaxTxExUnitsL, ppPricesL)
+import Cardano.Ledger.Api (
+  TransactionScriptFailure,
+  bodyTxL,
+  collateralInputsTxBodyL,
+  ensureMinCoinTxOut,
+  evalTxExUnits,
+  feeTxBodyL,
+  inputsTxBodyL,
+  outputsTxBodyL,
+  ppMaxTxExUnitsL,
+  rdmrsTxWitsL,
+  scriptIntegrityHashTxBodyL,
+  witsTxL,
+ )
 import Cardano.Ledger.Babbage.Tx (body, getLanguageView, hashScriptIntegrity, wits)
 import Cardano.Ledger.Babbage.Tx qualified as Babbage
-import Cardano.Ledger.Babbage.TxBody (BabbageTxBody (..), spendInputs')
+import Cardano.Ledger.Babbage.TxBody (spendInputs')
 import Cardano.Ledger.Babbage.TxBody qualified as Babbage
 import Cardano.Ledger.Babbage.UTxO (getReferenceScripts)
 import Cardano.Ledger.BaseTypes qualified as Ledger
-import Cardano.Ledger.Binary (mkSized)
 import Cardano.Ledger.Coin (Coin (..))
 import Cardano.Ledger.Core (isNativeScript)
 import Cardano.Ledger.Core qualified as Core
@@ -31,18 +43,19 @@ import Cardano.Ledger.Hashes (EraIndependentTxBody)
 import Cardano.Ledger.SafeHash qualified as SafeHash
 import Cardano.Ledger.Shelley.API (unUTxO)
 import Cardano.Ledger.Shelley.API qualified as Ledger
+import Cardano.Ledger.Shelley.API.Wallet (evaluateTransactionFee)
 import Cardano.Ledger.Val (Val (..), invert)
 import Cardano.Slotting.EpochInfo (EpochInfo)
 import Cardano.Slotting.Time (SystemStart (..))
 import Control.Arrow (left)
 import Control.Concurrent.Class.MonadSTM (check, newTVarIO, readTVarIO, writeTVar)
-import Control.Lens ((^.))
+import Control.Lens ((%~), (.~), (^.))
 import Data.List qualified as List
 import Data.Map.Strict ((!))
 import Data.Map.Strict qualified as Map
 import Data.Maybe.Strict (StrictMaybe (..))
 import Data.Ratio ((%))
-import Data.Sequence.Strict qualified as StrictSeq
+import Data.Sequence.Strict ((|>))
 import Data.Set qualified as Set
 import Hydra.Cardano.Api (
   BlockHeader,
@@ -60,7 +73,6 @@ import Hydra.Cardano.Api (
   fromLedgerTxOut,
   fromLedgerUTxO,
   getChainPoint,
-  ledgerEraVersion,
   makeShelleyAddress,
   selectLovelace,
   shelleyAddressInEra,
@@ -226,7 +238,6 @@ data ChangeError = ChangeError {inputBalance :: Coin, outputBalance :: Coin}
 -- necessary fees and augments inputs / outputs / collateral accordingly to
 -- cover for the transaction cost and get the change back.
 --
--- TODO: The fee calculation is currently very dumb and static.
 -- XXX: All call sites of this function use cardano-api types
 coverFee_ ::
   Core.PParams LedgerEra ->
@@ -237,72 +248,81 @@ coverFee_ ::
   Babbage.AlonzoTx LedgerEra ->
   Either ErrCoverFee (Babbage.AlonzoTx LedgerEra)
 coverFee_ pparams systemStart epochInfo lookupUTxO walletUTxO [email protected]{body, wits} = do
-  (input, output) <- findUTxOToPayFees walletUTxO
+  (feeTxIn, feeTxOut) <- findUTxOToPayFees walletUTxO
 
-  let newInputs = spendInputs' body <> Set.singleton input
+  let newInputs = spendInputs' body <> Set.singleton feeTxIn
   resolvedInputs <- traverse resolveInput (toList newInputs)
 
+  -- Ensure we have at least the minimum amount of ada. NOTE: setMinCoinTxOut
+  -- would invalidate most Hydra protocol transactions.
+  let txOuts = body ^. outputsTxBodyL <&> ensureMinCoinTxOut pparams
+
+  -- Compute costs of redeemers
   let utxo = lookupUTxO <> walletUTxO
-  estimatedScriptCosts <-
-    estimateScriptsCost pparams systemStart epochInfo utxo partialTx
+  estimatedScriptCosts <- estimateScriptsCost pparams systemStart epochInfo utxo partialTx
   let adjustedRedeemers =
         adjustRedeemers
           (spendInputs' body)
           newInputs
           estimatedScriptCosts
           (txrdmrs wits)
-      needlesslyHighFee = calculateNeedlesslyHighFee adjustedRedeemers
-
-  -- Ensure we have at least the minimum amount of ada. NOTE: setMinCointTxOut
-  -- would invalidate most Hydra protocol transactions.
-  let txOuts = body ^. outputsTxBodyL <&> ensureMinCoinTxOut pparams
-
-  -- Add a change output
-  change <-
-    first ErrNotEnoughFunds $
-      mkChange
-        output
-        resolvedInputs
-        (toList txOuts)
-        needlesslyHighFee
-  let newOutputs = txOuts <> StrictSeq.singleton change
 
-      referenceScripts = getReferenceScripts @LedgerEra (Ledger.UTxO utxo) (Babbage.referenceInputs' body)
+  -- Compute script integrity hash from adjusted redeemers
+  let referenceScripts = getReferenceScripts @LedgerEra (Ledger.UTxO utxo) (Babbage.referenceInputs' body)
       langs =
         [ getLanguageView pparams l
         | (_hash, script) <- Map.toList $ Map.union (txscripts wits) referenceScripts
         , (not . isNativeScript @LedgerEra) script
         , l <- maybeToList (language script)
         ]
-      finalBody =
-        body
-          { btbInputs = newInputs
-          , btbOutputs = mkSized ledgerEraVersion <$> newOutputs
-          , btbCollateral = Set.singleton input
-          , btbTxFee = needlesslyHighFee
-          , btbScriptIntegrityHash =
-              hashScriptIntegrity
-                (Set.fromList langs)
-                adjustedRedeemers
-                (txdats wits)
-          }
+      scriptIntegrityHash =
+        hashScriptIntegrity
+          (Set.fromList langs)
+          adjustedRedeemers
+          (txdats wits)
+
+  let
+    unbalancedBody =
+      body
+        & inputsTxBodyL .~ newInputs
+        & outputsTxBodyL .~ txOuts
+        & collateralInputsTxBodyL .~ Set.singleton feeTxIn
+        & scriptIntegrityHashTxBodyL .~ scriptIntegrityHash
+    unbalancedTx =
+      partialTx
+        & bodyTxL .~ unbalancedBody
+        & witsTxL . rdmrsTxWitsL .~ adjustedRedeemers
+
+  -- Compute fee using a body with selected txOut to pay fees (= full change)
+  -- and an aditional witness (we will sign this tx later)
+  let fee = evaluateTransactionFee pparams costingTx additionalWitnesses
+      costingTx =
+        unbalancedTx
+          & bodyTxL . outputsTxBodyL %~ (|> feeTxOut)
+          & bodyTxL . feeTxBodyL .~ Coin 10_000_000
+      -- XXX: Not hard-code but parameterize to make this flexible enough for
+      -- later signing and commit transactions with more than one sig
+      additionalWitnesses = 2
+
+  -- Balance tx with a change output and computed fee
+  change <-
+    first ErrNotEnoughFunds $
+      mkChange
+        feeTxOut
+        resolvedInputs
+        (toList txOuts)
+        fee
   pure $
-    partialTx
-      { body = finalBody
-      , wits = wits{txrdmrs = adjustedRedeemers}
-      }
+    unbalancedTx
+      & bodyTxL . outputsTxBodyL %~ (|> change)
+      & bodyTxL . feeTxBodyL .~ fee
  where
   findUTxOToPayFees utxo = case findLargestUTxO utxo of
     Nothing ->
       Left ErrNoFuelUTxOFound
     Just (i, o) ->
       Right (i, o)
 
-  -- TODO: Do a better fee estimation based on the transaction's content.
-  calculateNeedlesslyHighFee (Redeemers redeemers) =
-    let executionCost = txscriptfee (pparams ^. ppPricesL) $ foldMap snd redeemers
-     in Coin 2_000_000 <> executionCost
-
   getAdaValue :: TxOut -> Coin
   getAdaValue (Babbage.BabbageTxOut _ value _ _) =
     coin value

hydra-node/test/Hydra/Chain/Direct/WalletSpec.hs

@@ -5,7 +5,7 @@ module Hydra.Chain.Direct.WalletSpec where
 import Hydra.Prelude
 import Test.Hydra.Prelude
 
-import Cardano.Ledger.Api (bodyTxL, coinTxOutL, outputsTxBodyL)
+import Cardano.Ledger.Api (EraTx (getMinFeeTx), EraTxBody (feeTxBodyL), PParams, bodyTxL, coinTxOutL, outputsTxBodyL)
 import Cardano.Ledger.Babbage.Tx (AlonzoTx (..))
 import Cardano.Ledger.Babbage.TxBody (BabbageTxBody (..), BabbageTxOut (..))
 import Cardano.Ledger.BaseTypes qualified as Ledger
@@ -43,6 +43,7 @@ import Hydra.Cardano.Api (
 import Hydra.Cardano.Api qualified as Api
 import Hydra.Cardano.Api.Prelude (fromShelleyPaymentCredential)
 import Hydra.Cardano.Api.Pretty (renderTx)
+import Hydra.Cardano.Api.Tx (signTx, toLedgerTx)
 import Hydra.Chain.CardanoClient (QueryPoint (..))
 import Hydra.Chain.Direct.Fixture qualified as Fixture
 import Hydra.Chain.Direct.Wallet (
@@ -57,10 +58,11 @@ import Hydra.Chain.Direct.Wallet (
   findLargestUTxO,
   newTinyWallet,
  )
-import Hydra.Ledger.Cardano (genKeyPair, genOneUTxOFor)
+import Hydra.Ledger.Cardano (genKeyPair, genOneUTxOFor, genSigningKey)
 import Test.QuickCheck (
   Property,
   checkCoverage,
+  conjoin,
   counterexample,
   cover,
   forAll,
@@ -73,6 +75,7 @@ import Test.QuickCheck (
   scale,
   suchThat,
   vectorOf,
+  (.&&.),
  )
 import Prelude qualified
 
@@ -226,11 +229,39 @@ prop_balanceTransaction =
           Left err ->
             property False
               & counterexample ("Error: " <> show err)
-              & counterexample ("Lookup UTXO: \n" <> decodeUtf8 (encodePretty lookupUTxO))
-              & counterexample ("Wallet UTXO: \n" <> decodeUtf8 (encodePretty walletUTxO))
-              & counterexample (renderTx $ fromLedgerTx tx)
           Right tx' ->
-            isBalanced (lookupUTxO <> walletUTxO) tx tx'
+            forAllBlind genSigningKey $ \sk -> do
+              -- NOTE: Testing the signed transaction as adding a witness
+              -- changes the fee requirements.
+              let signedTx = toLedgerTx $ signTx sk (fromLedgerTx tx')
+              conjoin
+                [ isBalanced (lookupUTxO <> walletUTxO) tx signedTx
+                , hasLowFees Fixture.pparams signedTx
+                ]
+                & counterexample ("Signed tx: \n" <> renderTx (fromLedgerTx signedTx))
+                & counterexample ("Balanced tx: \n" <> renderTx (fromLedgerTx tx'))
+          & counterexample ("Partial tx: \n" <> renderTx (fromLedgerTx tx))
+          & counterexample ("Lookup UTXO: \n" <> decodeUtf8 (encodePretty lookupUTxO))
+          & counterexample ("Wallet UTXO: \n" <> decodeUtf8 (encodePretty walletUTxO))
+
+hasLowFees :: PParams LedgerEra -> Tx LedgerEra -> Property
+hasLowFees pparams tx =
+  counterexample ("PParams: " <> show pparams) $
+    notTooLow .&&. notTooHigh
+ where
+  notTooLow =
+    actualFee >= minFee
+      & counterexample ("Fee too low: " <> show actualFee <> " < " <> show minFee)
+
+  notTooHigh =
+    actualFee < minFee <+> acceptableOverestimation
+      & counterexample ("Fee too high: " <> show actualFee <> " > " <> show (minFee <+> acceptableOverestimation))
+
+  acceptableOverestimation = Coin 100_000
+
+  actualFee = tx ^. bodyTxL . feeTxBodyL
+
+  minFee = getMinFeeTx pparams tx
 
 isBalanced :: Map TxIn TxOut -> Tx LedgerEra -> Tx LedgerEra -> Property
 isBalanced utxo originalTx balancedTx =