From 1e1d6199f4867c6ed157b7b7732791e5b23daddb Mon Sep 17 00:00:00 2001 From: Neil Mayhew Date: Fri, 18 Oct 2024 18:17:08 -0600 Subject: [PATCH 1/4] Implement WITHDRAWAL script tests --- .../Ledger/Alonzo/Imp/UtxowSpec/Valid.hs | 17 +++++++++++++---- 1 file changed, 13 insertions(+), 4 deletions(-) diff --git a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Imp/UtxowSpec/Valid.hs b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Imp/UtxowSpec/Valid.hs index d764049f34a..705903bce3a 100644 --- a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Imp/UtxowSpec/Valid.hs +++ b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Imp/UtxowSpec/Valid.hs @@ -37,6 +37,7 @@ spec = describe "Valid transactions" $ do alwaysSucceedsWithDatumHash = hashPlutusScript $ alwaysSucceedsWithDatum slang :: ScriptHash (EraCrypto era) alwaysSucceedsNoDatumHash = hashPlutusScript $ alwaysSucceedsNoDatum slang :: ScriptHash (EraCrypto era) alwaysFailsWithDatumHash = hashPlutusScript $ alwaysFailsWithDatum slang :: ScriptHash (EraCrypto era) + alwaysFailsNoDatumHash = hashPlutusScript $ alwaysFailsNoDatum slang :: ScriptHash (EraCrypto era) it "Validating SPEND script" $ do txIn <- produceScript alwaysSucceedsWithDatumHash @@ -68,10 +69,18 @@ spec = describe "Valid transactions" $ do & inputsTxBodyL .~ [txIn] & certsTxBodyL .~ [txCert] - it "Validating WITHDRAWAL script" $ do - const $ pendingWith "not implemented yet" - it "Not validating WITHDRAWAL script" $ do - const $ pendingWith "not implemented yet" + it "Validating WITHDRAWAL script" $ do + account <- registerStakeCredential @era $ ScriptHashObj alwaysSucceedsNoDatumHash + expectTxSuccess <=< submitTx $ + mkBasicTx $ + mkBasicTxBody & withdrawalsTxBodyL .~ Withdrawals [(account, mempty)] + + it "Not validating WITHDRAWAL script" $ do + account <- registerStakeCredential @era $ ScriptHashObj alwaysFailsNoDatumHash + expectTxSuccess <=< submitPhase2Invalid $ + mkBasicTx $ + mkBasicTxBody & withdrawalsTxBodyL .~ Withdrawals [(account, mempty)] + it "Validating MINT script" $ do const $ pendingWith "not implemented yet" it "Not validating MINT script" $ do From 149eec99137ce090a85a7fbd7ad2e0ec9cc6b2af Mon Sep 17 00:00:00 2001 From: Neil Mayhew Date: Mon, 21 Oct 2024 12:15:07 -0600 Subject: [PATCH 2/4] Improve logging in submitPhase2Invalid --- .../testlib/Test/Cardano/Ledger/Alonzo/ImpTest.hs | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) diff --git a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/ImpTest.hs b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/ImpTest.hs index 2ceefaab8e1..ead91721230 100644 --- a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/ImpTest.hs +++ b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/ImpTest.hs @@ -515,10 +515,15 @@ submitPhase2Invalid :: Tx era -> ImpTestM era (Tx era) submitPhase2Invalid tx = do - (predFailure, fixedUpTx) <- expectLeft =<< trySubmitTx tx - scriptPredicateFailure <- impScriptPredicateFailure fixedUpTx - predFailure `shouldBeExpr` pure (injectFailure scriptPredicateFailure) - withNoFixup $ submitTx $ fixedUpTx & isValidTxL .~ IsValid False + fixedUpTx <- + impAnn "Check that tx fails with IsValid True" $ do + tx ^. isValidTxL `shouldBe` IsValid True + (predFailure, fixedUpTx) <- expectLeft =<< trySubmitTx tx + scriptPredicateFailure <- impScriptPredicateFailure fixedUpTx + predFailure `shouldBeExpr` pure (injectFailure scriptPredicateFailure) + pure fixedUpTx + impAnn "Submit tx with IsValid False" $ do + withNoFixup $ submitTx $ fixedUpTx & isValidTxL .~ IsValid False expectTxSuccess :: ( HasCallStack From 26fab889c250ec791c893c3cf869152a9224073d Mon Sep 17 00:00:00 2001 From: Neil Mayhew Date: Mon, 21 Oct 2024 12:18:28 -0600 Subject: [PATCH 3/4] Implement MINT script tests --- .../Ledger/Alonzo/Imp/UtxowSpec/Valid.hs | 11 +++++--- eras/conway/impl/CHANGELOG.md | 1 + eras/conway/impl/cardano-ledger-conway.cabal | 1 - .../Cardano/Ledger/Conway/Imp/UtxosSpec.hs | 25 +++---------------- eras/mary/impl/CHANGELOG.md | 1 + .../Test/Cardano/Ledger/Mary/ImpTest.hs | 18 ++++++++++++- 6 files changed, 29 insertions(+), 28 deletions(-) diff --git a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Imp/UtxowSpec/Valid.hs b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Imp/UtxowSpec/Valid.hs index 705903bce3a..d4e38443463 100644 --- a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Imp/UtxowSpec/Valid.hs +++ b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Imp/UtxowSpec/Valid.hs @@ -19,6 +19,7 @@ import Cardano.Ledger.Plutus ( ) import Control.Monad ((<=<)) import Lens.Micro ((&), (.~)) +import Test.Cardano.Ledger.Alonzo.Arbitrary () import Test.Cardano.Ledger.Alonzo.ImpTest import Test.Cardano.Ledger.Imp.Common import Test.Cardano.Ledger.Plutus.Examples @@ -81,10 +82,12 @@ spec = describe "Valid transactions" $ do mkBasicTx $ mkBasicTxBody & withdrawalsTxBodyL .~ Withdrawals [(account, mempty)] - it "Validating MINT script" $ do - const $ pendingWith "not implemented yet" - it "Not validating MINT script" $ do - const $ pendingWith "not implemented yet" + it "Validating MINT script" $ do + expectTxSuccess <=< submitTx <=< mkTokenMintingTx $ alwaysSucceedsNoDatumHash + + it "Not validating MINT script" $ do + expectTxSuccess <=< submitPhase2Invalid <=< mkTokenMintingTx $ alwaysFailsNoDatumHash + it "Validating scripts everywhere" $ do const $ pendingWith "not implemented yet" it "Acceptable supplimentary datum" $ do diff --git a/eras/conway/impl/CHANGELOG.md b/eras/conway/impl/CHANGELOG.md index b5ae7a10956..6ffe0d4f3ca 100644 --- a/eras/conway/impl/CHANGELOG.md +++ b/eras/conway/impl/CHANGELOG.md @@ -8,6 +8,7 @@ ### `testlib` +* Remove `mintingTokenTx` (which is replaced by `mkTokenMintingTx` in Mary) * Add `minFeeUpdateGovAction` * Add `mkTreasuryWithdrawalsGovAction` and `mkParameterChangeGovAction` * Switch to using `ImpSpec` package diff --git a/eras/conway/impl/cardano-ledger-conway.cabal b/eras/conway/impl/cardano-ledger-conway.cabal index 62fe0d41706..51a6a43f9ce 100644 --- a/eras/conway/impl/cardano-ledger-conway.cabal +++ b/eras/conway/impl/cardano-ledger-conway.cabal @@ -163,7 +163,6 @@ library testlib cardano-ledger-babbage:{cardano-ledger-babbage, testlib}, cardano-ledger-conway, cardano-ledger-core:{cardano-ledger-core, testlib}, - cardano-ledger-mary, cardano-ledger-shelley:{cardano-ledger-shelley, testlib}, cardano-strict-containers, containers, diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/UtxosSpec.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/UtxosSpec.hs index 9c5c479cb92..cadd1515201 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/UtxosSpec.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/UtxosSpec.hs @@ -28,11 +28,6 @@ import Cardano.Ledger.Conway.TxInfo import Cardano.Ledger.Credential (Credential (..), StakeReference (..)) import Cardano.Ledger.DRep import Cardano.Ledger.Keys (KeyRole (..)) -import Cardano.Ledger.Mary.Value ( - MaryValue (..), - MultiAsset (..), - PolicyID (..), - ) import Cardano.Ledger.Plutus import Cardano.Ledger.Shelley.LedgerState import Cardano.Ledger.Shelley.Rules (ShelleyUtxowPredFailure (..)) @@ -597,11 +592,10 @@ costModelsSpec = govIdConstitution1 <- enactConstitution SNothing (Constitution anchor SNothing) dRep committeeMembers' - let mintingScriptHash = hashPlutusScript (evenRedeemerNoDatum SPlutusV3) + mintingTokenTx <- mkTokenMintingTx $ hashPlutusScript (evenRedeemerNoDatum SPlutusV3) impAnn "Minting token fails" $ do - tx <- mintingTokenTx @era (mkBasicTx @era mkBasicTxBody) mintingScriptHash - submitFailingTx tx [injectFailure $ CollectErrors [NoCostModel PlutusV3]] + submitFailingTx mintingTokenTx [injectFailure $ CollectErrors [NoCostModel PlutusV3]] govIdPPUpdate1 <- enactCostModels @@ -619,8 +613,7 @@ costModelsSpec = committeeMembers' impAnn "Minting token succeeds" $ do - tx <- mintingTokenTx @era (mkBasicTx @era mkBasicTxBody) mintingScriptHash - submitTx_ tx + submitTx_ mintingTokenTx impAnn "Updating CostModels succeeds" $ do void $ @@ -695,18 +688,6 @@ testPlutusV1V2Failure sh badField lenz errorField = do CollectErrors [BadTranslation errorField] ) -mintingTokenTx :: ConwayEraImp era => Tx era -> ScriptHash (EraCrypto era) -> ImpTestM era (Tx era) -mintingTokenTx tx sh = do - name <- arbitrary - count <- choose (0, 10) - let policyId = PolicyID sh - let ma = MultiAsset $ Map.singleton policyId [(name, count)] - addr <- freshKeyAddr_ - pure $ - tx - & bodyTxL . mintTxBodyL .~ ma - & bodyTxL . outputsTxBodyL <>~ [mkBasicTxOut addr (MaryValue mempty ma)] - enactCostModels :: ConwayEraImp era => StrictMaybe (GovPurposeId 'PParamUpdatePurpose era) -> diff --git a/eras/mary/impl/CHANGELOG.md b/eras/mary/impl/CHANGELOG.md index 879e265e2f9..d6200205fd1 100644 --- a/eras/mary/impl/CHANGELOG.md +++ b/eras/mary/impl/CHANGELOG.md @@ -6,6 +6,7 @@ ### `testlib` +* Add `mkTokenMintingTx` * Switch to using `ImpSpec` package ## 1.7.0.1 diff --git a/eras/mary/impl/testlib/Test/Cardano/Ledger/Mary/ImpTest.hs b/eras/mary/impl/testlib/Test/Cardano/Ledger/Mary/ImpTest.hs index fd687ef2a86..2a49b6818db 100644 --- a/eras/mary/impl/testlib/Test/Cardano/Ledger/Mary/ImpTest.hs +++ b/eras/mary/impl/testlib/Test/Cardano/Ledger/Mary/ImpTest.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} @@ -8,6 +9,7 @@ module Test.Cardano.Ledger.Mary.ImpTest ( MaryEraImp, module Test.Cardano.Ledger.Allegra.ImpTest, + mkTokenMintingTx, ) where import Cardano.Crypto.DSIGN (DSIGNAlgorithm (..), Ed25519DSIGN) @@ -18,8 +20,10 @@ import Cardano.Ledger.Crypto (Crypto (..)) import Cardano.Ledger.Mary (MaryEra) import Cardano.Ledger.Mary.Core import Cardano.Ledger.Mary.Value +import Lens.Micro ((&), (.~)) import Test.Cardano.Ledger.Allegra.ImpTest -import Test.Cardano.Ledger.Common +import Test.Cardano.Ledger.Imp.Common +import Test.Cardano.Ledger.Mary.Arbitrary () import Test.Cardano.Ledger.Mary.TreeDiff () instance @@ -52,3 +56,15 @@ instance , Signable (DSIGN c) (Hash (HASH c) EraIndependentTxBody) ) => MaryEraImp (MaryEra c) + +mkTokenMintingTx :: MaryEraImp era => ScriptHash (EraCrypto era) -> ImpTestM era (Tx era) +mkTokenMintingTx sh = do + name <- arbitrary + count <- choose (1, 10) + let policyId = PolicyID sh + let ma = multiAssetFromList [(policyId, name, count)] + addr <- freshKeyAddr_ + pure $ + mkBasicTx mkBasicTxBody + & bodyTxL . mintTxBodyL .~ ma + & bodyTxL . outputsTxBodyL .~ [mkBasicTxOut addr (MaryValue mempty ma)] From 521f1c4f9c425a2456030fc534bc77e18971b173 Mon Sep 17 00:00:00 2001 From: Neil Mayhew Date: Tue, 22 Oct 2024 14:57:13 -0600 Subject: [PATCH 4/4] Fix incorrect handling of timelocks in impAllegraSatisfyNativeScript --- .../Test/Cardano/Ledger/Allegra/ImpTest.hs | 18 +++++++++++------- .../Test/Cardano/Ledger/Shelley/ImpTest.hs | 9 ++++++--- 2 files changed, 17 insertions(+), 10 deletions(-) diff --git a/eras/allegra/impl/testlib/Test/Cardano/Ledger/Allegra/ImpTest.hs b/eras/allegra/impl/testlib/Test/Cardano/Ledger/Allegra/ImpTest.hs index bb7e672f051..44299d1b64b 100644 --- a/eras/allegra/impl/testlib/Test/Cardano/Ledger/Allegra/ImpTest.hs +++ b/eras/allegra/impl/testlib/Test/Cardano/Ledger/Allegra/ImpTest.hs @@ -19,6 +19,7 @@ import Cardano.Ledger.Allegra (AllegraEra) import Cardano.Ledger.Allegra.Core import Cardano.Ledger.Allegra.Scripts ( AllegraEraScript, + evalTimelock, pattern RequireTimeExpire, pattern RequireTimeStart, ) @@ -55,15 +56,18 @@ instance fixupTx = shelleyFixupTx impAllegraSatisfyNativeScript :: - AllegraEraScript era => + ( AllegraEraScript era + , AllegraEraTxBody era + ) => Set.Set (KeyHash 'Witness (EraCrypto era)) -> + TxBody era -> NativeScript era -> ImpTestM era (Maybe (Map.Map (KeyHash 'Witness (EraCrypto era)) (KeyPair 'Witness (EraCrypto era)))) -impAllegraSatisfyNativeScript providedVKeyHashes script = do +impAllegraSatisfyNativeScript providedVKeyHashes txBody script = do impState <- get let keyPairs = impState ^. impKeyPairsG - prevSlotNo = impState ^. impLastTickG + vi = txBody ^. vldtTxBodyL satisfyMOf m Empty | m <= 0 = Just mempty | otherwise = Nothing @@ -82,10 +86,10 @@ impAllegraSatisfyNativeScript providedVKeyHashes script = do RequireAllOf ss -> satisfyMOf (length ss) ss RequireAnyOf ss -> satisfyMOf 1 ss RequireMOf m ss -> satisfyMOf m ss - RequireTimeExpire slotNo - | slotNo < prevSlotNo -> Just mempty + lock@(RequireTimeStart _) + | evalTimelock mempty vi lock -> Just mempty | otherwise -> Nothing - RequireTimeStart slotNo - | slotNo > prevSlotNo -> Just mempty + lock@(RequireTimeExpire _) + | evalTimelock mempty vi lock -> Just mempty | otherwise -> Nothing pure $ satisfyScript script diff --git a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/ImpTest.hs b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/ImpTest.hs index 0faa667932c..fecf2a9d770 100644 --- a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/ImpTest.hs +++ b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/ImpTest.hs @@ -512,6 +512,8 @@ class impSatisfyNativeScript :: -- | Set of Witnesses that have already been satisfied Set.Set (KeyHash 'Witness (EraCrypto era)) -> + -- | The transaction body that the script will be applied to + TxBody era -> NativeScript era -> ImpTestM era (Maybe (Map (KeyHash 'Witness (EraCrypto era)) (KeyPair 'Witness (EraCrypto era)))) @@ -714,7 +716,7 @@ instance startEpochNo = impEraStartEpochNo @(ShelleyEra c) pure $ translateToShelleyLedgerStateFromUtxo transContext startEpochNo Byron.empty - impSatisfyNativeScript providedVKeyHashes script = do + impSatisfyNativeScript providedVKeyHashes _txBody script = do keyPairs <- gets impKeyPairs let satisfyMOf m Empty @@ -863,7 +865,8 @@ updateAddrTxWits tx = impAnn "updateAddrTxWits" $ do addrWitHashes = curAddrWitHashes <> Set.map witVKeyHash extraAddrVKeyWits -- Shelley Based Native Script Witnesses scriptsRequired <- impNativeScriptsRequired tx - nativeScriptsKeyPairs <- mapM (impSatisfyNativeScript addrWitHashes) (Map.elems scriptsRequired) + nativeScriptsKeyPairs <- + mapM (impSatisfyNativeScript addrWitHashes txBody) (Map.elems scriptsRequired) let extraNativeScriptVKeyWits = mkWitnessesVKey txBodyHash $ Map.elems (mconcat (catMaybes nativeScriptsKeyPairs)) -- Byron Based Witessed @@ -903,7 +906,7 @@ impNativeScriptKeyPairs tx = do scriptsRequired <- impNativeScriptsRequired tx let nativeScripts = Map.elems scriptsRequired curAddrWits = Set.map witVKeyHash $ tx ^. witsTxL . addrTxWitsL - keyPairs <- mapM (impSatisfyNativeScript curAddrWits) nativeScripts + keyPairs <- mapM (impSatisfyNativeScript curAddrWits $ tx ^. bodyTxL) nativeScripts pure . mconcat $ catMaybes keyPairs fixupTxOuts :: (ShelleyEraImp era, HasCallStack) => Tx era -> ImpTestM era (Tx era)