From 45c03e190618c029f5bb3bdba8ca1b818069cbaf Mon Sep 17 00:00:00 2001 From: Mateusz Galazyn Date: Wed, 8 Jan 2025 15:32:22 +0100 Subject: [PATCH] add test catching missing ada from cert deposit return --- cardano-api/internal/Cardano/Api/Fees.hs | 55 ++++++----- cardano-api/internal/Cardano/Api/Tx/Body.hs | 5 +- .../internal/Cardano/Api/Tx/Compatible.hs | 4 +- .../Cardano/Api/Transaction/Autobalance.hs | 96 +++++++++---------- 4 files changed, 85 insertions(+), 75 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/Fees.hs b/cardano-api/internal/Cardano/Api/Fees.hs index 6c52171f8c..748464d637 100644 --- a/cardano-api/internal/Cardano/Api/Fees.hs +++ b/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 diff --git a/cardano-api/internal/Cardano/Api/Tx/Body.hs b/cardano-api/internal/Cardano/Api/Tx/Body.hs index 93dd37f9b9..2140cabc75 100644 --- 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 index 84c58d597f..6956b3228b 100644 --- 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 index d442fa2743..55d65843de 100644 --- 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 @@ -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,17 +185,12 @@ 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 @@ -218,13 +198,9 @@ prop_make_transaction_body_autobalance_multi_asset_collateral = H.propertyOnce $ 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