Recursive fee calc

Author: Jimbo4350

cabal.project

@@ -28,8 +28,8 @@ extra-packages: Cabal
 -- with solving constraints. Remove this when not needed anymore.
 max-backjumps: 50000
 
-program-options
-  ghc-options: -Werror
+-- program-options
+--   ghc-options: -Werror
 
 package crypton
   -- Using RDRAND instead of /dev/urandom as an entropy source for key

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
+  , RecursiveFeeCalculationError (..)
+  , 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 (..)
+  ( RecursiveFeeCalculationError (..)
+  , 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,16 @@ evaluateTransactionFee
 evaluateTransactionFee pp (UnsignedTx tx) keywitcount byronwitcount refScriptsSize =
   L.estimateMinFeeTx pp tx (fromIntegral keywitcount) (fromIntegral byronwitcount) refScriptsSize
 
+data RecursiveFeeCalculationError = NotEnoughAda Coin deriving (Show, Eq)
+
+instance Error RecursiveFeeCalculationError 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."
+      ]
+
 -- The assumption here is that we are spending a single UTxO
 -- When the fee changes we must also adjust the outputs.
 -- We will make two outputs, one for the change (if any)
@@ -671,46 +684,36 @@ calcMinFeeRecursive
   -> L.PParams (LedgerEra era)
   -> Int
   -- ^ Number of extra key hashes for native scripts
-  -> UnsignedTx (LedgerEra era)
-calcMinFeeRecursive unSignTx@(UnsignedTx ledgerTx) utxo pparams nExtraWitnesses =
-  let sbe = convert useEra
-      minFee = obtainCommonConstraints (useEra @era) $ L.calcMinFeeTx utxo pparams ledgerTx nExtraWitnesses
-
-      txBodyFee = ledgerTx ^. L.bodyTxL . L.feeTxBodyL
-   in if minFee == txBodyFee
-        then
-          let txBalance = evaluateTransactionBalance pparams mempty mempty mempty utxo unSignTx
-           in -- We have reached the minimum fee but there isn't a guarantee that
-              -- the inputs/outputs are balanced
-              if txBalance == 0
-                then unSignTx
-                else
-                  let balancedOuts = balanceTxOuts sbe txBalance txBody
-                      updatedTx = ledgerTx & L.bodyTxL . L.outputsTxBodyL .~ Seq.fromList balancedOuts
-                   in updatedTx
-        -- TODO: We currently just add the balance (positive or negative) to the
-        -- first output. This is not ideal because we could make the transaction invalid
-        -- if we have a negative balance and the resulting output has less then the
-        -- required minimum UTxO value.
-        else
-          let newTx = ledgerTx & L.bodyTxL . L.feeTxBodyL .~ minFee
-           in calcMinFeeRecursive newTx utxo pparams nExtraWitnesses
+  -> Either RecursiveFeeCalculationError (UnsignedTx (LedgerEra era))
+calcMinFeeRecursive unSignTx@(UnsignedTx ledgerTx) utxo pparams nExtraWitnesses
+  | minFee == txBodyFee && L.isZero txBalanceCoin =
+      -- We have reached the minimum fee but there isn't a guarantee that
+      -- the inputs/outputs are balanced
+      return unSignTx
+  | minFee == txBodyFee && txBalanceCoin > 0 =
+      -- We have a surplus balance so we modify the outputs to include it.
+      let balancedOuts = balanceTxOuts txBalanceValue unSignTx
+          updatedTx = UnsignedTx (ledgerTx & L.bodyTxL . L.outputsTxBodyL .~ Seq.fromList balancedOuts)
+       in return updatedTx
+  | txBalanceCoin < 0 = Left $ NotEnoughAda txBalanceCoin
+  | otherwise =
+      let newTx = UnsignedTx (ledgerTx & L.bodyTxL . L.feeTxBodyL .~ minFee)
+       in calcMinFeeRecursive newTx utxo pparams nExtraWitnesses
+ where
+  minFee = obtainCommonConstraints (useEra @era) $ L.calcMinFeeTx utxo pparams ledgerTx nExtraWitnesses
+  txBodyFee = ledgerTx ^. L.bodyTxL . L.feeTxBodyL
+  txBalanceValue = evaluateTransactionBalance pparams mempty mempty mempty utxo unSignTx
+  txBalanceCoin = L.coin txBalanceValue
 
 balanceTxOuts
-  :: IsEra era
-  => TxOutValue era
-  -> L.TxBody (ShelleyLedgerEra era)
-  -> [L.TxOut (ShelleyLedgerEra era)]
-balanceTxOuts sbe txBalance txBody =
-  let outs = toList $ txBody ^. L.outputsTxBodyL
+  :: L.Value (LedgerEra era)
+  -> UnsignedTx (LedgerEra era)
+  -> [L.TxOut (LedgerEra era)]
+balanceTxOuts txBalance (UnsignedTx tx) =
+  let outs = toList $ tx ^. L.bodyTxL . L.outputsTxBodyL
       split = List.uncons outs
-      (h, rest) = maybe (Unsafe.error "calcMinFeeRecursive: No outs!") id split
-      balance =
-        forShelleyBasedEraInEon
-          sbe
-          (L.inject $ txOutValueToLovelace txBalance)
-          (\w -> toLedgerValue w $ txOutValueToValue txBalance)
-      updatedout = h & L.valueTxOutL %~ (<> balance)
+      (h, rest) = maybe (error "calcMinFeeRecursive: No outs!") id split
+      updatedout = h & L.valueTxOutL %~ (<> txBalance)
    in updatedout : rest
 
 -- Essentially we check for the existence of collateral inputs. If they exist we

cardano-api/test/cardano-api-test/Test/Cardano/Api/Experimental.hs

@@ -15,24 +15,34 @@ import Cardano.Api.Experimental qualified as Exp
 import Cardano.Api.Experimental.Era (convert)
 import Cardano.Api.Experimental.Tx qualified as Exp
 import Cardano.Api.Genesis qualified as Genesis
+import Cardano.Api.Ledger qualified as L
 import Cardano.Api.Ledger qualified as Ledger
+import Cardano.Api.Parser.Text qualified as Api
 import Cardano.Api.Plutus qualified as Script
 import Cardano.Api.Tx (Tx (ShelleyTx))
 
+import Cardano.Ledger.Address qualified as L
 import Cardano.Ledger.Alonzo.Scripts qualified as UnexportedLedger
 import Cardano.Ledger.Api qualified as UnexportedLedger
+import Cardano.Ledger.Babbage.TxBody qualified as L
+import Cardano.Ledger.Conway qualified as L
+import Cardano.Ledger.Core qualified as L
+import Cardano.Ledger.Credential qualified as L
+import Cardano.Ledger.Plutus.Data qualified as L
 import Cardano.Slotting.EpochInfo qualified as Slotting
 import Cardano.Slotting.Slot qualified as Slotting
 import Cardano.Slotting.Time qualified as Slotting
 
 import Control.Monad.Identity (Identity)
 import Data.Bifunctor (first)
+import Data.Map.Strict qualified as Map
 import Data.Maybe (fromMaybe)
+import Data.Maybe.Strict (StrictMaybe (..))
 import Data.Ratio ((%))
 import Data.Text.Encoding qualified as Text
 import Data.Time qualified as Time
 import Data.Time.Clock.POSIX qualified as Time
-import Lens.Micro ((&))
+import Lens.Micro
 
 import Test.Gen.Cardano.Api.Typed (genTx)
 
@@ -126,10 +136,55 @@ prop_balance_transaction_two_ways = H.propertyOnce $ do
   -- Old API
   let oldFees = Api.evaluateTransactionFee sbe exampleProtocolParams txBody 0 1 0
       -- NEW API
-      newFees = Exp.evaluateTransactionFee exampleProtocolParams (Exp.makeUnsignedTx era newTxBodyContent) 0 1 0
+      unSignTx = Exp.makeUnsignedTx era newTxBodyContent
+      newFees = Exp.evaluateTransactionFee exampleProtocolParams unSignTx 0 1 0
+
+  -- Recursive calc
+  dummyTxIn <-
+    H.evalEither
+      ( Api.toShelleyTxIn
+          <$> Api.runParser
+            Api.parseTxIn
+            "be6efd42a3d7b9a00d09d77a5d41e55ceaf0bd093a8aa8a893ce70d9caafd978#0"
+      )
+
+  let paymentCredential :: L.PaymentCredential
+      paymentCredential =
+        L.KeyHashObj $
+          L.KeyHash
+            "1c14ee8e58fbcbd48dc7367c95a63fd1d937ba989820015db16ac7e5"
+
+      stakingCredential :: L.StakeCredential
+      stakingCredential =
+        L.KeyHashObj $
+          L.KeyHash
+            "e37a65ea2f9bcefb645de4312cf13d8ac12ae61cf242a9aa2973c9ee"
+      initialFundedAddress :: L.Addr
+      initialFundedAddress = L.Addr L.Testnet paymentCredential (L.StakeRefBase stakingCredential)
+      dummyLargeTxOut :: L.BabbageTxOut L.ConwayEra =
+        Exp.obtainCommonConstraints era $
+          L.BabbageTxOut
+            initialFundedAddress
+            (L.MaryValue (L.Coin 12_000_000) mempty)
+            L.NoDatum
+            SNothing
+
+      dummyUTxO = L.UTxO $ Map.singleton dummyTxIn dummyLargeTxOut
+  Exp.UnsignedTx recFeeTx <-
+    H.evalEither $ Exp.calcMinFeeRecursive unSignTx dummyUTxO exampleProtocolParams 0
+  let recFee = recFeeTx ^. (L.bodyTxL . L.feeTxBodyL)
   H.note_ $ "Fees 1: " <> show oldFees
 
-  oldFees H.=== newFees
+  oldFees H.=== L.Coin 236
+
+  newFees H.=== L.Coin 236
+
+  -- Recursive fee calculation appears result in fees that are ~ 20% lower
+  recFee H.=== L.Coin 193
+
+  H.assert $ recFee < oldFees
+
+  H.assert $ recFee < newFees
 
   -- Balance without ledger context (other that protocol parameters)
   -- Old api