Merge pull request #1106 from IntersectMBO/jordan/introduce-calculate-min-fee-recursive

Introduce recursive minimum fee calculation

Author: Jimbo4350

cardano-api/cardano-api.cabal

@@ -367,13 +367,15 @@ test-suite cardano-api-test
     cardano-crypto-wrapper:testlib,
     cardano-ledger-alonzo,
     cardano-ledger-api ^>=1.12.1,
+    cardano-ledger-babbage,
     cardano-ledger-binary,
     cardano-ledger-conway,
     cardano-ledger-core >=1.14,
     cardano-ledger-mary,
     cardano-ledger-shelley,
     cardano-protocol-tpraos,
     cardano-slotting,
+    cardano-strict-containers,
     cborg,
     containers,
     data-default,

cardano-api/src/Cardano/Api/Experimental.hs

@@ -25,6 +25,8 @@ module Cardano.Api.Experimental
   , mkTxCertificates
 
     -- ** Transaction fee related
+  , FeeCalculationError (..)
+  , calcMinFeeRecursive
   , estimateBalancedTxBody
   , evaluateTransactionFee
   , collectTxBodyScriptWitnesses

cardano-api/src/Cardano/Api/Experimental/Tx/Internal/Fee.hs

@@ -13,9 +13,11 @@
 {-# LANGUAGE TypeApplications #-}
 
 module Cardano.Api.Experimental.Tx.Internal.Fee
-  ( TxBodyErrorAutoBalance (..)
+  ( FeeCalculationError (..)
+  , TxBodyErrorAutoBalance (..)
   , TxFeeEstimationError (..)
   , calculateMinimumUTxO
+  , calcMinFeeRecursive
   , collectTxBodyScriptWitnesses
   , estimateBalancedTxBody
   , evaluateTransactionExecutionUnits
@@ -83,6 +85,7 @@ import Data.Maybe
 import Data.OSet.Strict qualified as OSet
 import Data.Ord (Down (Down), comparing)
 import Data.Ratio
+import Data.Sequence.Strict qualified as Seq
 import Data.Set (Set)
 import Data.Set qualified as Set
 import GHC.Exts (IsList (..))
@@ -657,6 +660,200 @@ evaluateTransactionFee
 evaluateTransactionFee pp (UnsignedTx tx) keywitcount byronwitcount refScriptsSize =
   L.estimateMinFeeTx pp tx (fromIntegral keywitcount) (fromIntegral byronwitcount) refScriptsSize
 
+data FeeCalculationError
+  = -- | Updating an existing change output resulted in negative ADA.
+    NotEnoughAdaForChangeOutput Coin
+  | -- | Creating a new change output would require negative ADA.
+    NotEnoughAdaForNewOutput Coin
+  | NonAdaAssetsUnbalanced L.MultiAsset
+  | -- | @MinUTxONotMet actual required@: an output does not meet the minimum UTxO requirement.
+    MinUTxONotMet L.Coin L.Coin
+  | FeeCalculationDidNotConverge
+  deriving (Show, Eq)
+
+instance Error FeeCalculationError where
+  prettyError (NotEnoughAdaForChangeOutput balance) =
+    mconcat
+      [ "Not enough ADA when updating existing change output. Balance: "
+      , pretty balance
+      , "\nThis means that the transaction does not have enough ada to cover the fees. The usual solution is to provide more inputs, or inputs with more ada."
+      ]
+  prettyError (NotEnoughAdaForNewOutput balance) =
+    mconcat
+      [ "Not enough ADA when creating new change output. Balance: "
+      , pretty balance
+      , "\nThis means that the transaction does not have enough ada to cover the fees. The usual solution is to provide more inputs, or inputs with more ada."
+      ]
+  prettyError (NonAdaAssetsUnbalanced multiAsset) =
+    mconcat
+      [ "Non-ADA assets are unbalanced: "
+      , pshow multiAsset
+      , "\nThe transaction inputs and minted values do not match the outputs for one or more native tokens."
+      ]
+  prettyError (MinUTxONotMet actual required) =
+    mconcat
+      [ "An output does not meet the minimum UTxO requirement."
+      , "\nActual ADA in output: " <> pretty actual
+      , "\nMinimum required: " <> pretty required
+      , "\nThe usual solution is to provide more ADA inputs to cover the minimum UTxO for outputs carrying native tokens."
+      ]
+  prettyError FeeCalculationDidNotConverge =
+    "Fee calculation did not converge after the maximum number of iterations."
+
+-- | Recursively calculate the minimum fee for a transaction and balance it.
+--
+-- Starting from the provided transaction, this function iteratively adjusts
+-- the fee field and output values until the transaction is fully balanced
+-- (i.e. @inputs + mint + withdrawals + refunds = outputs + fee + deposits@
+-- for all value components: ADA and every native token).
+--
+-- Before entering the iterative loop the multi-asset balance is checked.
+-- Because fee adjustments only affect ADA, a negative multi-asset balance
+-- is unrecoverable and the function returns 'NonAdaAssetsUnbalanced'
+-- immediately.
+--
+-- On each iteration the balance is computed via 'evaluateTransactionBalance'
+-- and the minimum fee via @calcMinFeeTx@. The function then proceeds based
+-- on the following cases, evaluated in order:
+--
+-- * __Case 1 – Fee converged, balance is zero__: The transaction is fully
+--   balanced. Before returning, all outputs are checked against the minimum
+--   UTxO requirement ('MinUTxONotMet'). Note: a 'MinUTxONotMet' error at
+--   this point typically means that Case 2 distributed surplus multi-assets
+--   to an output on a prior iteration but there was not enough ADA surplus
+--   to satisfy the increased @coinPerUTxOByte@ requirement for that output.
+--   The remedy is to provide additional ADA inputs.
+--
+-- * __Case 2 – Fee converged, non-zero balance__: There is surplus or
+--   deficit ADA, excess multi-assets (e.g. from minting), or both. A new
+--   change output is created at the provided change address with the
+--   balance and appended to the end of the existing outputs; if a change
+--   output already exists it is updated in place. If the resulting change
+--   output would have negative ADA, the transaction is unrecoverable and
+--   'NotEnoughAdaForChangeOutput' or 'NotEnoughAdaForNewOutput' is returned. Otherwise the function recurses, because
+--   the changed output may alter the transaction size and therefore the
+--   required fee, and must also satisfy the minimum UTxO
+--   (@coinPerUTxOByte@) constraint.
+--
+-- * __Case 3 – Fee has not converged__: The fee field is set to the newly
+--   computed minimum fee and the function recurses.
+--
+-- A maximum iteration limit (currently 50) guards against non-termination.
+-- In practice convergence occurs within 2–3 iterations.
+calcMinFeeRecursive
+  :: forall era
+   . IsEra era
+  => L.Addr
+  -- ^ Change address. Any surplus value (ADA and/or native tokens) is
+  -- sent to a new output at this address, appended at the end of the
+  -- existing outputs.
+  -> UnsignedTx (LedgerEra era)
+  -> L.UTxO (LedgerEra era)
+  -> L.PParams (LedgerEra era)
+  -> Set PoolId
+  -- ^ The set of registered stake pools. Pool registrations for pools
+  -- already in this set are treated as re-registrations (no deposit
+  -- required on the produced side).
+  -> Map StakeCredential L.Coin
+  -- ^ Deposits for stake credentials being deregistered in this
+  -- transaction. These are counted as refunds on the consumed side.
+  -> Map (Ledger.Credential Ledger.DRepRole) L.Coin
+  -- ^ Deposits for DRep credentials being deregistered in this
+  -- transaction. These are counted as refunds on the consumed side.
+  -> Int
+  -- ^ Number of extra key hashes for native scripts
+  -> Either FeeCalculationError (UnsignedTx (LedgerEra era))
+calcMinFeeRecursive changeAddr unsignedTx utxo pparams poolids stakeDelegDeposits drepDelegDeposits nExtraWitnesses
+  -- If multi-assets are non-negative initially, they stay non-negative across
+  -- iterations (only ADA and fee change), so check once upfront.
+  | multiAssetIsNegative =
+      Left $ NonAdaAssetsUnbalanced multiAssets
+  | otherwise =
+      go maxIterations unsignedTx
+ where
+  initialBalance = evaluateTransactionBalance pparams poolids stakeDelegDeposits drepDelegDeposits utxo unsignedTx
+  multiAssets =
+    obtainCommonConstraints (useEra @era) $
+      let L.MaryValue _ ma = initialBalance
+       in ma
+  -- Check whether any native token quantity is negative.
+  -- ADA is zeroed out so it doesn't influence the check.
+  multiAssetIsNegative =
+    obtainCommonConstraints (useEra @era) $
+      not (L.pointwise (>=) (L.MaryValue (L.Coin 0) multiAssets) mempty)
+  maxIterations :: Int
+  maxIterations = 50
+
+  go
+    :: Int
+    -> UnsignedTx (LedgerEra era)
+    -> Either FeeCalculationError (UnsignedTx (LedgerEra era))
+  go 0 _ = Left FeeCalculationDidNotConverge
+  go n unSignTx@(UnsignedTx ledgerTx)
+    | minFee == txBodyFee && L.isZero txBalanceValue = do
+        -- Case 1
+        let outs = toList $ ledgerTx ^. L.bodyTxL . L.outputsTxBodyL
+        mapM_ (checkOutputMinUTxO pparams) outs
+        return unSignTx
+    | minFee == txBodyFee = do
+        -- Case 2
+        balancedOuts <- balanceTxOuts @era changeAddr txBalanceValue unSignTx
+        let updatedTx = UnsignedTx (ledgerTx & L.bodyTxL . L.outputsTxBodyL .~ balancedOuts)
+        go (n - 1) updatedTx
+    | otherwise =
+        -- Case 3
+        let newTx = UnsignedTx (ledgerTx & L.bodyTxL . L.feeTxBodyL .~ minFee)
+         in go (n - 1) newTx
+   where
+    minFee = obtainCommonConstraints (useEra @era) $ L.calcMinFeeTx utxo pparams ledgerTx nExtraWitnesses
+    txBodyFee = ledgerTx ^. L.bodyTxL . L.feeTxBodyL
+    txBalanceValue =
+      evaluateTransactionBalance pparams poolids stakeDelegDeposits drepDelegDeposits utxo unSignTx
+
+checkOutputMinUTxO
+  :: forall era
+   . IsEra era
+  => Ledger.PParams (LedgerEra era)
+  -> L.TxOut (LedgerEra era)
+  -> Either FeeCalculationError ()
+checkOutputMinUTxO pp out =
+  obtainCommonConstraints (useEra @era) $
+    let txout = TxOut out
+     in case checkMinUTxOValue pp txout of
+          Right () -> Right ()
+          Left (TxOut offending, minRequired) ->
+            Left $ MinUTxONotMet (offending ^. L.coinTxOutL) minRequired
+
+balanceTxOuts
+  :: forall era
+   . HasCallStack
+  => IsEra era
+  => L.Addr
+  -> L.Value (LedgerEra era)
+  -> UnsignedTx (LedgerEra era)
+  -> Either FeeCalculationError (Seq.StrictSeq (L.TxOut (LedgerEra era)))
+balanceTxOuts changeAddr txBalance (UnsignedTx tx) =
+  obtainCommonConstraints (useEra @era) $
+    let outs = tx ^. L.bodyTxL . L.outputsTxBodyL
+     in case outs of
+          rest Seq.:|> lastOut
+            | lastOut ^. L.addrTxOutL == changeAddr ->
+                -- Update existing change output in place.
+                -- We compute the new value before writing it into the TxOut,
+                -- because the ledger's TxOut setter throws an exception on
+                -- negative values.
+                let newValue = (lastOut ^. L.valueTxOutL) <> txBalance
+                    changeCoin = L.coin newValue
+                 in if changeCoin < 0
+                      then Left $ NotEnoughAdaForChangeOutput changeCoin
+                      else Right $ rest Seq.:|> (lastOut & L.valueTxOutL .~ newValue)
+          _ ->
+            -- Append a new change output
+            let changeCoin = L.coin txBalance
+             in if changeCoin < 0
+                  then Left $ NotEnoughAdaForNewOutput changeCoin
+                  else Right $ outs Seq.:|> L.mkBasicTxOut changeAddr txBalance
+
 -- Essentially we check for the existence of collateral inputs. If they exist we
 -- create a fictitious collateral return output. Why? Because we need to put dummy values
 -- to get a fee estimate (i.e we overestimate the fee). The required collateral depends