diff --git a/cardano-api/cardano-api.cabal b/cardano-api/cardano-api.cabal index 4a7751e64..d5dbdb8d1 100644 --- a/cardano-api/cardano-api.cabal +++ b/cardano-api/cardano-api.cabal @@ -318,16 +318,17 @@ test-suite cardano-api-test cardano-ledger-binary, cardano-ledger-core:{cardano-ledger-core, testlib} >=1.14, cardano-ledger-mary, - cardano-ledger-shelley, cardano-protocol-tpraos, cardano-slotting, cborg, containers, + data-default, directory, hedgehog >=1.1, hedgehog-extras, hedgehog-quickcheck, interpolatedstring-perl6, + microlens, mtl, ouroboros-consensus, ouroboros-consensus-cardano, diff --git a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs index 2f432702f..531f0818f 100644 --- a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs +++ b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs @@ -409,8 +409,8 @@ genValueForTxOut sbe = do caseShelleyToAllegraOrMaryEraOnwards (const (pure ada)) ( \w -> do - v <- genValue w genAssetId genPositiveQuantity - pure $ ada <> v + v <- Gen.list (Range.constant 0 5) $ genValue w genAssetId genPositiveQuantity + pure $ ada <> mconcat v ) sbe diff --git a/cardano-api/internal/Cardano/Api/Eon/ConwayEraOnwards.hs b/cardano-api/internal/Cardano/Api/Eon/ConwayEraOnwards.hs index 06fa98fc0..d991fdfbd 100644 --- a/cardano-api/internal/Cardano/Api/Eon/ConwayEraOnwards.hs +++ b/cardano-api/internal/Cardano/Api/Eon/ConwayEraOnwards.hs @@ -12,11 +12,13 @@ module Cardano.Api.Eon.ConwayEraOnwards ( ConwayEraOnwards (..) , conwayEraOnwardsConstraints , conwayEraOnwardsToShelleyBasedEra + , conwayEraOnwardsToBabbageEraOnwards , ConwayEraOnwardsConstraints , IsConwayBasedEra (..) ) where +import Cardano.Api.Eon.BabbageEraOnwards import Cardano.Api.Eon.ShelleyBasedEra import Cardano.Api.Eras.Core import Cardano.Api.Modes @@ -114,6 +116,10 @@ conwayEraOnwardsToShelleyBasedEra :: ConwayEraOnwards era -> ShelleyBasedEra era conwayEraOnwardsToShelleyBasedEra = \case ConwayEraOnwardsConway -> ShelleyBasedEraConway +conwayEraOnwardsToBabbageEraOnwards :: ConwayEraOnwards era -> BabbageEraOnwards era +conwayEraOnwardsToBabbageEraOnwards = \case + ConwayEraOnwardsConway -> BabbageEraOnwardsConway + class IsConwayBasedEra era where conwayBasedEra :: ConwayEraOnwards era diff --git a/cardano-api/internal/Cardano/Api/Fees.hs b/cardano-api/internal/Cardano/Api/Fees.hs index 7f736b6f5..eb0b91771 100644 --- a/cardano-api/internal/Cardano/Api/Fees.hs +++ b/cardano-api/internal/Cardano/Api/Fees.hs @@ -30,6 +30,7 @@ module Cardano.Api.Fees , estimateBalancedTxBody , estimateOrCalculateBalancedTxBody , makeTransactionBodyAutoBalance + , calcReturnAndTotalCollateral , AutoBalanceError (..) , BalancedTxBody (..) , FeeEstimationMode (..) @@ -81,6 +82,7 @@ import Cardano.Ledger.Credential as Ledger (Credential) import qualified Cardano.Ledger.Crypto as Ledger import qualified Cardano.Ledger.Keys as Ledger import qualified Cardano.Ledger.Plutus.Language as Plutus +import qualified Cardano.Ledger.Val as L import qualified Ouroboros.Consensus.HardFork.History as Consensus import qualified PlutusLedgerApi.V1 as Plutus @@ -325,7 +327,7 @@ estimateBalancedTxBody (txReturnCollateral txbodycontent) (txTotalCollateral txbodycontent) changeaddr - totalPotentialCollateral + (A.mkAdaValue sbe totalPotentialCollateral) ) sbe @@ -1070,10 +1072,8 @@ makeTransactionBodyAutoBalance availableEra $ obtainCommonConstraints availableEra $ txbodycontent - { txOuts = - txOuts txbodycontent - <> [TxOut changeaddr (TxOutValueShelleyBased sbe change) TxOutDatumNone ReferenceScriptNone] - } + & modTxOuts + (<> [TxOut changeaddr (TxOutValueShelleyBased sbe change) TxOutDatumNone ReferenceScriptNone]) exUnitsMapWithLogs <- first TxBodyErrorValidityInterval $ evaluateTransactionExecutionUnitsShelley @@ -1143,21 +1143,23 @@ makeTransactionBodyAutoBalance (retColl, reqCol) = caseShelleyToAlonzoOrBabbageEraOnwards (const (TxReturnCollateralNone, TxTotalCollateralNone)) - ( \w -> - let collIns = case txInsCollateral txbodycontent of - TxInsCollateral _ collIns' -> collIns' - TxInsCollateralNone -> mempty - collateralOuts = catMaybes [Map.lookup txin (unUTxO utxo) | txin <- collIns] - totalPotentialCollateral = mconcat $ map (\(TxOut _ txOutVal _ _) -> txOutValueToLovelace txOutVal) collateralOuts - in calcReturnAndTotalCollateral - w - fee - pp - (txInsCollateral txbodycontent) - (txReturnCollateral txbodycontent) - (txTotalCollateral txbodycontent) - changeaddr - totalPotentialCollateral + ( \w -> do + let totalPotentialCollateral = + mconcat + [ txOutValue + | TxInsCollateral _ collInputs <- pure $ txInsCollateral txbodycontent + , collTxIn <- collInputs + , Just (TxOut _ (TxOutValueShelleyBased _ txOutValue) _ _) <- pure $ Map.lookup collTxIn (unUTxO utxo) + ] + calcReturnAndTotalCollateral + w + fee + pp + (txInsCollateral txbodycontent) + (txReturnCollateral txbodycontent) + (txTotalCollateral txbodycontent) + changeaddr + totalPotentialCollateral ) sbe @@ -1295,49 +1297,52 @@ calcReturnAndTotalCollateral -- ^ From the initial TxBodyContent -> AddressInEra era -- ^ Change address - -> Coin - -- ^ Total available collateral in lovelace + -> L.Value (ShelleyLedgerEra era) + -- ^ Total available collateral (can include non-ada) -> (TxReturnCollateral CtxTx era, TxTotalCollateral era) calcReturnAndTotalCollateral _ _ _ TxInsCollateralNone _ _ _ _ = (TxReturnCollateralNone, TxTotalCollateralNone) -calcReturnAndTotalCollateral retColSup fee pp' TxInsCollateral{} txReturnCollateral txTotalCollateral cAddr totalAvailableAda = - do - let colPerc = pp' ^. Ledger.ppCollateralPercentageL - -- We must first figure out how much lovelace we have committed - -- as collateral and we must determine if we have enough lovelace at our - -- collateral tx inputs to cover the tx - totalCollateralLovelace = totalAvailableAda - requiredCollateral@(L.Coin reqAmt) = fromIntegral colPerc * fee - totalCollateral = - TxTotalCollateral retColSup . L.rationalToCoinViaCeiling $ - reqAmt % 100 - -- Why * 100? requiredCollateral is the product of the collateral percentage and the tx fee - -- We choose to multiply 100 rather than divide by 100 to make the calculation - -- easier to manage. At the end of the calculation we then use % 100 to perform our division - -- and round the returnCollateral down which has the effect of potentially slightly - -- overestimating the required collateral. - L.Coin amt = totalCollateralLovelace * 100 - requiredCollateral - returnCollateral = L.rationalToCoinViaFloor $ amt % 100 - case (txReturnCollateral, txTotalCollateral) of - (rc@TxReturnCollateral{}, tc@TxTotalCollateral{}) -> - (rc, tc) - (rc@TxReturnCollateral{}, TxTotalCollateralNone) -> - (rc, TxTotalCollateralNone) - (TxReturnCollateralNone, tc@TxTotalCollateral{}) -> - (TxReturnCollateralNone, tc) - (TxReturnCollateralNone, TxTotalCollateralNone) -> - if totalCollateralLovelace * 100 >= requiredCollateral - then - ( TxReturnCollateral - retColSup - ( TxOut - cAddr - (lovelaceToTxOutValue (babbageEraOnwardsToShelleyBasedEra retColSup) returnCollateral) - TxOutDatumNone - ReferenceScriptNone - ) - , totalCollateral - ) - else (TxReturnCollateralNone, TxTotalCollateralNone) +calcReturnAndTotalCollateral w fee pp' TxInsCollateral{} txReturnCollateral txTotalCollateral cAddr totalAvailableCollateral = babbageEraOnwardsConstraints w $ do + let sbe = babbageEraOnwardsToShelleyBasedEra w + colPerc = pp' ^. Ledger.ppCollateralPercentageL + -- We must first figure out how much lovelace we have committed + -- as collateral and we must determine if we have enough lovelace at our + -- collateral tx inputs to cover the tx + totalCollateralLovelace = totalAvailableCollateral ^. A.adaAssetL sbe + requiredCollateral@(L.Coin reqAmt) = fromIntegral colPerc * fee + totalCollateral = + TxTotalCollateral w . L.rationalToCoinViaCeiling $ + reqAmt % 100 + -- Why * 100? requiredCollateral is the product of the collateral percentage and the tx fee + -- We choose to multiply 100 rather than divide by 100 to make the calculation + -- easier to manage. At the end of the calculation we then use % 100 to perform our division + -- and round the returnCollateral down which has the effect of potentially slightly + -- overestimating the required collateral. + L.Coin returnCollateralAmount = totalCollateralLovelace * 100 - requiredCollateral + returnAdaCollateral = A.mkAdaValue sbe $ L.rationalToCoinViaFloor $ returnCollateralAmount % 100 + -- non-ada collateral is not used, so just return it as is in the return collateral output + nonAdaCollateral = L.modifyCoin (const mempty) totalAvailableCollateral + returnCollateral = returnAdaCollateral <> nonAdaCollateral + case (txReturnCollateral, txTotalCollateral) of + (rc@TxReturnCollateral{}, tc@TxTotalCollateral{}) -> + (rc, tc) + (rc@TxReturnCollateral{}, TxTotalCollateralNone) -> + (rc, TxTotalCollateralNone) + (TxReturnCollateralNone, tc@TxTotalCollateral{}) -> + (TxReturnCollateralNone, tc) + (TxReturnCollateralNone, TxTotalCollateralNone) + | returnCollateralAmount < 0 -> + (TxReturnCollateralNone, TxTotalCollateralNone) + | otherwise -> + ( TxReturnCollateral + w + ( TxOut + cAddr + (TxOutValueShelleyBased sbe returnCollateral) + TxOutDatumNone + ReferenceScriptNone + ) + , totalCollateral + ) calculateCreatedUTOValue :: ShelleyBasedEra era -> TxBodyContent build era -> Value diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs index c168cc0cc..40c7f270f 100644 --- a/cardano-api/src/Cardano/Api.hs +++ b/cardano-api/src/Cardano/Api.hs @@ -104,6 +104,7 @@ module Cardano.Api , ConwayEraOnwards (..) , conwayEraOnwardsConstraints , conwayEraOnwardsToShelleyBasedEra + , conwayEraOnwardsToBabbageEraOnwards , IsConwayBasedEra (..) -- * Era case handling 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 4051453a3..23ef930e9 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 @@ -1,4 +1,5 @@ {-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE RankNTypes #-} @@ -6,7 +7,6 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} -{- HLINT ignore "Use list comprehension" -} {- HLINT ignore "Use camelCase" -} module Test.Cardano.Api.Transaction.Autobalance @@ -15,35 +15,50 @@ module Test.Cardano.Api.Transaction.Autobalance where import Cardano.Api +import Cardano.Api.Fees import qualified Cardano.Api.Ledger as L +import qualified Cardano.Api.Ledger.Lens as L import Cardano.Api.Script import Cardano.Api.Shelley (Address (..), LedgerProtocolParameters (..)) +import qualified Cardano.Ledger.Alonzo.Core as L +import qualified Cardano.Ledger.Coin as L import qualified Cardano.Ledger.Mary.Value as L -import qualified Cardano.Ledger.Shelley.Scripts as L +import Cardano.Ledger.Val ((<->)) +import qualified Cardano.Ledger.Val as L import qualified Cardano.Slotting.EpochInfo as CS import qualified Cardano.Slotting.Slot as CS import qualified Cardano.Slotting.Time as CS import qualified Data.ByteString as B +import Data.Default (def) import Data.Function import qualified Data.Map.Strict as M +import Data.Maybe +import Data.Ratio ((%)) import qualified Data.Time.Format as DT -import GHC.Exts (IsList (..), IsString (..)) +import GHC.Exts (IsList (..)) import GHC.Stack +import Lens.Micro ((^.)) + +import Test.Gen.Cardano.Api.Typed import Test.Cardano.Api.Orphans () -import Hedgehog (MonadTest, Property, (===)) +import Hedgehog (MonadTest, Property, forAll, (===)) import qualified Hedgehog as H import qualified Hedgehog.Extras as H +import qualified Hedgehog.Gen as Gen import Test.Tasty (TestTree, testGroup) import Test.Tasty.Hedgehog (testProperty) -- | Test that the fee is the same when spending minted asset manually or when autobalancing it prop_make_transaction_body_autobalance_return_correct_fee_for_multi_asset :: Property prop_make_transaction_body_autobalance_return_correct_fee_for_multi_asset = H.propertyOnce $ do - let sbe = ShelleyBasedEraConway + let ceo = ConwayEraOnwardsConway + beo = conwayEraOnwardsToBabbageEraOnwards ceo + meo = babbageEraOnwardsToMaryEraOnwards beo + sbe = conwayEraOnwardsToShelleyBasedEra ceo era = toCardanoEra sbe aeo <- H.nothingFail $ forEraMaybeEon @AlonzoEraOnwards era @@ -54,76 +69,20 @@ prop_make_transaction_body_autobalance_return_correct_fee_for_multi_asset = H.pr let epochInfo = LedgerEpochInfo $ CS.fixedEpochInfo (CS.EpochSize 100) (CS.mkSlotLength 1000) pparams <- - LedgerProtocolParameters @ConwayEra + LedgerProtocolParameters <$> H.readJsonFileOk "test/cardano-api-test/files/input/protocol-parameters/conway.json" - plutusWitness <- loadPlutusWitness - - let scriptHashStr = "e2b715a86bee4f14fef84081217f9e2646893a7d60a38af69e0aa572" - let policyId' = fromString scriptHashStr - let scriptHash = L.ScriptHash $ fromString scriptHashStr + (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 = - UTxO - [ - ( TxIn - "01f4b788593d4f70de2a45c2e1e87088bfbdfa29577ae1b62aba60e095e3ab53" - (TxIx 0) - , TxOut - ( AddressInEra - (ShelleyAddressInEra ShelleyBasedEraConway) - ( ShelleyAddress - L.Testnet - ( L.KeyHashObj $ - L.KeyHash "ebe9de78a37f84cc819c0669791aa0474d4f0a764e54b9f90cfe2137" - ) - L.StakeRefNull - ) - ) - ( TxOutValueShelleyBased - ShelleyBasedEraConway - ( L.MaryValue - (L.Coin 4_000_000) - (L.MultiAsset [(L.PolicyID scriptHash, [(L.AssetName "eeee", 1)])]) - ) - ) - TxOutDatumNone - ReferenceScriptNone - ) - ] - + let utxos = mkUtxos beo scriptHash txInputs = map (,BuildTxWith (KeyWitness KeyWitnessForSpending)) . toList . M.keys . unUTxO $ utxos txInputsCollateral = TxInsCollateral aeo $ toList . M.keys . unUTxO $ utxos - - let address = - AddressInEra - (ShelleyAddressInEra ShelleyBasedEraConway) - ( ShelleyAddress - L.Testnet - (L.ScriptHashObj scriptHash) - L.StakeRefNull - ) - let txOutputs doesIncludeAsset = - [ TxOut - address - ( TxOutValueShelleyBased - ShelleyBasedEraConway - ( L.MaryValue - (L.Coin 2_000_000) - ( L.MultiAsset $ - if doesIncludeAsset - then [(L.PolicyID scriptHash, [(L.AssetName "eeee", 2)])] - else [] - ) - ) - ) - TxOutDatumNone - ReferenceScriptNone - ] + let address = mkAddress sbe scriptHash let txMint = TxMintValue - MaryEraOnwardsConway + meo [(AssetId policyId' "eeee", 1)] (BuildTxWith [(policyId', plutusWitness)]) @@ -132,12 +91,12 @@ prop_make_transaction_body_autobalance_return_correct_fee_for_multi_asset = H.pr defaultTxBodyContent sbe & setTxIns txInputs & setTxInsCollateral txInputsCollateral - & setTxOuts (txOutputs False) -- include minted asset in txout manually + & setTxOuts (mkTxOutput beo address Nothing) -- include minted asset in txout manually & setTxMintValue txMint & setTxProtocolParams (pure $ pure pparams) -- tx body content with manually added asset to TxOut - let contentWithTxoutAsset = content & setTxOuts (txOutputs True) + let contentWithTxoutAsset = content & setTxOuts (mkTxOutput beo address (Just scriptHash)) -- change txout only with ADA (BalancedTxBody balancedContentWithTxoutAsset _ _ feeWithTxoutAsset) <- @@ -178,34 +137,242 @@ prop_make_transaction_body_autobalance_return_correct_fee_for_multi_asset = H.pr H.note_ "There are differences between fees for two autobalanced TxBodyContents. Diff:" H.diff balancedContentWithTxoutAsset (\_ _ -> feeWithTxoutAsset == fee) balancedContent feeWithTxoutAsset === fee - where - loadPlutusWitness - :: HasCallStack - => MonadFail m - => MonadIO m - => MonadTest m - => m (ScriptWitness WitCtxMint ConwayEra) - loadPlutusWitness = do - envelope <- - H.leftFailM $ - fmap (deserialiseFromJSON AsTextEnvelope) . H.evalIO $ - B.readFile "test/cardano-api-test/files/input/plutus/v3.alwaysTrue.json" - ScriptInAnyLang (PlutusScriptLanguage PlutusScriptV3) (PlutusScript PlutusScriptV3 script) <- - H.leftFail $ deserialiseFromTextEnvelopeAnyOf textEnvTypes envelope - pure $ - PlutusScriptWitness - PlutusScriptV3InConway + +prop_make_transaction_body_autobalance_multi_asset_collateral :: Property +prop_make_transaction_body_autobalance_multi_asset_collateral = H.propertyOnce $ do + let ceo = ConwayEraOnwardsConway + beo = conwayEraOnwardsToBabbageEraOnwards ceo + sbe = babbageEraOnwardsToShelleyBasedEra beo + meo = babbageEraOnwardsToMaryEraOnwards 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" + + 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 + 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 + [(AssetId policyId' "eeee", 1)] + (BuildTxWith [(policyId', plutusWitness)]) + + let content = + defaultTxBodyContent sbe + & setTxIns txInputs + & setTxInsCollateral txInputsCollateral + & setTxOuts (mkTxOutput beo address Nothing) + & setTxMintValue txMint + & setTxProtocolParams (pure $ pure pparams) + + -- autobalanced body has assets and ADA in the change txout + (BalancedTxBody balancedContent _ _ fee) <- + H.leftFail $ + makeTransactionBodyAutoBalance + sbe + systemStart + epochInfo + pparams + mempty + mempty + mempty + utxos + content + address + Nothing + + 335_475 === fee + TxReturnCollateral _ (TxOut _ txOutValue _ _) <- H.noteShow $ 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 + +-- | Implements collateral validation from Babbage spec, from +-- https://github.com/IntersectMBO/cardano-ledger/releases, babbage-ledger.pdf, Figure 2. +-- +-- Seems that under 400 runs the test is not able to detect the violation of properties. +prop_calcReturnAndTotalCollateral :: Property +prop_calcReturnAndTotalCollateral = H.withTests 400 . H.property $ do + let beo = BabbageEraOnwardsConway + sbe = babbageEraOnwardsToShelleyBasedEra beo + era = toCardanoEra beo + feeCoin@(L.Coin fee) <- forAll genLovelace + totalCollateral <- forAll $ genValueForTxOut sbe + let totalCollateralAda = totalCollateral ^. L.adaAssetL sbe + pparams <- + H.readJsonFileOk "test/cardano-api-test/files/input/protocol-parameters/conway.json" + requiredCollateralPct <- H.noteShow . fromIntegral $ pparams ^. L.ppCollateralPercentageL + requiredCollateralAda <- + H.noteShow . L.rationalToCoinViaCeiling $ (fee * requiredCollateralPct) % 100 + txInsColl <- forAll $ genTxInsCollateral era + txRetColl <- + forAll $ Gen.frequency [(4, pure TxReturnCollateralNone), (1, genTxReturnCollateral sbe)] + txTotColl <- forAll $ Gen.frequency [(4, pure TxTotalCollateralNone), (1, genTxTotalCollateral era)] + let address = AddressInEra (ShelleyAddressInEra sbe) (ShelleyAddress L.Testnet def L.StakeRefNull) + + let (resRetColl, resTotColl) = + calcReturnAndTotalCollateral + beo + feeCoin + pparams + txInsColl + txRetColl + txTotColl + address + totalCollateral + + H.annotateShow resRetColl + H.annotateShow resTotColl + + let resRetCollValue = + mconcat + [ txOutValue + | TxReturnCollateral _ (TxOut _ (TxOutValueShelleyBased _ txOutValue) _ _) <- pure resRetColl + ] + collBalance = totalCollateral <-> resRetCollValue + + resTotCollValue <- + H.noteShow $ mconcat [L.mkAdaValue sbe lovelace | TxTotalCollateral _ lovelace <- pure resTotColl] + + if + | txInsColl == TxInsCollateralNone -> do + -- no inputs - no outputs + TxReturnCollateralNone === resRetColl + TxTotalCollateralNone === resTotColl + | txRetColl /= TxReturnCollateralNone || txTotColl /= TxTotalCollateralNone -> do + -- got collateral values as function arguments - not calculating anything + txRetColl === resRetColl + txTotColl === resTotColl + | totalCollateralAda < requiredCollateralAda -> do + -- provided collateral not enough, not calculating anything + TxReturnCollateralNone === resRetColl + TxTotalCollateralNone === resTotColl + | otherwise -> do + -- no explicit collateral or return collateral was provided, we do the calculation + H.annotateShow collBalance + H.note_ "Check if collateral balance is positive" + H.assertWith collBalance $ L.pointwise (<=) mempty + H.note_ "Check if collateral balance contains only ada" + H.assertWith collBalance L.isAdaOnly + H.note_ "Check if collateral balance is at least minimum required" + H.assertWith collBalance $ L.pointwise (<=) (L.inject requiredCollateralAda) + H.note_ "Check that collateral balance is equal to collateral in tx body" + resTotCollValue === collBalance + +-- * Utilities + +loadPlutusWitness + :: HasCallStack + => MonadFail m + => MonadIO m + => MonadTest m + => ConwayEraOnwards era + -> m (ScriptHash, ScriptWitness WitCtxMint era) +loadPlutusWitness ceo = do + envelope <- + H.leftFailM $ + fmap (deserialiseFromJSON AsTextEnvelope) . H.evalIO $ + B.readFile "test/cardano-api-test/files/input/plutus/v3.alwaysTrue.json" + ScriptInAnyLang (PlutusScriptLanguage PlutusScriptV3) s@(PlutusScript PlutusScriptV3 script) <- + H.leftFail $ deserialiseFromTextEnvelopeAnyOf textEnvTypes envelope + let scriptLangInEra = case ceo of + ConwayEraOnwardsConway -> PlutusScriptV3InConway + pure + ( hashScript s + , PlutusScriptWitness + scriptLangInEra PlutusScriptV3 (PScript script) NoScriptDatumForMint (unsafeHashableScriptData (ScriptDataMap [])) (ExecutionUnits 0 0) + ) + +textEnvTypes :: [FromSomeType HasTextEnvelope ScriptInAnyLang] +textEnvTypes = + [ FromSomeType + (AsScript AsPlutusScriptV3) + (ScriptInAnyLang (PlutusScriptLanguage PlutusScriptV3)) + ] + +mkUtxos :: BabbageEraOnwards era -> L.ScriptHash L.StandardCrypto -> UTxO era +mkUtxos beo scriptHash = babbageEraOnwardsConstraints beo $ do + let sbe = babbageEraOnwardsToShelleyBasedEra beo + UTxO + [ + ( TxIn + "01f4b788593d4f70de2a45c2e1e87088bfbdfa29577ae1b62aba60e095e3ab53" + (TxIx 0) + , TxOut + ( AddressInEra + (ShelleyAddressInEra sbe) + ( ShelleyAddress + L.Testnet + ( L.KeyHashObj $ + L.KeyHash "ebe9de78a37f84cc819c0669791aa0474d4f0a764e54b9f90cfe2137" + ) + L.StakeRefNull + ) + ) + ( TxOutValueShelleyBased + sbe + ( L.MaryValue + (L.Coin 4_000_000) + (L.MultiAsset [(L.PolicyID scriptHash, [(L.AssetName "eeee", 1)])]) + ) + ) + TxOutDatumNone + ReferenceScriptNone + ) + ] - textEnvTypes :: [FromSomeType HasTextEnvelope ScriptInAnyLang] - textEnvTypes = - [ FromSomeType - (AsScript AsPlutusScriptV3) - (ScriptInAnyLang (PlutusScriptLanguage PlutusScriptV3)) +-- | Make an address from a script hash +mkAddress :: ShelleyBasedEra era -> L.ScriptHash L.StandardCrypto -> AddressInEra era +mkAddress sbe scriptHash = + AddressInEra + (ShelleyAddressInEra sbe) + ( ShelleyAddress + L.Testnet + (L.ScriptHashObj scriptHash) + L.StakeRefNull + ) + +-- | Make a single txout with an optional asset +mkTxOutput + :: BabbageEraOnwards era + -> AddressInEra era + -> Maybe (L.ScriptHash L.StandardCrypto) + -- ^ there will be an asset in the txout if provided + -> [TxOut CtxTx era] +mkTxOutput beo address mScriptHash = babbageEraOnwardsConstraints beo $ do + let sbe = babbageEraOnwardsToShelleyBasedEra beo + [ TxOut + address + ( TxOutValueShelleyBased + sbe + ( L.MaryValue + (L.Coin 2_000_000) + ( L.MultiAsset $ + fromList + [(L.PolicyID scriptHash, [(L.AssetName "eeee", 2)]) | scriptHash <- maybeToList mScriptHash] + ) + ) + ) + TxOutDatumNone + ReferenceScriptNone ] tests :: TestTree @@ -215,4 +382,8 @@ tests = [ testProperty "makeTransactionBodyAutoBalance test correct fees when mutli-asset tx" prop_make_transaction_body_autobalance_return_correct_fee_for_multi_asset + , testProperty + "makeTransactionBodyAutoBalance autobalances multi-asset collateral" + prop_make_transaction_body_autobalance_multi_asset_collateral + , testProperty "calcReturnAndTotalCollateral constraints hold" prop_calcReturnAndTotalCollateral ]