Improve autobalancing errors when change has no lovelace

Author: carbolymer

cardano-api/src/Cardano/Api/Internal/Fees.hs

@@ -643,13 +643,16 @@ estimateBalancedTxBody
         balance =
           evaluateTransactionBalance sbe pparams poolids stakeDelegDeposits drepDelegDeposits fakeUTxO txbody2
         balanceTxOut = TxOut changeaddr balance TxOutDatumNone ReferenceScriptNone
-    -- check if the balance is positive or negative
-    -- in one case we can produce change, in the other the inputs are insufficient
-    first TxFeeEstimationBalanceError $ balanceCheck sbe pparams balanceTxOut
 
     -- Step 6. Check all txouts have the min required UTxO value
     forM_ (txOuts txbodycontent1) $
-      \txout -> first TxFeeEstimationBalanceError $ checkMinUTxOValue sbe txout pparams
+      \txout -> first TxFeeEstimationBalanceError $ checkMinUTxOValue sbe pparams txout
+
+    -- check if the balance is positive or negative
+    -- in one case we can produce change, in the other the inputs are insufficient
+    finalTxOuts <-
+      first TxFeeEstimationBalanceError $
+        checkAndIncludeChange sbe pparams balanceTxOut (txOuts txbodycontent1)
 
     -- Step 7.
 
@@ -661,10 +664,7 @@ estimateBalancedTxBody
     let finalTxBodyContent =
           txbodycontent1
             { txFee = TxFeeExplicit sbe fee
-            , txOuts =
-                accountForNoChange
-                  balanceTxOut
-                  (txOuts txbodycontent)
+            , txOuts = finalTxOuts
             , txReturnCollateral = retColl
             , txTotalCollateral = reqCol
             }
@@ -1471,11 +1471,10 @@ makeTransactionBodyAutoBalance
               }
       let balance = evaluateTransactionBalance sbe pp poolids stakeDelegDeposits drepDelegDeposits utxo txbody2
           balanceTxOut = TxOut changeaddr balance TxOutDatumNone ReferenceScriptNone
-      forM_ (txOuts txbodycontent1) $ \txout -> checkMinUTxOValue sbe txout pp
+      forM_ (txOuts txbodycontent1) $ \txout -> checkMinUTxOValue sbe pp txout
 
-      -- check if the balance is positive or negative
-      -- in one case we can produce change, in the other the inputs are insufficient
-      balanceCheck sbe pp balanceTxOut
+      -- check if change meets txout criteria, and include if non-zero
+      finalTxOuts <- checkAndIncludeChange sbe pp balanceTxOut (txOuts txbodycontent1)
 
       -- TODO: we could add the extra fee for the CBOR encoding of the change,
       -- now that we know the magnitude of the change: i.e. 1-8 bytes extra.
@@ -1487,10 +1486,7 @@ makeTransactionBodyAutoBalance
       let finalTxBodyContent =
             txbodycontent1
               { txFee = TxFeeExplicit sbe fee
-              , txOuts =
-                  accountForNoChange
-                    balanceTxOut
-                    (txOuts txbodycontent)
+              , txOuts = finalTxOuts
               , txReturnCollateral = retColl
               , txTotalCollateral = reqCol
               }
@@ -1510,26 +1506,36 @@ makeTransactionBodyAutoBalance
     era :: CardanoEra era
     era = toCardanoEra sbe
 
--- | In the event of spending the exact amount of lovelace in
+-- | In the event of spending the exact amount of lovelace and non-ada assets in
 -- the specified input(s), this function excludes the change
 -- output. Note that this does not save any fees because by default
 -- the fee calculation includes a change address for simplicity and
 -- we make no attempt to recalculate the tx fee without a change address.
-accountForNoChange :: TxOut CtxTx era -> [TxOut CtxTx era] -> [TxOut CtxTx era]
-accountForNoChange change@(TxOut _ balance _ _) rest =
-  case txOutValueToLovelace balance of
-    L.Coin 0 -> rest
-    -- We append change at the end so a client can predict the indexes
-    -- of the outputs
-    _ -> rest ++ [change]
+checkAndIncludeChange
+  :: ShelleyBasedEra era
+  -> Ledger.PParams (ShelleyLedgerEra era)
+  -> TxOut CtxTx era
+  -> [TxOut CtxTx era]
+  -> Either (TxBodyErrorAutoBalance era) [TxOut CtxTx era]
+checkAndIncludeChange sbe pp change@(TxOut _ balance _ _) rest = do
+  let outValue = toMaryValue $ txOutValueToValue balance
+  if L.isZero outValue
+    then pure rest
+    else do
+      -- check if the balance is positive or negative
+      -- in one case we can produce change, in the other the inputs are insufficient
+      balanceCheck sbe pp change
+      -- We append change at the end so a client can predict the indexes of the outputs.
+      -- Note that if this function will append change with 0 ADA, and non-ada assets in it.
+      pure $ rest <> [change]
 
 checkMinUTxOValue
   :: ShelleyBasedEra era
-  -> TxOut CtxTx era
   -> Ledger.PParams (ShelleyLedgerEra era)
+  -> TxOut CtxTx era
   -> Either (TxBodyErrorAutoBalance era) ()
-checkMinUTxOValue sbe txout@(TxOut _ v _ _) bpp = do
-  let minUTxO = calculateMinimumUTxO sbe txout bpp
+checkMinUTxOValue sbe bpp txout@(TxOut _ v _ _) = do
+  let minUTxO = calculateMinimumUTxO sbe bpp txout
   if txOutValueToLovelace v >= minUTxO
     then Right ()
     else Left $ TxBodyErrorMinUTxONotMet (txOutInAnyEra (toCardanoEra sbe) txout) minUTxO
@@ -1543,10 +1549,16 @@ balanceCheck sbe bpparams txout@(TxOut _ balance _ _) = do
   let outValue@(L.MaryValue coin multiAsset) = toMaryValue $ txOutValueToValue balance
       isPositiveValue = L.pointwise (>) outValue mempty
   if
-    | L.isZero outValue -> pure () -- empty TxOut
+    | L.isZero outValue -> pure () -- empty TxOut - ok, it's removed at the end
+    | L.isZero coin -> -- no ADA, just non-ADA assets
+        Left $
+          TxBodyErrorAdaBalanceTooSmall
+            (TxOutInAnyEra (toCardanoEra sbe) txout)
+            (calculateMinimumUTxO sbe bpparams txout)
+            coin
     | not isPositiveValue -> Left $ TxBodyErrorBalanceNegative coin multiAsset
     | otherwise ->
-        case checkMinUTxOValue sbe txout bpparams of
+        case checkMinUTxOValue sbe bpparams txout of
           Left (TxBodyErrorMinUTxONotMet txOutAny minUTxO) ->
             Left $ TxBodyErrorAdaBalanceTooSmall txOutAny minUTxO coin
           Left err -> Left err
@@ -1891,10 +1903,10 @@ traverseScriptWitnesses =
 calculateMinimumUTxO
   :: HasCallStack
   => ShelleyBasedEra era
-  -> TxOut CtxTx era
   -> Ledger.PParams (ShelleyLedgerEra era)
+  -> TxOut CtxTx era
   -> L.Coin
-calculateMinimumUTxO sbe txout pp =
+calculateMinimumUTxO sbe pp txout =
   shelleyBasedEraConstraints sbe $
     let txOutWithMinCoin = L.setMinCoinTxOut pp (toShelleyTxOutAny sbe txout)
      in txOutWithMinCoin ^. L.coinTxOutL

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

@@ -1,13 +1,18 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
 
 module Test.Cardano.Api.Orphans () where
 
 import Cardano.Api.Shelley
 
+import Cardano.Ledger.Mary.Value qualified as L
+
+import Data.String (IsString (..))
+
 import Test.Cardano.Crypto.Orphans ()
 
 -- Signing Key instances
@@ -29,3 +34,5 @@ deriving instance Eq (SigningKey GenesisUTxOKey)
 deriving instance Eq (SigningKey KesKey)
 
 deriving instance Eq (SigningKey VrfKey)
+
+deriving instance IsString L.AssetName