Introduce recursive minimum fee calculation

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,11 +85,12 @@ 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 (..))
 import GHC.Stack
-import Lens.Micro ((.~), (^.))
+import Lens.Micro ((%~), (.~), (^.))
 import Prettyprinter (punctuate)
 
 data TxBodyErrorAutoBalance era
@@ -657,6 +660,193 @@ evaluateTransactionFee
 evaluateTransactionFee pp (UnsignedTx tx) keywitcount byronwitcount refScriptsSize =
   L.estimateMinFeeTx pp tx (fromIntegral keywitcount) (fromIntegral byronwitcount) refScriptsSize
 
+data FeeCalculationError
+  = NotEnoughAda 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 (NotEnoughAda balance) =
+    mconcat
+      [ "The transaction balance is negative: "
+      , 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).
+--
+-- 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 – Negative multi-asset balance__: The outputs demand more of a
+--   native token than is available from inputs and minting. This is
+--   unrecoverable because fee adjustments only affect ADA — they cannot
+--   change the multi-asset balance. Remedy: provide additional inputs
+--   containing the deficit tokens, mint the missing amount, or reduce the
+--   token quantities in the outputs.
+--   Returns 'NonAdaAssetsUnbalanced'.
+--
+-- * __Case 2 – 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 3 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 3 – 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
+--   'NotEnoughAda' 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 4 – 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 = go maxIterations
+ where
+  maxIterations :: Int
+  maxIterations = 50
+
+  go
+    :: Int
+    -> UnsignedTx (LedgerEra era)
+    -> L.UTxO (LedgerEra era)
+    -> L.PParams (LedgerEra era)
+    -> Set PoolId
+    -> Map StakeCredential L.Coin
+    -> Map (Ledger.Credential Ledger.DRepRole) L.Coin
+    -> Int
+    -> Either FeeCalculationError (UnsignedTx (LedgerEra era))
+  go 0 _ _ _ _ _ _ _ = Left FeeCalculationDidNotConverge
+  go n unSignTx@(UnsignedTx ledgerTx) utxo pparams poolids stakeDelegDeposits drepDelegDeposits nExtraWitnesses
+    | multiAssetIsNegative =
+        -- Case 1
+        Left $ NonAdaAssetsUnbalanced (getMultiAssets (useEra @era) txBalanceValue)
+    | minFee == txBodyFee && L.isZero txBalanceValue = do
+        -- Case 2
+        let outs = toList $ ledgerTx ^. L.bodyTxL . L.outputsTxBodyL
+        mapM_ (checkOutputMinUTxO pparams) outs
+        return unSignTx
+    | minFee == txBodyFee = do
+        -- Case 3
+        balancedOuts <- balanceTxOuts @era changeAddr txBalanceValue unSignTx
+        let updatedTx = UnsignedTx (ledgerTx & L.bodyTxL . L.outputsTxBodyL .~ balancedOuts)
+        go (n - 1) updatedTx utxo pparams poolids stakeDelegDeposits drepDelegDeposits nExtraWitnesses
+    | otherwise =
+        -- Case 4
+        let newTx = UnsignedTx (ledgerTx & L.bodyTxL . L.feeTxBodyL .~ minFee)
+         in go (n - 1) newTx utxo pparams poolids stakeDelegDeposits drepDelegDeposits nExtraWitnesses
+   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
+    txBalanceCoin = L.coin txBalanceValue
+    multiAssetIsNegative =
+      obtainCommonConstraints (useEra @era) $
+        not (L.pointwise (>=) txBalanceValue (L.inject txBalanceCoin))
+
+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
+
+getMultiAssets :: Era era -> L.Value (LedgerEra era) -> L.MultiAsset
+getMultiAssets era val = case era of
+  DijkstraEra -> mempty
+  ConwayEra ->
+    let L.MaryValue _ ma = val
+     in ma
+
+balanceTxOuts
+  :: forall era
+   . 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
+                let updatedOut = lastOut & L.valueTxOutL %~ (<> txBalance)
+                    changeCoin = L.coin (updatedOut ^. L.valueTxOutL)
+                 in if changeCoin < 0
+                      then Left $ NotEnoughAda changeCoin
+                      else Right $ rest Seq.:|> updatedOut
+          _ ->
+            -- Append a new change output
+            let changeCoin = L.coin txBalance
+             in if changeCoin < 0
+                  then Left $ NotEnoughAda 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