Better reporting of negative balance in transaction balancing

Author: carbolymer

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

@@ -4,6 +4,7 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiWayIf #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -357,6 +358,7 @@ import Cardano.Api.Internal.Plutus
 import Cardano.Api.Internal.Pretty
 import Cardano.Api.Internal.ProtocolParameters
 import Cardano.Api.Internal.Query
+import Cardano.Api.Internal.ReexposeLedger qualified as L
 import Cardano.Api.Internal.Script
 import Cardano.Api.Internal.Tx.Body
 import Cardano.Api.Internal.Tx.Sign
@@ -370,8 +372,8 @@ import Cardano.Ledger.Alonzo.Scripts qualified as Alonzo
 import Cardano.Ledger.Api qualified as L
 import Cardano.Ledger.Coin qualified as L
 import Cardano.Ledger.Conway.Governance qualified as L
-import Cardano.Ledger.Core qualified as L
 import Cardano.Ledger.Credential as Ledger (Credential)
+import Cardano.Ledger.Mary.Value qualified as L
 import Cardano.Ledger.Plutus.Language qualified as Plutus
 import Cardano.Ledger.Val qualified as L
 import Ouroboros.Consensus.HardFork.History qualified as Consensus
@@ -395,6 +397,7 @@ import Data.Text (Text)
 import GHC.Exts (IsList (..))
 import GHC.Stack
 import Lens.Micro ((.~), (^.))
+import Prettyprinter (punctuate)
 
 -- | Type synonym for logs returned by the ledger's @evalTxExUnitsWithLogs@ function.
 -- for scripts in transactions.
@@ -639,9 +642,10 @@ estimateBalancedTxBody
     let fakeUTxO = createFakeUTxO sbe txbodycontent1 $ selectLovelace availableUTxOValue
         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 changeaddr balance
+    first TxFeeEstimationBalanceError $ balanceCheck sbe pparams balanceTxOut
 
     -- Step 6. Check all txouts have the min required UTxO value
     forM_ (txOuts txbodycontent1) $
@@ -659,7 +663,7 @@ estimateBalancedTxBody
             { txFee = TxFeeExplicit sbe fee
             , txOuts =
                 accountForNoChange
-                  (TxOut changeaddr balance TxOutDatumNone ReferenceScriptNone)
+                  balanceTxOut
                   (txOuts txbodycontent)
             , txReturnCollateral = retColl
             , txTotalCollateral = reqCol
@@ -673,7 +677,7 @@ estimateBalancedTxBody
       ( BalancedTxBody
           finalTxBodyContent
           txbody3
-          (TxOut changeaddr balance TxOutDatumNone ReferenceScriptNone)
+          balanceTxOut
           fee
       )
 
@@ -990,9 +994,7 @@ evaluateTransactionExecutionUnits
   -> LedgerProtocolParameters era
   -> UTxO era
   -> TxBody era
-  -> Either
-       (TransactionValidityError era)
-       (Map ScriptWitnessIndex (Either ScriptExecutionError (EvalTxExecutionUnitsLog, ExecutionUnits)))
+  -> Map ScriptWitnessIndex (Either ScriptExecutionError (EvalTxExecutionUnitsLog, ExecutionUnits))
 evaluateTransactionExecutionUnits era systemstart epochInfo pp utxo txbody =
   case makeSignedTransaction' era [] txbody of
     ShelleyTx sbe tx' -> evaluateTransactionExecutionUnitsShelley sbe systemstart epochInfo pp utxo tx'
@@ -1006,14 +1008,12 @@ evaluateTransactionExecutionUnitsShelley
   -> LedgerProtocolParameters era
   -> UTxO era
   -> L.Tx (ShelleyLedgerEra era)
-  -> Either
-       (TransactionValidityError era)
-       (Map ScriptWitnessIndex (Either ScriptExecutionError (EvalTxExecutionUnitsLog, ExecutionUnits)))
+  -> Map ScriptWitnessIndex (Either ScriptExecutionError (EvalTxExecutionUnitsLog, ExecutionUnits))
 evaluateTransactionExecutionUnitsShelley sbe systemstart epochInfo (LedgerProtocolParameters pp) utxo tx =
   caseShelleyToMaryOrAlonzoEraOnwards
-    (const (Right Map.empty))
+    (const Map.empty)
     ( \w ->
-        pure . fromLedgerScriptExUnitsMap w $
+        fromLedgerScriptExUnitsMap w $
           alonzoEraOnwardsConstraints w $
             L.evalTxExUnitsWithLogs pp tx (toLedgerUTxO sbe utxo) ledgerEpochInfo systemstart
     )
@@ -1147,22 +1147,21 @@ data TxBodyErrorAutoBalance era
     TxBodyScriptExecutionError [(ScriptWitnessIndex, ScriptExecutionError)]
   | -- | One or more scripts were expected to fail validation, but none did.
     TxBodyScriptBadScriptValidity
-  | -- | There is not enough ada to cover both the outputs and the fees.
-    -- The transaction should be changed to provide more input ada, or
+  | -- | There is not enough ada and non-ada to cover both the outputs and the fees.
+    -- The transaction should be changed to provide more input assets, or
     -- otherwise adjusted to need less (e.g. outputs, script etc).
-    TxBodyErrorAdaBalanceNegative L.Coin
+    TxBodyErrorBalanceNegative L.Coin L.MultiAsset
   | -- | There is enough ada to cover both the outputs and the fees, but the
     -- resulting change is too small: it is under the minimum value for
     -- new UTXO entries. The transaction should be changed to provide more
     -- input ada.
     TxBodyErrorAdaBalanceTooSmall
-      -- \^ Offending TxOut
-
       TxOutInAnyEra
+      -- ^ Offending TxOut
+      L.Coin
       -- ^ Minimum UTxO
       L.Coin
       -- ^ Tx balance
-      L.Coin
   | -- | 'makeTransactionBodyAutoBalance' does not yet support the Byron era.
     TxBodyErrorByronEraNotSupported
   | -- | The 'ProtocolParameters' must provide the value for the min utxo
@@ -1173,11 +1172,10 @@ data TxBodyErrorAutoBalance era
     TxBodyErrorValidityInterval (TransactionValidityError era)
   | -- | The minimum spendable UTxO threshold has not been met.
     TxBodyErrorMinUTxONotMet
-      -- \^ Offending TxOut
-
       TxOutInAnyEra
-      -- ^ Minimum UTXO
+      -- ^ Offending TxOut
       L.Coin
+      -- ^ Minimum UTXO
   | TxBodyErrorNonAdaAssetsUnbalanced Value
   | TxBodyErrorScriptWitnessIndexMissingFromExecUnitsMap
       ScriptWitnessIndex
@@ -1201,12 +1199,14 @@ instance Error (TxBodyErrorAutoBalance era) where
         ]
     TxBodyScriptBadScriptValidity ->
       "One or more of the scripts were expected to fail validation, but none did."
-    TxBodyErrorAdaBalanceNegative lovelace ->
-      mconcat
-        [ "The transaction does not balance in its use of ada. The net balance "
-        , "of the transaction is negative: " <> pretty lovelace <> ". "
-        , "The usual solution is to provide more inputs, or inputs with more ada."
+    TxBodyErrorBalanceNegative lovelace assets ->
+      mconcat $
+        [ "The transaction does not balance in its use of assets. The net balance "
+        , "of the transaction is negative: "
         ]
+          <> punctuate ", " [pretty lovelace, pretty assets]
+          <> [ ". The usual solution is to provide more inputs, or inputs with more assets."
+             ]
     TxBodyErrorAdaBalanceTooSmall changeOutput minUTxO balance ->
       mconcat
         [ "The transaction does balance in its use of ada, however the net "
@@ -1365,8 +1365,16 @@ makeTransactionBodyAutoBalance
       -- 4. balance the transaction and update tx change output
 
       txbodyForChange <- first TxBodyError $ createTransactionBody sbe txbodycontent
-      let initialChangeTxOut =
+      let initialChangeTxOutValue =
             evaluateTransactionBalance sbe pp poolids stakeDelegDeposits drepDelegDeposits utxo txbodyForChange
+          initialChangeTxOut =
+            TxOut
+              changeaddr
+              initialChangeTxOutValue
+              TxOutDatumNone
+              ReferenceScriptNone
+
+      balanceCheck sbe pp initialChangeTxOut
 
       -- Tx body used only for evaluating execution units. Because txout exact
       -- values do not matter much here, we are using an initial change value,
@@ -1378,16 +1386,16 @@ makeTransactionBodyAutoBalance
             sbe
           $ txbodycontent
             & modTxOuts
-              (<> [TxOut changeaddr initialChangeTxOut TxOutDatumNone ReferenceScriptNone])
-      exUnitsMapWithLogs <-
-        first TxBodyErrorValidityInterval $
-          evaluateTransactionExecutionUnits
-            era
-            systemstart
-            history
-            lpp
-            utxo
-            txbody
+              (<> [initialChangeTxOut])
+      -- first TxBodyErrorValidityInterval $ -- TODO remove this?
+      let exUnitsMapWithLogs =
+            evaluateTransactionExecutionUnits
+              era
+              systemstart
+              history
+              lpp
+              utxo
+              txbody
 
       let exUnitsMap = Map.map (fmap snd) exUnitsMapWithLogs
 
@@ -1419,7 +1427,7 @@ makeTransactionBodyAutoBalance
               { txFee = TxFeeExplicit sbe maxLovelaceFee
               , txOuts =
                   txOuts txbodycontent
-                    <> [TxOut changeaddr initialChangeTxOut TxOutDatumNone ReferenceScriptNone]
+                    <> [initialChangeTxOut]
               , txReturnCollateral = dummyCollRet
               , txTotalCollateral = dummyTotColl
               }
@@ -1468,11 +1476,12 @@ makeTransactionBodyAutoBalance
               , txTotalCollateral = reqCol
               }
       let balance = evaluateTransactionBalance sbe pp poolids stakeDelegDeposits drepDelegDeposits utxo txbody2
+          balanceTxOut = TxOut changeaddr balance TxOutDatumNone ReferenceScriptNone
       forM_ (txOuts txbodycontent1) $ \txout -> checkMinUTxOValue sbe txout pp
 
       -- 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 changeaddr balance
+      balanceCheck sbe pp balanceTxOut
 
       -- 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.
@@ -1486,7 +1495,7 @@ makeTransactionBodyAutoBalance
               { txFee = TxFeeExplicit sbe fee
               , txOuts =
                   accountForNoChange
-                    (TxOut changeaddr balance TxOutDatumNone ReferenceScriptNone)
+                    balanceTxOut
                     (txOuts txbodycontent)
               , txReturnCollateral = retColl
               , txTotalCollateral = reqCol
@@ -1500,7 +1509,7 @@ makeTransactionBodyAutoBalance
         ( BalancedTxBody
             finalTxBodyContent
             txbody3
-            (TxOut changeaddr balance TxOutDatumNone ReferenceScriptNone)
+            balanceTxOut
             fee
         )
    where
@@ -1534,26 +1543,20 @@ checkMinUTxOValue sbe txout@(TxOut _ v _ _) bpp = do
 balanceCheck
   :: ShelleyBasedEra era
   -> Ledger.PParams (ShelleyLedgerEra era)
-  -> AddressInEra era
-  -> TxOutValue era
+  -> TxOut CtxTx era
   -> Either (TxBodyErrorAutoBalance era) ()
-balanceCheck sbe bpparams changeaddr balance
-  | txOutValueToLovelace balance == 0 && onlyAda (txOutValueToValue balance) = return ()
-  | txOutValueToLovelace balance < 0 =
-      Left . TxBodyErrorAdaBalanceNegative $ txOutValueToLovelace balance
-  | otherwise =
-      case checkMinUTxOValue sbe (TxOut changeaddr balance TxOutDatumNone ReferenceScriptNone) bpparams of
-        Left (TxBodyErrorMinUTxONotMet txOutAny minUTxO) ->
-          Left $ TxBodyErrorAdaBalanceTooSmall txOutAny minUTxO (txOutValueToLovelace balance)
-        Left err -> Left err
-        Right _ -> Right ()
-
-isNotAda :: AssetId -> Bool
-isNotAda AdaAssetId = False
-isNotAda _ = True
-
-onlyAda :: Value -> Bool
-onlyAda = null . toList . filterValue isNotAda
+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 && L.isAdaOnly outValue -> pure () -- no change
+    | not isPositiveValue -> Left $ TxBodyErrorBalanceNegative coin multiAsset
+    | otherwise ->
+        case checkMinUTxOValue sbe txout bpparams of
+          Left (TxBodyErrorMinUTxONotMet txOutAny minUTxO) ->
+            Left $ TxBodyErrorAdaBalanceTooSmall txOutAny minUTxO coin
+          Left err -> Left err
+          Right _ -> Right ()
 
 -- Calculation taken from validateInsufficientCollateral:
 -- https://github.com/input-output-hk/cardano-ledger/blob/389b266d6226dedf3d2aec7af640b3ca4984c5ea/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxo.hs#L335

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

@@ -29,6 +29,7 @@ import Cardano.Chain.Update.Validation.Endorsement qualified as L.Endorsement
 import Cardano.Chain.Update.Validation.Interface qualified as L.Interface
 import Cardano.Chain.Update.Validation.Registration qualified as L.Registration
 import Cardano.Chain.Update.Validation.Voting qualified as L.Voting
+import Cardano.Crypto.Hash qualified as Crypto
 import Cardano.Ledger.Allegra.Rules qualified as L
 import Cardano.Ledger.Alonzo.PParams qualified as Ledger
 import Cardano.Ledger.Alonzo.Rules qualified as L
@@ -49,6 +50,7 @@ import Cardano.Ledger.Core qualified as L hiding (KeyHash)
 import Cardano.Ledger.HKD (NoUpdate (..))
 import Cardano.Ledger.Hashes qualified as L hiding (KeyHash)
 import Cardano.Ledger.Keys qualified as L.Keys
+import Cardano.Ledger.Mary.Value qualified as L
 import Cardano.Ledger.Shelley.API.Mempool qualified as L
 import Cardano.Ledger.Shelley.PParams qualified as Ledger
 import Cardano.Ledger.Shelley.Rules qualified as L
@@ -89,12 +91,13 @@ import Data.Monoid
 import Data.Text qualified as T
 import Data.Text.Encoding qualified as Text
 import Data.Typeable (Typeable)
-import GHC.Exts (IsList (..))
+import GHC.Exts (IsList (..), IsString (..))
 import GHC.Generics
 import GHC.Stack (HasCallStack)
 import GHC.TypeLits
 import Lens.Micro
 import Network.Mux qualified as Mux
+import Prettyprinter (punctuate, viaShow)
 
 deriving instance Generic (L.ApplyTxError era)
 
@@ -257,6 +260,22 @@ deriving newtype instance Num L.Coin
 instance Pretty L.Coin where
   pretty (L.Coin n) = pretty n <+> "Lovelace"
 
+instance Pretty L.MultiAsset where
+  pretty (L.MultiAsset assetsMap) =
+    mconcat $
+      punctuate
+        ", "
+        [ pretty quantity <+> pretty pId <> "." <> pretty name
+        | (pId, assets) <- toList assetsMap
+        , (name, quantity) <- toList assets
+        ]
+
+instance Pretty L.PolicyID where
+  pretty (L.PolicyID (L.ScriptHash sh)) = pretty $ Crypto.hashToStringAsHex sh
+
+instance Pretty L.AssetName where
+  pretty = pretty . L.assetNameToTextAsHex
+
 -- Orphan instances involved in the JSON output of the API queries.
 -- We will remove/replace these as we provide more API wrapper types