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 16c583c6199..fd573eccdba 100644 --- a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/ImpTest.hs +++ b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/ImpTest.hs @@ -363,6 +363,8 @@ plutusTestScripts lang = Map.fromList [ mkScriptTestEntry (alwaysSucceeds2 lang) $ PlutusArgs (P.I 0) Nothing , mkScriptTestEntry (alwaysSucceeds3 lang) $ PlutusArgs (P.I 0) (Just $ P.I 0) + , mkScriptTestEntry (alwaysFails2 lang) $ PlutusArgs (P.I 0) Nothing + , mkScriptTestEntry (alwaysFails3 lang) $ PlutusArgs (P.I 0) (Just $ P.I 0) , mkScriptTestEntry (guessTheNumber2 lang) $ PlutusArgs (P.I 3) Nothing , mkScriptTestEntry (guessTheNumber3 lang) $ PlutusArgs (P.I 3) (Just $ P.I 3) , mkScriptTestEntry (evendata3 lang) $ PlutusArgs (P.I 4) (Just $ P.I 0) diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp.hs index ff742516a94..cb573c70b6f 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp.hs @@ -17,6 +17,7 @@ import Cardano.Ledger.Conway.Core import Cardano.Ledger.Conway.Governance (ConwayGovState) import Cardano.Ledger.Conway.Rules (ConwayGovPredFailure) import Cardano.Ledger.Conway.TxInfo (ConwayContextError) +import Cardano.Ledger.Shelley.Rules (ShelleyUtxowPredFailure (..)) import Test.Cardano.Ledger.Common import qualified Test.Cardano.Ledger.Conway.Imp.EnactSpec as Enact import qualified Test.Cardano.Ledger.Conway.Imp.EpochSpec as Epoch @@ -35,6 +36,7 @@ spec :: , Inject (ConwayContextError era) (ContextError era) , InjectRuleFailure "LEDGER" BabbageUtxoPredFailure era , InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era + , InjectRuleFailure "LEDGER" ShelleyUtxowPredFailure era ) => Spec spec = do diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/GovSpec.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/GovSpec.hs index 20f86ae3c49..c99681a09cf 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/GovSpec.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/GovSpec.hs @@ -44,6 +44,7 @@ import qualified Data.Sequence.Strict as SSeq import qualified Data.Set as Set import Data.Tree import Lens.Micro +import Test.Cardano.Ledger.Conway.Arbitrary () import Test.Cardano.Ledger.Conway.ImpTest import Test.Cardano.Ledger.Core.KeyPair (mkAddr) import Test.Cardano.Ledger.Core.Rational (IsRatio (..)) @@ -628,58 +629,6 @@ spec = passNEpochs 3 fmap (!! 3) getProposalsForest `shouldReturn` Node (SJust p116) [] - describe "Proposals always have valid previous actions" $ do - context "Invalid proposals are rejected" $ do - it "Invalid Index in GovPurposeId" $ do - gaidConstitutionProp <- submitInitConstitutionGovAction - curConstitution <- getsNES $ newEpochStateGovStateL . constitutionGovStateL - constitutionHash <- freshSafeHash - let constitutionActionNext = - NewConstitution - (SJust $ GovPurposeId gaidConstitutionProp) - ( Constitution - ( Anchor - (fromJust $ textToUrl 64 "constitution.1") - constitutionHash - ) - SNothing - ) - curConstitution' <- getsNES $ newEpochStateGovStateL . constitutionGovStateL - impAnn "Constitution has not been enacted yet" $ - curConstitution' `shouldBe` curConstitution - submitGovAction_ constitutionActionNext - it "Enact Constitution and use valid GovPurposeId" $ do - (dRep, committeeMember, _) <- electBasicCommittee - constitutionHash <- freshSafeHash - let constitution = - Constitution - ( Anchor - (fromJust $ textToUrl 64 "constitution.0") - constitutionHash - ) - SNothing - constitutionAction = - NewConstitution SNothing constitution - gaidConstitutionProp <- submitGovAction constitutionAction - submitYesVote_ (DRepVoter dRep) gaidConstitutionProp - submitYesVote_ (CommitteeVoter committeeMember) gaidConstitutionProp - passEpoch - passEpoch - curConstitution <- getsNES $ newEpochStateGovStateL . constitutionGovStateL - impAnn "Constitution has been enacted" $ - curConstitution `shouldBe` constitution - constitutionHash1 <- freshSafeHash - let constitutionAction1 = - NewConstitution - (SJust $ GovPurposeId gaidConstitutionProp) - ( Constitution - ( Anchor - (fromJust $ textToUrl 64 "constitution.1") - constitutionHash1 - ) - SNothing - ) - submitGovAction_ constitutionAction1 describe "Voting" $ do context "fails for" $ do @@ -851,13 +800,19 @@ spec = (pp ^. ppMinFeeAL) `shouldBe` newMinFeeA describe "Constitution proposals" $ do - context "accepted for" $ + context "accepted for" $ do it "empty PrevGovId before the first constitution is enacted" $ do -- Initial proposal does not need a GovPurposeId but after it is enacted, the -- following ones are not _ <- submitConstitution SNothing -- Until the first proposal is enacted all proposals with empty GovPurposeIds are valid void $ submitConstitution SNothing + it "valid GovPurposeId" $ do + (dRep, committeeMember, _) <- electBasicCommittee + constitution <- arbitrary + gaidConstitutionProp <- enactConstitution SNothing constitution dRep committeeMember + constitution1 <- arbitrary + void $ enactConstitution (SJust $ GovPurposeId gaidConstitutionProp) constitution1 dRep committeeMember context "rejected for" $ do it "empty PrevGovId after the first constitution was enacted" $ do @@ -866,7 +821,7 @@ spec = submitYesVote_ (DRepVoter dRep) govActionId submitYesVote_ (CommitteeVoter committeeMember) govActionId passNEpochs 2 - constitution <- newConstitution + constitution <- arbitrary let invalidNewConstitutionGovAction = NewConstitution SNothing @@ -880,7 +835,7 @@ spec = (_dRep, _committeeMember, _) <- electBasicCommittee (govActionId, _constitution) <- submitConstitution SNothing passNEpochs 2 - constitution <- newConstitution + constitution <- arbitrary let invalidPrevGovActionId = -- Expected Ix = 0 GovPurposeId (govActionId {gaidGovActionIx = GovActionIx 1}) @@ -995,15 +950,15 @@ spec = rsEnactState pulserRatifyState `shouldBe` enactState it "policy is respected by proposals" $ do + (dRep, committeeMember, _) <- electBasicCommittee keyHash <- freshKeyHash scriptHash <- impAddNativeScript $ RequireAllOf (SSeq.singleton (RequireSignature keyHash)) + anchor <- arbitrary + _ <- enactConstitution SNothing (Constitution anchor (SJust scriptHash)) dRep committeeMember wrongScriptHash <- impAddNativeScript $ RequireMOf 1 $ SSeq.fromList [RequireAnyOf mempty, RequireAllOf mempty] - modifyNES $ - nesEsL . esLStateL . lsUTxOStateL . utxosGovStateL . constitutionGovStateL - .~ Constitution def (SJust scriptHash) pp <- getsNES $ nesEsL . curPParamsEpochStateL impAnn "ParameterChange with correct policy succeeds" $ do let @@ -1034,7 +989,7 @@ spec = , pProcAnchor = def } - impAnn "ParameterChange with invalid policy succeeds" $ do + impAnn "ParameterChange with invalid policy fails" $ do rewardAccount <- registerRewardAccount let pparamsUpdate = @@ -1053,7 +1008,7 @@ spec = InvalidPolicyHash (SJust wrongScriptHash) (SJust scriptHash) ] - impAnn "TreasuryWithdrawals with invalid policy succeeds" $ do + impAnn "TreasuryWithdrawals with invalid policy fails" $ do rewardAccount <- registerRewardAccount let withdrawals = @@ -1518,7 +1473,7 @@ submitConstitution :: StrictMaybe (GovPurposeId 'ConstitutionPurpose era) -> ImpTestM era (GovActionId (EraCrypto era), Constitution era) submitConstitution prevGovId = do - constitution <- newConstitution + constitution <- arbitrary let constitutionAction = NewConstitution prevGovId @@ -1526,17 +1481,6 @@ submitConstitution prevGovId = do govActionId <- submitGovAction constitutionAction pure (govActionId, constitution) -newConstitution :: Era era => ImpTestM era (Constitution era) -newConstitution = do - constitutionHash <- freshSafeHash - pure $ - Constitution - ( Anchor - (fromJust $ textToUrl 64 "constitution.0") - constitutionHash - ) - SNothing - proposalWithRewardAccount :: forall era. ConwayEraImp era => 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 733cd2a222f..fdeceed089f 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 @@ -2,6 +2,8 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -9,9 +11,13 @@ module Test.Cardano.Ledger.Conway.Imp.UtxosSpec where import Cardano.Ledger.Address (Addr (..)) +import Cardano.Ledger.Allegra.Scripts ( + pattern RequireTimeStart, + ) import Cardano.Ledger.Alonzo.Plutus.Context (EraPlutusContext (..)) import Cardano.Ledger.Alonzo.Plutus.Evaluate (CollectError (..)) import Cardano.Ledger.Alonzo.Rules (AlonzoUtxosPredFailure (..)) +import Cardano.Ledger.Alonzo.Tx (IsValid (..)) import Cardano.Ledger.Babbage.Rules (BabbageUtxoPredFailure (..)) import Cardano.Ledger.Babbage.TxInfo (BabbageContextError (..)) import Cardano.Ledger.BaseTypes @@ -30,6 +36,7 @@ import Cardano.Ledger.Plutus ( hashPlutusScript, ) import Cardano.Ledger.Shelley.LedgerState +import Cardano.Ledger.Shelley.Rules (ShelleyUtxowPredFailure (..)) import Cardano.Ledger.TxIn (TxId (..), mkTxInPartial) import Data.Default.Class (def) import Data.List.NonEmpty (NonEmpty (..)) @@ -44,7 +51,7 @@ import Test.Cardano.Ledger.Core.KeyPair (mkAddr) import Test.Cardano.Ledger.Core.Rational ((%!)) import Test.Cardano.Ledger.Core.Utils import Test.Cardano.Ledger.Imp.Common -import Test.Cardano.Ledger.Plutus.Examples (guessTheNumber3) +import Test.Cardano.Ledger.Plutus.Examples (alwaysFails2, alwaysSucceeds2, guessTheNumber3) spendDatum :: P1.Data spendDatum = P1.I 3 @@ -127,17 +134,19 @@ testPlutusV1V2Failure sh badField lenz errorField = do spec :: forall era. - ( Inject (BabbageContextError era) (ContextError era) + ( ConwayEraImp era + , Inject (BabbageContextError era) (ContextError era) + , Inject (ConwayContextError era) (ContextError era) , InjectRuleFailure "LEDGER" BabbageUtxoPredFailure era , InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era - , ConwayEraImp era - , Inject (ConwayContextError era) (ContextError era) + , InjectRuleFailure "LEDGER" ShelleyUtxowPredFailure era ) => SpecWith (ImpTestState era) spec = describe "UTXOS" $ do datumAndReferenceInputsSpec conwayFeaturesPlutusV1V2FailureSpec + govPolicySpec datumAndReferenceInputsSpec :: forall era. @@ -485,3 +494,123 @@ conwayFeaturesPlutusV1V2FailureSpec = do (drepKH, _delegatorKH, _spendingKP) <- setupSingleDRep 1_000 let updateDRepTxCert = UpdateDRepTxCert @era (KeyHashObj drepKH) SNothing testCertificateNotSupportedV2 updateDRepTxCert + +govPolicySpec :: + forall era. + ( ConwayEraImp era + , InjectRuleFailure "LEDGER" ShelleyUtxowPredFailure era + ) => + SpecWith (ImpTestState era) +govPolicySpec = do + describe "Gov policy scripts" $ do + it "failing native script govPolicy" $ do + (dRep, committeeMember, _) <- electBasicCommittee + scriptHash <- impAddNativeScript $ RequireTimeStart (SlotNo 1) + anchor <- arbitrary + void $ enactConstitution SNothing (Constitution anchor (SJust scriptHash)) dRep committeeMember + rewardAccount <- registerRewardAccount + pp <- getsNES $ nesEsL . curPParamsEpochStateL + impAnn "ParameterChange" $ do + let pparamsUpdate = def & ppuCommitteeMinSizeL .~ SJust 1 + let govAction = ParameterChange SNothing pparamsUpdate (SJust scriptHash) + let proposal = + ProposalProcedure + { pProcReturnAddr = rewardAccount + , pProcGovAction = govAction + , pProcDeposit = pp ^. ppGovActionDepositL + , pProcAnchor = anchor + } + let tx = + mkBasicTx mkBasicTxBody + & bodyTxL . proposalProceduresTxBodyL .~ [proposal] + & bodyTxL . vldtTxBodyL .~ ValidityInterval SNothing SNothing + submitFailingTx tx [injectFailure $ ScriptWitnessNotValidatingUTXOW [scriptHash]] + + impAnn "TreasuryWithdrawals" $ do + let withdrawals = Map.fromList [(rewardAccount, Coin 1000)] + let govAction = TreasuryWithdrawals withdrawals (SJust scriptHash) + + let proposal = + ProposalProcedure + { pProcReturnAddr = rewardAccount + , pProcGovAction = govAction + , pProcDeposit = pp ^. ppGovActionDepositL + , pProcAnchor = anchor + } + let tx = + mkBasicTx mkBasicTxBody + & bodyTxL . proposalProceduresTxBodyL .~ [proposal] + & bodyTxL . vldtTxBodyL .~ ValidityInterval SNothing SNothing + submitFailingTx tx [injectFailure $ ScriptWitnessNotValidatingUTXOW [scriptHash]] + + it "alwaysSucceeds Plutus govPolicy validates" $ do + let alwaysSucceedsSh = hashPlutusScript (alwaysSucceeds2 SPlutusV3) + (dRep, committeeMember, _) <- electBasicCommittee + anchor <- arbitrary + pp <- getsNES $ nesEsL . curPParamsEpochStateL + void $ enactConstitution SNothing (Constitution anchor (SJust alwaysSucceedsSh)) dRep committeeMember + rewardAccount <- registerRewardAccount + + impAnn "ParameterChange" $ do + let pparamsUpdate = def & ppuCommitteeMinSizeL .~ SJust 1 + let govAction = ParameterChange SNothing pparamsUpdate (SJust alwaysSucceedsSh) + let proposal = + ProposalProcedure + { pProcReturnAddr = rewardAccount + , pProcGovAction = govAction + , pProcDeposit = pp ^. ppGovActionDepositL + , pProcAnchor = anchor + } + submitProposal_ proposal + impAnn "TreasuryWithdrawals" $ do + let withdrawals = Map.fromList [(rewardAccount, Coin 1000)] + let govAction = TreasuryWithdrawals withdrawals (SJust alwaysSucceedsSh) + + let proposal = + ProposalProcedure + { pProcReturnAddr = rewardAccount + , pProcGovAction = govAction + , pProcDeposit = pp ^. ppGovActionDepositL + , pProcAnchor = anchor + } + submitProposal_ proposal + + it "alwaysFails Plutus govPolicy does not validate" $ do + let alwaysFailsSh = hashPlutusScript (alwaysFails2 SPlutusV3) + (dRep, committeeMember, _) <- electBasicCommittee + anchor <- arbitrary + pp <- getsNES $ nesEsL . curPParamsEpochStateL + void $ enactConstitution SNothing (Constitution anchor (SJust alwaysFailsSh)) dRep committeeMember + + rewardAccount <- registerRewardAccount + impAnn "ParameterChange" $ do + let pparamsUpdate = def & ppuCommitteeMinSizeL .~ SJust 1 + let govAction = ParameterChange SNothing pparamsUpdate (SJust alwaysFailsSh) + let proposal = + ProposalProcedure + { pProcReturnAddr = rewardAccount + , pProcGovAction = govAction + , pProcDeposit = pp ^. ppGovActionDepositL + , pProcAnchor = anchor + } + let tx = mkBasicTx mkBasicTxBody & bodyTxL . proposalProceduresTxBodyL .~ [proposal] + res <- trySubmitTx tx + void $ expectLeft res + -- TODO: find a way to check that this is a PlutusFailure, without comparing the entire PredicateFailure + submitTx_ $ tx & isValidTxL .~ IsValid False + + impAnn "TreasuryWithdrawals" $ do + let withdrawals = Map.fromList [(rewardAccount, Coin 1000)] + let govAction = TreasuryWithdrawals withdrawals (SJust alwaysFailsSh) + let proposal = + ProposalProcedure + { pProcReturnAddr = rewardAccount + , pProcGovAction = govAction + , pProcDeposit = pp ^. ppGovActionDepositL + , pProcAnchor = anchor + } + let tx = mkBasicTx mkBasicTxBody & bodyTxL . proposalProceduresTxBodyL .~ [proposal] + res <- trySubmitTx tx + void $ expectLeft res + -- TODO: find a way to check that this is a PlutusFailure, without comparing the entire PredicateFailure + submitTx_ $ tx & isValidTxL .~ IsValid False diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/ImpTest.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/ImpTest.hs index 02a7cd03672..58b0619d74e 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/ImpTest.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/ImpTest.hs @@ -20,6 +20,7 @@ module Test.Cardano.Ledger.Conway.ImpTest ( module ImpTest, ConwayEraImp, + enactConstitution, submitGovAction, submitGovAction_, submitGovActions, @@ -1109,6 +1110,29 @@ submitConstitutionGovActionForest p forest = n <- submitConstitutionGovAction $ GovPurposeId <$> parent pure (n, fmap (\(Node _child subtree) -> Node (SJust n) subtree) children) +enactConstitution :: + forall era. + ( ConwayEraImp era + , HasCallStack + ) => + StrictMaybe (GovPurposeId 'ConstitutionPurpose era) -> + Constitution era -> + Credential 'DRepRole (EraCrypto era) -> + Credential 'HotCommitteeRole (EraCrypto era) -> + ImpTestM era (GovActionId (EraCrypto era)) +enactConstitution prevGovId constitution dRep committeeMember = impAnn "Enacting constitution" $ do + let action = NewConstitution prevGovId constitution + govId <- submitGovAction action + submitYesVote_ (DRepVoter dRep) govId + submitYesVote_ (CommitteeVoter committeeMember) govId + logRatificationChecks govId + passNEpochs 2 + enactedConstitution <- + getsNES $ + nesEsL . esLStateL . lsUTxOStateL . utxosGovStateL . constitutionGovStateL + enactedConstitution `shouldBe` constitution + pure govId + -- | Asserts that the URL of the current constitution is equal to the given -- string constitutionShouldBe :: (HasCallStack, ConwayEraGov era) => String -> ImpTestM era () diff --git a/eras/shelley/impl/CHANGELOG.md b/eras/shelley/impl/CHANGELOG.md index 94285778c8e..5a4390d9c7f 100644 --- a/eras/shelley/impl/CHANGELOG.md +++ b/eras/shelley/impl/CHANGELOG.md @@ -41,7 +41,6 @@ * `fixupFees` * `logFeeMismatch` * `impScriptsL` - * `impCollateralTxIdsL` * `impNativeScriptsG` * Add: * `expectRegisteredRewardAddress` 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 7976f9594b5..1711b7fad9b 100644 --- a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/ImpTest.hs +++ b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/ImpTest.hs @@ -91,9 +91,6 @@ module Test.Cardano.Ledger.Shelley.ImpTest ( -- * Combinators withNoFixup, - - -- * Lenses - impCollateralTxIdsL, -- We only export getters, because internal state should not be accessed during testing impNESG, impLastTickG, @@ -111,7 +108,6 @@ import Cardano.Ledger.BaseTypes ( BlocksMade (..), EpochSize (..), Globals (..), - Inject, Network (..), ShelleyBase, SlotNo, @@ -213,7 +209,6 @@ import Test.Cardano.Ledger.Core.KeyPair ( KeyPair (..), mkAddr, mkKeyHash, - mkKeyPair, mkWitnessesVKey, ) import Test.Cardano.Ledger.Core.Utils (mkDummySafeHash, testGlobals, txInAt) @@ -238,7 +233,6 @@ import UnliftIO.Exception ( data ImpTestState era = ImpTestState { impNES :: !(NewEpochState era) , impRootTxIn :: !(TxIn (EraCrypto era)) - , impCollateralTxIds :: ![TxIn (EraCrypto era)] , impKeyPairs :: !(forall k. Map (KeyHash k (EraCrypto era)) (KeyPair k (EraCrypto era))) , impByronKeyPairs :: !(Map (BootstrapAddress (EraCrypto era)) ByronKeyPair) , impNativeScripts :: !(Map (ScriptHash (EraCrypto era)) (NativeScript era)) @@ -278,9 +272,6 @@ impNativeScriptsL = lens impNativeScripts (\x y -> x {impNativeScripts = y}) impNativeScriptsG :: SimpleGetter (ImpTestState era) (Map (ScriptHash (EraCrypto era)) (NativeScript era)) impNativeScriptsG = impNativeScriptsL -impCollateralTxIdsL :: Lens' (ImpTestState era) [TxIn (EraCrypto era)] -impCollateralTxIdsL = lens impCollateralTxIds (\x y -> x {impCollateralTxIds = y}) - class ( Show (NewEpochState era) , ToExpr (NewEpochState era) @@ -391,14 +382,6 @@ mkHashVerKeyVRF = testKeyHash :: Crypto c => KeyHash kd c testKeyHash = mkKeyHash (-1) -impAddr :: Crypto c => Int -> Addr c -impAddr idx = - let KeyPair vk _ = mkKeyPair idx - in Addr - Testnet - (KeyHashObj $ hashKey vk) - StakeRefNull - initShelleyImpNES :: forall era. ( Default (StashedAVVMAddresses era) @@ -466,19 +449,6 @@ initShelleyImpNES = mkTxId :: Crypto c => Int -> TxId c mkTxId idx = TxId (mkDummySafeHash Proxy idx) -mkCollateralUTxO :: - ( EraTxOut era - , Inject t (Value era) - ) => - t -> - [(TxIn (EraCrypto era), TxOut era)] -mkCollateralUTxO rootCoin = - [ ( TxIn (mkTxId idx) minBound - , mkBasicTxOut (impAddr idx) $ inject rootCoin - ) - | idx <- [1 .. 100] - ] - instance ( Crypto c , NFData (SigDSIGN (DSIGN c)) @@ -859,6 +829,7 @@ trySubmitTx tx = do logToExpr txFixed st <- gets impNES lEnv <- impLedgerEnv st + ImpTestState {impRootTxIn} <- get res <- tryRunImpRule @"LEDGER" lEnv (st ^. nesEsL . esLStateL) txFixed let txId = TxId . hashAnnotated $ txFixed ^. bodyTxL outsSize = SSeq.length $ txFixed ^. bodyTxL . outputsTxBodyL @@ -867,7 +838,16 @@ trySubmitTx tx = do | otherwise = error ("Expected at least 1 output after submitting tx: " <> show txId) forM res $ \st' -> do modify $ impNESL . nesEsL . esLStateL .~ st' - impRootTxInL .= TxIn txId (mkTxIxPartial (fromIntegral rootIndex)) + UTxO utxo <- getUTxO + -- This TxIn is in the utxo, and thus can be the new root, only if the transaction was phase2-valid. + -- Otherwise, no utxo with this id would have been created, and so we need to set the new root + -- to what it was before the submission. + let assumedNewRoot = TxIn txId (mkTxIxPartial (fromIntegral rootIndex)) + let newRoot + | Map.member assumedNewRoot utxo = assumedNewRoot + | Map.member impRootTxIn utxo = impRootTxIn + | otherwise = error "Root not found in UTxO" + impRootTxInL .= newRoot pure txFixed -- | Submit a transaction that is expected to be rejected. The inputs and @@ -1024,7 +1004,6 @@ withImpState = , impGlobals = testGlobals , impLog = mempty , impGen = qcGen - , impCollateralTxIds = fst <$> mkCollateralUTxO @era rootCoin } where rootCoin = Coin 1_000_000_000 diff --git a/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Plutus/Examples.hs b/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Plutus/Examples.hs index f85c0a4a3e2..db78956bb8b 100644 --- a/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Plutus/Examples.hs +++ b/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Plutus/Examples.hs @@ -43,6 +43,41 @@ alwaysSucceeds3 = SPlutusV3 -> [71, 1, 1, 0, 34, 40, 0, 1] ) +{- Preproceesed Plutus Script +alwaysFails'2_0 :: PlutusTx.Builtins.Internal.BuiltinData -> + PlutusTx.Builtins.Internal.BuiltinData -> () +alwaysFails'2_0 _ _ = PlutusTx.Builtins.error GHC.Tuple.Prim.() +-} + +alwaysFails2 :: SLanguage l -> Plutus l +alwaysFails2 = + Plutus + . PlutusBinary + . pack + . ( \case + SPlutusV1 -> [69, 1, 0, 0, 34, 97] + SPlutusV2 -> [69, 1, 0, 0, 34, 97] + SPlutusV3 -> [69, 1, 1, 0, 34, 97] + ) + +{- Preproceesed Plutus Script +alwaysFails'3_0 :: PlutusTx.Builtins.Internal.BuiltinData -> + PlutusTx.Builtins.Internal.BuiltinData -> + PlutusTx.Builtins.Internal.BuiltinData -> () +alwaysFails'3_0 _ _ _ = PlutusTx.Builtins.error GHC.Tuple.Prim.() +-} + +alwaysFails3 :: SLanguage l -> Plutus l +alwaysFails3 = + Plutus + . PlutusBinary + . pack + . ( \case + SPlutusV1 -> [70, 1, 0, 0, 34, 38, 1] + SPlutusV2 -> [70, 1, 0, 0, 34, 38, 1] + SPlutusV3 -> [70, 1, 1, 0, 34, 38, 1] + ) + {- Preproceesed Plutus Script guessTheNumber'2_0 :: PlutusTx.Builtins.Internal.BuiltinData -> PlutusTx.Builtins.Internal.BuiltinData -> () diff --git a/libs/plutus-preprocessor/src/Main.hs b/libs/plutus-preprocessor/src/Main.hs index 9c6d16fd3f3..a32e169f890 100644 --- a/libs/plutus-preprocessor/src/Main.hs +++ b/libs/plutus-preprocessor/src/Main.hs @@ -8,9 +8,9 @@ -- not have any dependency on the plutus-plugin. Instead this package -- 'plutus-preprocessor' has that dependency, but one does not have to compile this -- package to build the system. If the plutus package changes, we will have to regenerate --- the PlutusScripts.hs file. To regenerate PlutusScripts.hs, on a machine that can --- depend upon plutus=plugin, then cd into the plutus-preprocessor directory and type --- 'cabal run plutus-preprocessor' +-- the Examples.hs file. +-- To regenerate Examples.hs, on a machine that can depend upon plutus=plugin, +-- run 'cabal run plutus-preprocessor' module Main where import Cardano.Ledger.Plutus.Language (Language (..)) @@ -75,6 +75,22 @@ displayScripts outh = do , alwaysSucceedsDecl3args , "alwaysSucceeds3" ) + , + ( \case + PlutusV1 -> PV1S.alwaysFails2argsBytes + PlutusV2 -> PV1S.alwaysFails2argsBytes + PlutusV3 -> PV3S.alwaysFails2argsBytes + , alwaysFailsDecl2args + , "alwaysFails2" + ) + , + ( \case + PlutusV1 -> PV1S.alwaysFails3argsBytes + PlutusV2 -> PV1S.alwaysFails3argsBytes + PlutusV3 -> PV3S.alwaysFails3argsBytes + , alwaysFailsDecl3args + , "alwaysFails3" + ) , ( \case PlutusV1 -> PV1S.guess2args diff --git a/libs/plutus-preprocessor/src/PlutusV1Scripts.hs b/libs/plutus-preprocessor/src/PlutusV1Scripts.hs index ca01f1cdb15..9212006d647 100644 --- a/libs/plutus-preprocessor/src/PlutusV1Scripts.hs +++ b/libs/plutus-preprocessor/src/PlutusV1Scripts.hs @@ -19,6 +19,8 @@ import ScriptSource $alwaysSucceedsDecl2args $alwaysSucceedsDecl3args +$alwaysFailsDecl2args +$alwaysFailsDecl3args $guessDecl $guessDecl2args $evendataDecl @@ -44,6 +46,16 @@ alwaysSucceeds3argsBytes = PV1.serialiseCompiledCode $$(P.compile [||alwaysSucceeds'3||]) +alwaysFails2argsBytes :: ShortByteString +alwaysFails2argsBytes = + PV1.serialiseCompiledCode + $$(P.compile [||alwaysFails'2||]) + +alwaysFails3argsBytes :: ShortByteString +alwaysFails3argsBytes = + PV1.serialiseCompiledCode + $$(P.compile [||alwaysFails'3||]) + guessTheNumberBytes :: ShortByteString guessTheNumberBytes = PV1.serialiseCompiledCode diff --git a/libs/plutus-preprocessor/src/PlutusV3Scripts.hs b/libs/plutus-preprocessor/src/PlutusV3Scripts.hs index 738f44018a5..2a9f17ec33d 100644 --- a/libs/plutus-preprocessor/src/PlutusV3Scripts.hs +++ b/libs/plutus-preprocessor/src/PlutusV3Scripts.hs @@ -19,6 +19,8 @@ import ScriptSource $alwaysSucceedsDecl2args $alwaysSucceedsDecl3args +$alwaysFailsDecl2args +$alwaysFailsDecl3args $guessDecl $guessDecl2args $evendataDecl @@ -44,6 +46,16 @@ alwaysSucceeds3argsBytes = PV3.serialiseCompiledCode $$(P.compile [||alwaysSucceeds'3||]) +alwaysFails2argsBytes :: ShortByteString +alwaysFails2argsBytes = + PV3.serialiseCompiledCode + $$(P.compile [||alwaysFails'2||]) + +alwaysFails3argsBytes :: ShortByteString +alwaysFails3argsBytes = + PV3.serialiseCompiledCode + $$(P.compile [||alwaysFails'3||]) + guessTheNumberBytes :: ShortByteString guessTheNumberBytes = PV3.serialiseCompiledCode diff --git a/libs/plutus-preprocessor/src/ScriptSource.hs b/libs/plutus-preprocessor/src/ScriptSource.hs index 09829281249..ed91dba9433 100644 --- a/libs/plutus-preprocessor/src/ScriptSource.hs +++ b/libs/plutus-preprocessor/src/ScriptSource.hs @@ -20,6 +20,20 @@ alwaysSucceedsDecl3args = alwaysSucceeds'3 _ _ _ = () |] +alwaysFailsDecl2args :: Q [Dec] +alwaysFailsDecl2args = + [d| + alwaysFails'2 :: P.BuiltinData -> P.BuiltinData -> () + alwaysFails'2 _ _ = P.error () + |] + +alwaysFailsDecl3args :: Q [Dec] +alwaysFailsDecl3args = + [d| + alwaysFails'3 :: P.BuiltinData -> P.BuiltinData -> P.BuiltinData -> () + alwaysFails'3 _ _ _ = P.error () + |] + guessDecl :: Q [Dec] guessDecl = [d|