add test catching missing ada from cert deposit return

cardano-api/internal/Cardano/Api/Fees.hs

@@ -98,6 +98,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 +191,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 +1006,7 @@ data FeeEstimationMode era
 makeTransactionBodyAutoBalance
   :: forall era
    . ()
+  => HasCallStack
   => ShelleyBasedEra era
   -> SystemStart
   -> LedgerEpochInfo
@@ -1044,18 +1047,39 @@ makeTransactionBodyAutoBalance
       -- 3. update tx with fees
       -- 4. balance the transaction and update tx change output
 
-      let totalValueAtSpendableUTxO = fromLedgerValue sbe . calculateIncomingUTxOValue . Map.elems $ unUTxO utxo
+      -- UTXO inputs, which inclue also non-ada assets
+      let totalValueAtUTxO =
+            fromLedgerValue sbe . calculateIncomingUTxOValue . Map.elems $ unUTxO utxo
           change =
             monoidForEraInEon (toCardanoEra sbe) $ \w ->
-              toLedgerValue w $ calculateChangeValue sbe totalValueAtSpendableUTxO txbodycontent
+              toLedgerValue w $ calculateChangeValue sbe totalValueAtUTxO txbodycontent
 
+      -- For the purpose of fees we just need to make a txbody of the right size in bytes. We do
+      -- not need the right values for the fee or change output. We use
+      -- "big enough" values for the change output and set so that the CBOR
+      -- encoding size of the tx will be big enough to cover the size of the final
+      -- output and fee. Yes this means this current code will only work for
+      -- final fee of less than around 4000 ada (2^32-1 lovelace) and change output
+      -- of less than around 18 trillion ada  (2^64-1 lovelace).
+      -- However, since at this point we know how much non-Ada change to give
+      -- we can use the true values for that.
+      let maxLovelaceChange = L.Coin (2 ^ (64 :: Integer)) - 1
+      let maxLovelaceFee = L.Coin (2 ^ (32 :: Integer) - 1)
+      let changeWithMaxLovelace = change & A.adaAssetL sbe .~ maxLovelaceChange
+      let changeTxOut =
+            forShelleyBasedEraInEon
+              sbe
+              (lovelaceToTxOutValue sbe maxLovelaceChange)
+              (\w -> maryEraOnwardsConstraints w $ TxOutValueShelleyBased sbe changeWithMaxLovelace)
+
+      -- tx body used only for evaluating execution units, txout exact values do not matter much here
       txbody0 <-
         first TxBodyError
           $ createTransactionBody
             sbe
           $ txbodycontent
             & modTxOuts
-              (<> [TxOut changeaddr (TxOutValueShelleyBased sbe change) TxOutDatumNone ReferenceScriptNone])
+              (<> [TxOut changeaddr changeTxOut TxOutDatumNone ReferenceScriptNone])
       exUnitsMapWithLogs <-
         first TxBodyErrorValidityInterval $
           evaluateTransactionExecutionUnits
@@ -1078,25 +1102,7 @@ makeTransactionBodyAutoBalance
 
       txbodycontent1 <- substituteExecutionUnits exUnitsMap' txbodycontent
 
-      -- Make a txbody that we will use for calculating the fees. For the purpose
-      -- of fees we just need to make a txbody of the right size in bytes. We do
-      -- not need the right values for the fee or change output. We use
-      -- "big enough" values for the change output and set so that the CBOR
-      -- encoding size of the tx will be big enough to cover the size of the final
-      -- output and fee. Yes this means this current code will only work for
-      -- final fee of less than around 4000 ada (2^32-1 lovelace) and change output
-      -- of less than around 18 trillion ada  (2^64-1 lovelace).
-      -- However, since at this point we know how much non-Ada change to give
-      -- we can use the true values for that.
-      let maxLovelaceChange = L.Coin (2 ^ (64 :: Integer)) - 1
-      let maxLovelaceFee = L.Coin (2 ^ (32 :: Integer) - 1)
-      let changeWithMaxLovelace = change & A.adaAssetL sbe .~ maxLovelaceChange
-      let changeTxOut =
-            forShelleyBasedEraInEon
-              sbe
-              (lovelaceToTxOutValue sbe maxLovelaceChange)
-              (\w -> maryEraOnwardsConstraints w $ TxOutValueShelleyBased sbe changeWithMaxLovelace)
-
+      -- Make a txbody that we will use for calculating the fees.
       let (dummyCollRet, dummyTotColl) = maybeDummyTotalCollAndCollReturnOutput sbe txbodycontent changeaddr
       txbody1 <-
         first TxBodyError $ -- TODO: impossible to fail now
@@ -1578,7 +1584,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

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]

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

cardano-api/test/cardano-api-test/Test/Cardano/Api/Transaction/Autobalance.hs

@@ -60,13 +60,9 @@ 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
-
-  systemStart <-
-    fmap SystemStart . H.evalIO $
-      DT.parseTimeM True DT.defaultTimeLocale "%Y-%m-%dT%H:%M:%S%QZ" "2021-09-01T00:00:00Z"
+      aeo = convert beo
 
+  systemStart <- parseSystemStart "2021-09-01T00:00:00Z"
   let epochInfo = LedgerEpochInfo $ CS.fixedEpochInfo (CS.EpochSize 100) (CS.mkSlotLength 1000)
 
   pparams <-
@@ -76,7 +72,7 @@ prop_make_transaction_body_autobalance_return_correct_fee_for_multi_asset = H.pr
   (sh@(ScriptHash scriptHash), plutusWitness) <- loadPlutusWitness ceo
   let policyId' = PolicyId sh
   -- one UTXO with an asset - the same we're minting in the transaction
-  let utxos = mkUtxos beo scriptHash
+  let utxos = mkUtxos beo (Just scriptHash)
       txInputs = map (,BuildTxWith (KeyWitness KeyWitnessForSpending)) . toList . M.keys . unUTxO $ utxos
       txInputsCollateral = TxInsCollateral aeo $ toList . M.keys . unUTxO $ utxos
   let address = mkAddress sbe scriptHash
@@ -143,49 +139,38 @@ prop_make_transaction_body_autobalance_when_deregistering_certs = H.propertyOnce
   let ceo = ConwayEraOnwardsConway
       beo = convert ceo
       sbe = convert beo
-      meo = convert beo
-      era = toCardanoEra sbe
-  aeo <- H.nothingFail $ forEraMaybeEon @AlonzoEraOnwards era
-
-  systemStart <-
-    fmap SystemStart . H.evalIO $
-      DT.parseTimeM True DT.defaultTimeLocale "%Y-%m-%dT%H:%M:%S%QZ" "2021-09-01T00:00:00Z"
 
+  systemStart <- parseSystemStart "2021-09-01T00:00:00Z"
   let epochInfo = LedgerEpochInfo $ CS.fixedEpochInfo (CS.EpochSize 100) (CS.mkSlotLength 1000)
 
   pparams <-
     LedgerProtocolParameters
       <$> H.readJsonFileOk "test/cardano-api-test/files/input/protocol-parameters/conway.json"
 
-  (sh@(ScriptHash scriptHash), plutusWitness) <- loadPlutusWitness ceo
-  let policyId' = PolicyId sh
-  -- one UTXO with an asset - the same we're minting in the transaction
-  let utxos = mkUtxos beo scriptHash
+  (ScriptHash scriptHash, _) <- loadPlutusWitness ceo
+
+  let utxos = mkUtxos beo Nothing
       txInputs = map (,BuildTxWith (KeyWitness KeyWitnessForSpending)) . toList . M.keys . unUTxO $ utxos
-      txInputsCollateral = TxInsCollateral aeo $ toList . M.keys . unUTxO $ utxos
-  let address = mkAddress sbe scriptHash
-  let txMint =
-        TxMintValue
-          meo
-          [(policyId', [("eeee", 1, BuildTxWith plutusWitness)])]
+      txInputsTotalCoin = mconcat $ getTxOutCoin =<< M.elems (unUTxO utxos)
+      address = mkAddress sbe scriptHash
+      deregDeposit = L.Coin 20_000_000
+      txOutCoin = L.Coin 20_800_000
+
   stakeCred <- forAll genStakeCredential
-  let deregDeposit = L.Coin 200_000
   let certs =
         [ ConwayCertificate ceo $
             L.ConwayTxCertDeleg (L.ConwayUnRegCert (toShelleyStakeCredential stakeCred) (L.SJust deregDeposit))
         ]
 
-  let content =
+      content =
         defaultTxBodyContent sbe
           & setTxIns txInputs
-          & setTxInsCollateral txInputsCollateral
-          & setTxOuts (mkTxOutput beo address (L.Coin 2_000_000) Nothing)
-          & setTxMintValue txMint
+          & setTxOuts (mkTxOutput beo address txOutCoin Nothing)
           & setTxProtocolParams (pure $ pure pparams)
           & setTxCertificates (TxCertificates sbe certs (BuildTxWith []))
 
   -- autobalanced body has assets and ADA in the change txout
-  (BalancedTxBody balancedContent _ txOut fee) <-
+  (BalancedTxBody _ _ changeOut fee) <-
     H.leftFail $
       makeTransactionBodyAutoBalance
         sbe
@@ -200,31 +185,22 @@ prop_make_transaction_body_autobalance_when_deregistering_certs = H.propertyOnce
         address
         Nothing
 
-  -- 335_475 === fee
-  H.noteShow fee
-  H.noteShowPretty txOut
+  changeCoin <- getTxOutCoin changeOut
 
-  TxReturnCollateral _ (TxOut _ txOutValue _ _) <-
-    H.noteShowPretty $ txReturnCollateral balancedContent
-  let assets = [a | a@(AssetId _ _, _) <- toList $ txOutValueToValue txOutValue]
-  H.note_ "Check that all assets from UTXO, from the collateral txin, are in the return collateral."
-  [(AssetId policyId' "eeee", 1)] === assets
+  H.note_ "Sanity check: inputs == outputs"
+  mconcat [deregDeposit, txInputsTotalCoin] === mconcat [txOutCoin, fee, changeCoin]
 
-  H.failure
+  176_633 === fee
 
 prop_make_transaction_body_autobalance_multi_asset_collateral :: Property
 prop_make_transaction_body_autobalance_multi_asset_collateral = H.propertyOnce $ do
   let ceo = ConwayEraOnwardsConway
       beo = convert ceo
       sbe = convert beo
       meo = convert beo
-      era = toCardanoEra sbe
-  aeo <- H.nothingFail $ forEraMaybeEon @AlonzoEraOnwards era
-
-  systemStart <-
-    fmap SystemStart . H.evalIO $
-      DT.parseTimeM True DT.defaultTimeLocale "%Y-%m-%dT%H:%M:%S%QZ" "2021-09-01T00:00:00Z"
+      aeo = convert beo
 
+  systemStart <- parseSystemStart "2021-09-01T00:00:00Z"
   let epochInfo = LedgerEpochInfo $ CS.fixedEpochInfo (CS.EpochSize 100) (CS.mkSlotLength 1000)
 
   pparams <-
@@ -234,7 +210,7 @@ prop_make_transaction_body_autobalance_multi_asset_collateral = H.propertyOnce $
   (sh@(ScriptHash scriptHash), plutusWitness) <- loadPlutusWitness ceo
   let policyId' = PolicyId sh
   -- one UTXO with an asset - the same we're minting in the transaction
-  let utxos = mkUtxos beo scriptHash
+  let utxos = mkUtxos beo (Just scriptHash)
       txInputs = map (,BuildTxWith (KeyWitness KeyWitnessForSpending)) . toList . M.keys . unUTxO $ utxos
       txInputsCollateral = TxInsCollateral aeo $ toList . M.keys . unUTxO $ utxos
   let address = mkAddress sbe scriptHash
@@ -381,8 +357,12 @@ textEnvTypes =
       (ScriptInAnyLang (PlutusScriptLanguage PlutusScriptV3))
   ]
 
-mkUtxos :: BabbageEraOnwards era -> L.ScriptHash L.StandardCrypto -> UTxO era
-mkUtxos beo scriptHash = babbageEraOnwardsConstraints beo $ do
+mkUtxos
+  :: BabbageEraOnwards era
+  -> Maybe (L.ScriptHash L.StandardCrypto)
+  -- ^ add an asset to the utxo if the script hash is provided
+  -> UTxO era
+mkUtxos beo mScriptHash = babbageEraOnwardsConstraints beo $ do
   let sbe = convert beo
   UTxO
     [
@@ -404,7 +384,10 @@ mkUtxos beo scriptHash = babbageEraOnwardsConstraints beo $ do
               sbe
               ( L.MaryValue
                   (L.Coin 4_000_000)
-                  (L.MultiAsset [(L.PolicyID scriptHash, [(L.AssetName "eeee", 1)])])
+                  ( L.MultiAsset $
+                      fromList
+                        [(L.PolicyID scriptHash, [(L.AssetName "eeee", 2)]) | scriptHash <- maybeToList mScriptHash]
+                  )
               )
           )
           TxOutDatumNone
@@ -450,6 +433,21 @@ mkTxOutput beo address coin mScriptHash = babbageEraOnwardsConstraints beo $ do
       ReferenceScriptNone
     ]
 
+parseSystemStart :: (HasCallStack, MonadTest m, MonadIO m) => String -> m SystemStart
+parseSystemStart timeString =
+  withFrozenCallStack $
+    fmap SystemStart . H.evalIO $
+      DT.parseTimeM True DT.defaultTimeLocale "%Y-%m-%dT%H:%M:%S%QZ" timeString
+
+getTxOutCoin
+  :: forall era ctx m
+   . (HasCallStack, MonadFail m, IsMaryBasedEra era)
+  => TxOut ctx era
+  -> m L.Coin
+getTxOutCoin txout = withFrozenCallStack $ maryEraOnwardsConstraints (maryBasedEra @era) $ do
+  TxOut _ (TxOutValueShelleyBased _ (L.MaryValue changeCoin _)) _ _ <- pure txout
+  pure changeCoin
+
 tests :: TestTree
 tests =
   testGroup