add test catching missing ada from cert deposit return

IntersectMBO · Jan 14, 2025 · 6577cbc · 6577cbc
1 parent 5de3cd1
commit 6577cbc
Show file tree

Hide file tree

Showing 4 changed files with 30 additions and 16 deletions.
diff --git a/cardano-api/internal/Cardano/Api/Fees.hs b/cardano-api/internal/Cardano/Api/Fees.hs
@@ -5,6 +5,7 @@
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
@@ -98,6 +99,7 @@ import           Data.Set (Set)
 import qualified Data.Set as Set
 import           Data.Text (Text)
 import           GHC.Exts (IsList (..))
+import           GHC.Stack
 import           Lens.Micro ((.~), (^.))
 
 -- | Type synonym for logs returned by the ledger's @evalTxExUnitsWithLogs@ function.
@@ -190,7 +192,8 @@ instance Error (TxFeeEstimationError era) where
 -- | Use when you do not have access to the UTxOs you intend to spend
 estimateBalancedTxBody
   :: forall era
-   . MaryEraOnwards era
+   . HasCallStack
+  => MaryEraOnwards era
   -> TxBodyContent BuildTx era
   -> L.PParams (ShelleyLedgerEra era)
   -> Set PoolId
@@ -1004,6 +1007,7 @@ data FeeEstimationMode era
 makeTransactionBodyAutoBalance
   :: forall era
    . ()
+  => HasCallStack
   => ShelleyBasedEra era
   -> SystemStart
   -> LedgerEpochInfo
@@ -1044,18 +1048,25 @@ makeTransactionBodyAutoBalance
       -- 3. update tx with fees
       -- 4. balance the transaction and update tx change output
 
-      let totalValueAtSpendableUTxO = fromLedgerValue sbe . calculateIncomingUTxOValue . Map.elems $ unUTxO utxo
+      let totalValueAtSpendableUTxO =
+            (fromLedgerValue sbe . calculateIncomingUTxOValue . Map.elems $ unUTxO utxo)
+              <> fromList [(AdaAssetId, Quantity 20_000_000)]
           change =
             monoidForEraInEon (toCardanoEra sbe) $ \w ->
               toLedgerValue w $ calculateChangeValue sbe totalValueAtSpendableUTxO txbodycontent
+          changeTxOutValue = TxOutValueShelleyBased sbe change
+
+      -- check change balance, otherwsie the ledger code will throw a GHC exception in the pure code in
+      -- createTransactionBody
+      balanceCheck sbe pp changeaddr changeTxOutValue
 
       txbody0 <-
         first TxBodyError
           $ createTransactionBody
             sbe
           $ txbodycontent
             & modTxOuts
-              (<> [TxOut changeaddr (TxOutValueShelleyBased sbe change) TxOutDatumNone ReferenceScriptNone])
+              (<> [TxOut changeaddr changeTxOutValue TxOutDatumNone ReferenceScriptNone])
       exUnitsMapWithLogs <-
         first TxBodyErrorValidityInterval $
           evaluateTransactionExecutionUnits
@@ -1578,7 +1589,8 @@ traverseScriptWitnesses =
   traverse (\(item, eRes) -> eRes >>= (\res -> Right (item, res)))
 
 calculateMinimumUTxO
-  :: ShelleyBasedEra era
+  :: HasCallStack
+  => ShelleyBasedEra era
   -> TxOut CtxTx era
   -> Ledger.PParams (ShelleyLedgerEra era)
   -> L.Coin

diff --git a/cardano-api/internal/Cardano/Api/Tx/Body.hs b/cardano-api/internal/Cardano/Api/Tx/Body.hs
@@ -1890,6 +1890,7 @@ instance Error TxBodyError where
 
 createTransactionBody
   :: ()
+  => HasCallStack
   => ShelleyBasedEra era
   -> TxBodyContent BuildTx era
   -> Either TxBodyError (TxBody era)
@@ -2633,7 +2634,8 @@ convTotalCollateral txTotalCollateral =
 
 convTxOuts
   :: forall ctx era ledgerera
-   . ShelleyLedgerEra era ~ ledgerera
+   . HasCallStack
+  => ShelleyLedgerEra era ~ ledgerera
   => ShelleyBasedEra era
   -> [TxOut ctx era]
   -> Seq.StrictSeq (Ledger.TxOut ledgerera)
@@ -2816,6 +2818,7 @@ guardShelleyTxInsOverflow txIns = do
 -- all eras
 mkCommonTxBody
   :: ()
+  => HasCallStack
   => ShelleyBasedEra era
   -> TxIns BuildTx era
   -> [TxOut ctx era]

diff --git a/cardano-api/internal/Cardano/Api/Tx/Compatible.hs b/cardano-api/internal/Cardano/Api/Tx/Compatible.hs
@@ -37,6 +37,7 @@ import           Data.Maybe.Strict
 import           Data.Monoid
 import qualified Data.Sequence.Strict as Seq
 import           GHC.Exts (IsList (..))
+import           GHC.Stack
 import           Lens.Micro hiding (ix)
 
 data AnyProtocolUpdate era where
@@ -205,7 +206,8 @@ createCompatibleSignedTx sbe ins outs witnesses txFee' anyProtocolUpdate anyVote
         .~ shelleyBootstrapWitnesses
 
 createCommonTxBody
-  :: ShelleyBasedEra era
+  :: HasCallStack
+  => ShelleyBasedEra era
   -> [TxIn]
   -> [TxOut ctx era]
   -> Lovelace

diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Transaction/Autobalance.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Transaction/Autobalance.hs
@@ -5,7 +5,6 @@
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TupleSections #-}
-{-# LANGUAGE TypeApplications #-}
 
 {- HLINT ignore "Use camelCase" -}
 
@@ -60,8 +59,7 @@ prop_make_transaction_body_autobalance_return_correct_fee_for_multi_asset = H.pr
       beo = convert ceo
       meo = convert beo
       sbe = convert ceo
-      era = toCardanoEra sbe
-  aeo <- H.nothingFail $ forEraMaybeEon @AlonzoEraOnwards era
+      aeo = convert beo
 
   systemStart <-
     fmap SystemStart . H.evalIO $
@@ -144,8 +142,7 @@ prop_make_transaction_body_autobalance_when_deregistering_certs = H.propertyOnce
       beo = convert ceo
       sbe = convert beo
       meo = convert beo
-      era = toCardanoEra sbe
-  aeo <- H.nothingFail $ forEraMaybeEon @AlonzoEraOnwards era
+      aeo = convert beo
 
   systemStart <-
     fmap SystemStart . H.evalIO $
@@ -169,7 +166,7 @@ prop_make_transaction_body_autobalance_when_deregistering_certs = H.propertyOnce
           meo
           [(policyId', [("eeee", 1, BuildTxWith plutusWitness)])]
   stakeCred <- forAll genStakeCredential
-  let deregDeposit = L.Coin 200_000
+  let deregDeposit = L.Coin 20_000_000
   let certs =
         [ ConwayCertificate ceo $
             L.ConwayTxCertDeleg (L.ConwayUnRegCert (toShelleyStakeCredential stakeCred) (L.SJust deregDeposit))
@@ -179,13 +176,13 @@ prop_make_transaction_body_autobalance_when_deregistering_certs = H.propertyOnce
         defaultTxBodyContent sbe
           & setTxIns txInputs
           & setTxInsCollateral txInputsCollateral
-          & setTxOuts (mkTxOutput beo address (L.Coin 2_000_000) Nothing)
+          & setTxOuts (mkTxOutput beo address (L.Coin 20_800_000) Nothing)
           & setTxMintValue txMint
           & setTxProtocolParams (pure $ pure pparams)
           & setTxCertificates (TxCertificates sbe certs (BuildTxWith []))
 
   -- autobalanced body has assets and ADA in the change txout
-  (BalancedTxBody balancedContent _ txOut fee) <-
+  (BalancedTxBody balancedContent _ changeOut fee) <-
     H.leftFail $
       makeTransactionBodyAutoBalance
         sbe
@@ -202,7 +199,7 @@ prop_make_transaction_body_autobalance_when_deregistering_certs = H.propertyOnce
 
   -- 335_475 === fee
   H.noteShow fee
-  H.noteShowPretty txOut
+  H.noteShowPretty changeOut
 
   TxReturnCollateral _ (TxOut _ txOutValue _ _) <-
     H.noteShowPretty $ txReturnCollateral balancedContent
@@ -219,7 +216,7 @@ prop_make_transaction_body_autobalance_multi_asset_collateral = H.propertyOnce $
       sbe = convert beo
       meo = convert beo
       era = toCardanoEra sbe
-  aeo <- H.nothingFail $ forEraMaybeEon @AlonzoEraOnwards era
+      aeo = convert beo
 
   systemStart <-
     fmap SystemStart . H.evalIO $