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 3566f79e181..2ceefaab8e1 100644 --- a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/ImpTest.hs +++ b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/ImpTest.hs @@ -113,6 +113,7 @@ import Test.Cardano.Ledger.Plutus ( testingCostModels, ) import Test.Cardano.Ledger.Plutus.Examples +import Test.Cardano.Ledger.Plutus.Guardrail (guardrailScript) class ( MaryEraImp era @@ -392,6 +393,7 @@ plutusTestScripts lang = , mkScriptTestEntry (datumIsWellformed lang) $ PlutusArgs (P.I 221) (Just $ P.I 5) , mkScriptTestEntry (inputsOutputsAreNotEmptyNoDatum lang) $ PlutusArgs (P.I 122) Nothing , mkScriptTestEntry (inputsOutputsAreNotEmptyWithDatum lang) $ PlutusArgs (P.I 222) (Just $ P.I 5) + , mkScriptTestEntry guardrailScript $ PlutusArgs (P.I 0) Nothing ] malformedPlutus :: Plutus l diff --git a/eras/conway/impl/CHANGELOG.md b/eras/conway/impl/CHANGELOG.md index 1d13cc1b940..b5ae7a10956 100644 --- a/eras/conway/impl/CHANGELOG.md +++ b/eras/conway/impl/CHANGELOG.md @@ -8,6 +8,8 @@ ### `testlib` +* Add `minFeeUpdateGovAction` +* Add `mkTreasuryWithdrawalsGovAction` and `mkParameterChangeGovAction` * Switch to using `ImpSpec` package * Remove `withImpStateWithProtVer` * Added `delegateSPORewardAddressToDRep_` diff --git a/eras/conway/impl/cardano-ledger-conway.cabal b/eras/conway/impl/cardano-ledger-conway.cabal index 4d7a4061893..62fe0d41706 100644 --- a/eras/conway/impl/cardano-ledger-conway.cabal +++ b/eras/conway/impl/cardano-ledger-conway.cabal @@ -178,8 +178,7 @@ library testlib mtl, plutus-ledger-api, prettyprinter, - small-steps >=1.1, - text + small-steps >=1.1 executable huddle-cddl main-is: Main.hs diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/EnactSpec.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/EnactSpec.hs index 512ed4b277f..34db1a6b2a4 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/EnactSpec.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/EnactSpec.hs @@ -460,13 +460,16 @@ actionPrioritySpec = nesEsL . esLStateL . lsUTxOStateL . utxosGovStateL . committeeGovStateL committee `shouldBe` SNothing - let val1 = Coin 1_000_001 - let val2 = Coin 1_000_002 - let val3 = Coin 1_000_003 - + -- distinct constitutional values for minFee + let genMinFeeVals = + (\x y z -> (Coin x, Coin y, Coin z)) + <$> uniformRM (30, 330) + <*> uniformRM (330, 660) + <*> uniformRM (660, 1000) it "proposals of same priority are enacted in order of submission" $ do modifyPParams $ ppPoolVotingThresholdsL . pvtPPSecurityGroupL .~ 1 %! 1 whenPostBootstrap (modifyPParams $ ppDRepVotingThresholdsL . dvtPPEconomicGroupL .~ def) + (val1, val2, val3) <- genMinFeeVals committeeCs <- registerInitialCommittee (spoC, _, _) <- setupPoolWithStake $ Coin 42_000_000 @@ -498,24 +501,26 @@ actionPrioritySpec = it "only the first action of a transaction gets enacted" $ do modifyPParams $ ppPoolVotingThresholdsL . pvtPPSecurityGroupL .~ 1 %! 1 whenPostBootstrap (modifyPParams $ ppDRepVotingThresholdsL . dvtPPEconomicGroupL .~ def) + (val1, val2, val3) <- genMinFeeVals committeeCs <- registerInitialCommittee (spoC, _, _) <- setupPoolWithStake $ Coin 42_000_000 + policy <- getGovPolicy gaids <- submitGovActions $ NE.fromList [ ParameterChange SNothing (def & ppuMinFeeAL .~ SJust val1) - SNothing + policy , ParameterChange SNothing (def & ppuMinFeeAL .~ SJust val2) - SNothing + policy , ParameterChange SNothing (def & ppuMinFeeAL .~ SJust val3) - SNothing + policy ] traverse_ ( \gaid -> do diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/EpochSpec.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/EpochSpec.hs index 0d50aebe6c5..e5476b4cd62 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/EpochSpec.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/EpochSpec.hs @@ -91,12 +91,10 @@ proposalsSpec = initialValue <- getsNES (nesEsL . curPParamsEpochStateL . ppMinFeeAL) - policy <- - getsNES $ - nesEpochStateL . epochStateGovStateL . constitutionGovStateL . constitutionScriptL + parameterChangeAction <- mkMinFeeUpdateGovAction SNothing govActionId <- mkProposalWithRewardAccount - (ParameterChange SNothing (def & ppuMinFeeAL .~ SJust (Coin 3000)) policy) + parameterChangeAction rewardAccount >>= submitProposal expectPresentGovActionId govActionId @@ -138,9 +136,7 @@ proposalsSpec = let ratifyState = extractDRepPulsingState (govStateFinal ^. cgsDRepPulsingStateL) rsExpired ratifyState `shouldBe` Set.singleton govActionId where - submitParameterChangeTree = submitGovActionTree $ submitGovAction . paramAction - paramAction p = - ParameterChange (GovPurposeId <$> p) (def & ppuMinFeeAL .~ SJust (Coin 10)) SNothing + submitParameterChangeTree = submitGovActionTree $ mkMinFeeUpdateGovAction >=> submitGovAction dRepSpec :: forall era. @@ -148,6 +144,7 @@ dRepSpec :: SpecWith (ImpInit (LedgerSpec era)) dRepSpec = describe "DRep" $ do + let submitParamChangeProposal = mkMinFeeUpdateGovAction SNothing >>= submitGovAction_ it "expiry is updated based on the number of dormant epochs" $ do modifyPParams $ ppGovActionLifetimeL .~ EpochInterval 2 (drep, _, _) <- setupSingleDRep 1_000_000 @@ -156,12 +153,10 @@ dRepSpec = let -- compute the epoch number that is an offset from starting epoch number offDRepActivity = addEpochInterval startEpochNo . EpochInterval - submitParamChangeProposal = - submitParameterChange SNothing $ def & ppuMinFeeAL .~ SJust (Coin 3000) expectNumDormantEpochs 0 -- epoch 0: we submit a proposal - _ <- submitParamChangeProposal + submitParamChangeProposal passNEpochsChecking 2 $ do expectNumDormantEpochs 0 expectDRepExpiry drep $ offDRepActivity 100 @@ -179,7 +174,7 @@ dRepSpec = expectNumDormantEpochs 3 expectDRepExpiry drep $ offDRepActivity 100 - _ <- submitParamChangeProposal + submitParamChangeProposal -- number of dormant epochs is added to the drep expiry and reset to 0 expectNumDormantEpochs 0 expectDRepExpiry drep $ offDRepActivity 103 @@ -202,12 +197,10 @@ dRepSpec = offDRepActivity offset = addEpochInterval startEpochNo $ EpochInterval (drepActivity + offset) - let submitParamChangeProposal = - submitParameterChange SNothing $ def & ppuMinFeeAL .~ SJust (Coin 3000) expectNumDormantEpochs 0 -- epoch 0: we submit a proposal - _ <- submitParamChangeProposal + submitParamChangeProposal passNEpochsChecking 2 $ do expectNumDormantEpochs 0 expectDRepExpiry drep $ offDRepActivity 0 @@ -229,7 +222,7 @@ dRepSpec = expectDRepExpiry drep $ offDRepActivity 0 expectActualDRepExpiry drep $ offDRepActivity 3 - _ <- submitParamChangeProposal + submitParamChangeProposal -- number of dormant epochs is added to the drep, considering they are not actually expired, -- and is reset to 0 expectNumDormantEpochs 0 @@ -463,7 +456,11 @@ depositMovesToTreasuryWhenStakingAddressUnregisters = do govPolicy <- getGovPolicy gaid <- mkProposalWithRewardAccount - (ParameterChange SNothing (emptyPParamsUpdate & ppuGovActionDepositL .~ SJust (Coin 10)) govPolicy) + ( ParameterChange + SNothing + (emptyPParamsUpdate & ppuGovActionDepositL .~ SJust (Coin 1000000)) + govPolicy + ) returnAddr >>= submitProposal expectPresentGovActionId gaid @@ -503,7 +500,7 @@ eventsSpec = describe "Events" $ do propDeposit <- getsNES $ nesEsL . curPParamsEpochStateL . ppGovActionDepositL let proposeParameterChange = do - newVal <- arbitrary + newVal <- CoinPerByte . Coin <$> choose (3000, 6500) proposal <- submitParameterChange SNothing $ def & ppuCoinsPerUTxOByteL .~ SJust newVal pure (proposal, getsNES (nesEsL . curPParamsEpochStateL . ppCoinsPerUTxOByteL) `shouldReturn` newVal) @@ -512,9 +509,10 @@ eventsSpec = describe "Events" $ do rewardAccount@(RewardAccount _ rewardCred) <- registerRewardAccount passEpoch -- prevent proposalC expiry and force it's deletion due to conflit. proposalC <- impAnn "proposalC" $ do - newVal <- arbitrary + newVal <- CoinPerByte . Coin <$> choose (3000, 6500) + paramChange <- mkParameterChangeGovAction SNothing $ (def & ppuCoinsPerUTxOByteL .~ SJust newVal) mkProposalWithRewardAccount - (ParameterChange SNothing (def & ppuCoinsPerUTxOByteL .~ SJust newVal) SNothing) + paramChange rewardAccount >>= submitProposal let 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 2391e222905..4ef10a0137b 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 @@ -57,7 +57,6 @@ spec = do withdrawalsSpec hardForkSpec pparamUpdateSpec - proposalsSpec networkIdSpec bootstrapPhaseSpec @@ -188,7 +187,7 @@ pparamUpdateSpec = let ppUpdate = emptyPParamsUpdate & lenz .~ SJust val - ga = ParameterChange SNothing ppUpdate SNothing + ga <- mkParameterChangeGovAction SNothing ppUpdate mkProposal ga >>= flip submitFailingProposal @@ -234,7 +233,7 @@ pparamUpdateSpec = ppuDRepDepositL zero it "PPU cannot be empty" $ do - let ga = ParameterChange SNothing emptyPParamsUpdate SNothing + ga <- mkParameterChangeGovAction SNothing emptyPParamsUpdate mkProposal ga >>= flip submitFailingProposal @@ -260,11 +259,7 @@ proposalsSpec = do () [ Node () [] ] - let parameterChangeAction = - ParameterChange - (SJust $ GovPurposeId $ mkCorruptGovActionId p1) - (def & ppuMinFeeAL .~ SJust (Coin 3000)) - SNothing + parameterChangeAction <- mkMinFeeUpdateGovAction (SJust $ mkCorruptGovActionId p1) parameterChangeProposal <- mkProposal parameterChangeAction submitFailingProposal parameterChangeProposal @@ -272,7 +267,7 @@ proposalsSpec = do ] it "Subtrees are pruned when proposals expire" $ do modifyPParams $ ppGovActionLifetimeL .~ EpochInterval 4 - p1 <- submitParameterChange SNothing (def & ppuMinFeeAL .~ SJust (Coin 3000)) + p1 <- mkMinFeeUpdateGovAction SNothing >>= submitGovAction passNEpochs 3 a <- submitParameterChangeTree @@ -307,7 +302,7 @@ proposalsSpec = do , Node SNothing [] ] it "Subtrees are pruned when proposals expire over multiple rounds" $ do - let ppupdate = def & ppuMinFeeAL .~ SJust (Coin 3000) + let ppupdate = def & ppuMinFeeAL .~ SJust (Coin 1000) let submitInitialProposal = submitParameterChange SNothing ppupdate let submitChildProposal parent = submitParameterChange (SJust parent) ppupdate modifyPParams $ ppGovActionLifetimeL .~ EpochInterval 4 @@ -716,15 +711,16 @@ proposalsSpec = do ens <- getEnactState returnAddr <- registerRewardAccount withdrawal <- - Map.singleton returnAddr . Coin . getPositive + (: []) . (returnAddr,) . Coin . getPositive <$> (arbitrary :: ImpTestM era (Positive Integer)) + wdrl <- mkTreasuryWithdrawalsGovAction withdrawal [prop0, prop1, prop2, prop3] <- traverse mkProposal ( [ InfoAction , NoConfidence (ens ^. ensPrevCommitteeL) , InfoAction - , TreasuryWithdrawals withdrawal SNothing + , wdrl ] :: [GovAction era] ) @@ -742,11 +738,10 @@ proposalsSpec = do submitProposal_ prop3 checkProps [prop0, prop1, prop2, prop3] where - submitParameterChangeForest = submitGovActionForest $ submitGovAction . paramAction - submitParameterChangeTree = submitGovActionTree $ submitGovAction . paramAction + submitParameterChangeForest = submitGovActionForest $ paramAction >=> submitGovAction + submitParameterChangeTree = submitGovActionTree (paramAction >=> submitGovAction) submitConstitutionForest = submitGovActionForest $ submitConstitution . fmap GovPurposeId - paramAction p = - ParameterChange (GovPurposeId <$> p) (def & ppuMinFeeAL .~ SJust (Coin 10)) SNothing + paramAction p = mkParameterChangeGovAction p (def & ppuMinFeeAL .~ SJust (Coin 500)) votingSpec :: forall era. @@ -1089,7 +1084,7 @@ withdrawalsSpec = , raCredential = rewardCredential } proposal <- - mkProposal $ TreasuryWithdrawals (Map.singleton badRewardAccount $ Coin 100_000_000) SNothing + mkTreasuryWithdrawalsGovAction [(badRewardAccount, Coin 100_000_000)] >>= mkProposal let idMismatch = injectFailure $ TreasuryWithdrawalsNetworkIdMismatch (Set.singleton badRewardAccount) Testnet @@ -1105,19 +1100,17 @@ withdrawalsSpec = } it "Fails for empty withdrawals" $ do - expectZeroTreasuryFailurePostBootstrap $ TreasuryWithdrawals Map.empty SNothing + mkTreasuryWithdrawalsGovAction [] >>= expectZeroTreasuryFailurePostBootstrap rwdAccount1 <- registerRewardAccount - expectZeroTreasuryFailurePostBootstrap $ - TreasuryWithdrawals [(rwdAccount1, zero)] SNothing + mkTreasuryWithdrawalsGovAction [(rwdAccount1, zero)] >>= expectZeroTreasuryFailurePostBootstrap rwdAccount2 <- registerRewardAccount - let withdrawals = Map.fromList [(rwdAccount1, zero), (rwdAccount2, zero)] + let withdrawals = [(rwdAccount1, zero), (rwdAccount2, zero)] - expectZeroTreasuryFailurePostBootstrap $ - TreasuryWithdrawals withdrawals SNothing + mkTreasuryWithdrawalsGovAction withdrawals >>= expectZeroTreasuryFailurePostBootstrap - let wdrls = TreasuryWithdrawals (Map.insert rwdAccount2 (Coin 100_000) withdrawals) SNothing + wdrls <- mkTreasuryWithdrawalsGovAction $ withdrawals ++ [(rwdAccount2, Coin 100_000)] proposal <- mkProposal wdrls submitBootstrapAwareFailingProposal_ proposal $ FailBootstrap [disallowedProposalFailure proposal] @@ -1256,9 +1249,9 @@ bootstrapPhaseSpec :: ) => SpecWith (ImpInit (LedgerSpec era)) bootstrapPhaseSpec = - describe "Proposing and voting during bootstrap phase" $ do + describe "Proposing and voting" $ do it "Parameter change" $ do - gid <- submitParameterChange SNothing (def & ppuMinFeeAL .~ SJust (Coin 3000)) + gid <- mkMinFeeUpdateGovAction SNothing >>= submitGovAction (committee :| _) <- registerInitialCommittee (drep, _, _) <- setupSingleDRep 1_000_000 (spo, _, _) <- setupPoolWithStake $ Coin 42_000_000 @@ -1287,7 +1280,7 @@ bootstrapPhaseSpec = submitYesVote_ (CommitteeVoter committee) gid it "Treasury withdrawal" $ do rewardAccount <- registerRewardAccount - let action = TreasuryWithdrawals [(rewardAccount, Coin 1000)] SNothing + action <- mkTreasuryWithdrawalsGovAction [(rewardAccount, Coin 1000)] proposal <- mkProposalWithRewardAccount action rewardAccount checkProposalFailure proposal it "NoConfidence" $ do diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/LedgerSpec.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/LedgerSpec.hs index 3b7c15e5c7a..67e7209e6bc 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/LedgerSpec.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/LedgerSpec.hs @@ -27,7 +27,6 @@ import qualified Cardano.Ledger.Shelley.HardForks as HF (bootstrapPhase) import Cardano.Ledger.Shelley.LedgerState import Cardano.Ledger.Shelley.Rules (ShelleyLedgersEnv (..), ShelleyLedgersEvent (..)) import Control.State.Transition.Extended -import Data.Default (def) import qualified Data.Sequence as Seq import qualified Data.Set as Set import Lens.Micro ((&), (.~), (^.)) @@ -162,7 +161,7 @@ spec = do (drep, _, _) <- setupSingleDRep 1_000_000 -- expire the drep before delegation - void $ submitParameterChange SNothing $ def & ppuMinFeeAL .~ SJust (Coin 3000) + mkMinFeeUpdateGovAction SNothing >>= submitGovAction_ passNEpochs 4 isDRepExpired drep `shouldReturn` True @@ -191,7 +190,8 @@ spec = do _ <- delegateToDRep cred (Coin 1_000_000) (DRepCredential drep) -- expire the drep after delegation - void $ submitParameterChange SNothing $ def & ppuMinFeeAL .~ SJust (Coin 3000) + mkMinFeeUpdateGovAction SNothing >>= submitGovAction_ + passNEpochs 4 isDRepExpired drep `shouldReturn` True diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/RatifySpec.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/RatifySpec.hs index 39e299747bb..65414762b2a 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/RatifySpec.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/RatifySpec.hs @@ -51,7 +51,7 @@ spec = do it "Many CC Cold Credentials map to the same Hot Credential act as many votes" $ do hotCred NE.:| _ <- registerInitialCommittee (dRep, _, _) <- setupSingleDRep =<< uniformRM (10_000_000, 1_000_000_000) - Positive deposit <- arbitrary + deposit <- uniformRM (1_000_000, 100_000_000_000) gaId <- submitParameterChange SNothing $ def & ppuDRepDepositL .~ SJust (Coin deposit) submitYesVote_ (CommitteeVoter hotCred) gaId whenPostBootstrap $ submitYesVote_ (DRepVoter dRep) gaId @@ -278,11 +278,7 @@ paramChangeAffectsProposalsSpec = -- These tests rely on submitting committee-update proposals and on drep votes, which are disallowed during bootstrap, -- so we can only run them post-bootstrap describe "ParameterChange affects existing proposals" $ do - let largerThreshold :: UnitInterval - largerThreshold = 51 %! 100 - smallerThreshold :: UnitInterval - smallerThreshold = 1 %! 2 - submitTwoExampleProposalsAndVoteOnTheChild :: + let submitTwoExampleProposalsAndVoteOnTheChild :: [(KeyHash 'StakePool (EraCrypto era), Vote)] -> [(Credential 'DRepRole (EraCrypto era), Vote)] -> ImpTestM era (GovActionId (EraCrypto era), GovActionId (EraCrypto era)) @@ -303,41 +299,50 @@ paramChangeAffectsProposalsSpec = passEpoch -- Make the votes count pure (gaiParent, gaiChild) describe "DRep" $ do - let setThreshold threshold = + let setCommitteeUpdateThreshold threshold = modifyPParams $ ppDRepVotingThresholdsL . dvtCommitteeNormalL .~ threshold - enactThreshold threshold drepC hotCommitteeC = do - modifyPParams $ ppDRepVotingThresholdsL . dvtPPGovGroupL .~ 1 %! 10 - drepVotingThresholds <- getsPParams ppDRepVotingThresholdsL - let paramChange = - ParameterChange - SNothing - ( emptyPParamsUpdate - & ppuDRepVotingThresholdsL - .~ SJust (drepVotingThresholds & dvtCommitteeNormalL .~ threshold) - ) - SNothing + getDrepVotingThresholds = getsPParams ppDRepVotingThresholdsL + enactCommitteeUpdateThreshold threshold dreps hotCommitteeC = do + drepVotingThresholds <- getDrepVotingThresholds + paramChange <- + mkParameterChangeGovAction + SNothing + ( emptyPParamsUpdate + & ppuDRepVotingThresholdsL + .~ SJust (drepVotingThresholds & dvtCommitteeNormalL .~ threshold) + ) pcGai <- submitGovAction paramChange - submitYesVote_ (DRepVoter drepC) pcGai + forM_ dreps $ \drep -> submitYesVote_ (DRepVoter drep) pcGai submitYesVote_ (CommitteeVoter hotCommitteeC) pcGai + isDRepAccepted pcGai `shouldReturn` True passNEpochs 2 + (^. dvtCommitteeNormalL) <$> getDrepVotingThresholds `shouldReturn` threshold + it "Increasing the threshold prevents a hitherto-ratifiable proposal from being ratified" $ whenPostBootstrap $ do (drepC, hotCommitteeC, _) <- electBasicCommittee - setThreshold smallerThreshold + setCommitteeUpdateThreshold $ 1 %! 2 -- small threshold (drep, _, _) <- setupSingleDRep 1_000_000 (_gaiParent, gaiChild) <- submitTwoExampleProposalsAndVoteOnTheChild [] [(drep, VoteYes)] isDRepAccepted gaiChild `shouldReturn` True - enactThreshold largerThreshold drepC hotCommitteeC + enactCommitteeUpdateThreshold + (65 %! 100) + ([drepC, drep] :: [Credential 'DRepRole (EraCrypto era)]) + hotCommitteeC isDRepAccepted gaiChild `shouldReturn` False it "Decreasing the threshold ratifies a hitherto-unratifiable proposal" $ whenPostBootstrap $ do -- This sets up a stake pool with 1_000_000 Coin (drepC, hotCommitteeC, _) <- electBasicCommittee - setThreshold largerThreshold - (drep, _, _) <- setupSingleDRep 1_000_000 + setCommitteeUpdateThreshold $ 1 %! 1 -- too large threshold + (drep, _, _) <- setupSingleDRep 3_000_000 (spoC, _, _) <- setupPoolWithStake $ Coin 3_000_000 (gaiParent, gaiChild) <- submitTwoExampleProposalsAndVoteOnTheChild [(spoC, VoteYes)] [(drep, VoteYes)] + logAcceptedRatio gaiChild isDRepAccepted gaiChild `shouldReturn` False - enactThreshold smallerThreshold drepC hotCommitteeC + enactCommitteeUpdateThreshold + (65 %! 100) + ([drepC, drep] :: [Credential 'DRepRole (EraCrypto era)]) + hotCommitteeC isDRepAccepted gaiChild `shouldReturn` True -- Not vote on the parent too to make sure both get enacted submitYesVote_ (DRepVoter drep) gaiParent @@ -349,27 +354,28 @@ paramChangeAffectsProposalsSpec = passEpoch -- UpdateCommittee is a delaying action getLastEnactedCommittee `shouldReturn` SJust (GovPurposeId gaiChild) describe "SPO" $ do - let setThreshold :: UnitInterval -> ImpTestM era () - setThreshold threshold = + let setCommitteeUpdateThreshold :: UnitInterval -> ImpTestM era () + setCommitteeUpdateThreshold threshold = modifyPParams $ ppPoolVotingThresholdsL . pvtCommitteeNormalL .~ threshold - enactThreshold threshold drepC hotCommitteeC = do + enactCommitteeUpdateThreshold threshold drepC hotCommitteeC = do poolVotingThresholds <- getsPParams ppPoolVotingThresholdsL - let paramChange = - ParameterChange - SNothing - ( emptyPParamsUpdate - & ppuPoolVotingThresholdsL - .~ SJust (poolVotingThresholds & pvtCommitteeNormalL .~ threshold) - ) - SNothing + paramChange <- + mkParameterChangeGovAction + SNothing + ( emptyPParamsUpdate + & ppuPoolVotingThresholdsL + .~ SJust (poolVotingThresholds & pvtCommitteeNormalL .~ threshold) + ) pcGai <- submitGovAction paramChange submitYesVote_ (DRepVoter drepC) pcGai submitYesVote_ (CommitteeVoter hotCommitteeC) pcGai passNEpochs 2 + (^. pvtCommitteeNormalL) <$> (getsPParams ppPoolVotingThresholdsL) `shouldReturn` threshold + it "Increasing the threshold prevents a hitherto-ratifiable proposal from being ratified" $ whenPostBootstrap $ do -- This sets up a stake pool with 1_000_000 Coin (drepC, hotCommitteeC, _) <- electBasicCommittee - setThreshold smallerThreshold + setCommitteeUpdateThreshold $ 1 %! 2 (poolKH1, _paymentC1, _stakingC1) <- setupPoolWithStake $ Coin 2_000_000 (poolKH2, _paymentC2, _stakingC2) <- setupPoolWithStake $ Coin 1_000_000 passEpoch -- Make the new pool distribution count @@ -380,13 +386,13 @@ paramChangeAffectsProposalsSpec = [(poolKH1, VoteYes), (poolKH2, VoteNo)] [(drepC, VoteYes)] isSpoAccepted gaiChild `shouldReturn` True - enactThreshold largerThreshold drepC hotCommitteeC + enactCommitteeUpdateThreshold (65 %! 100) drepC hotCommitteeC isSpoAccepted gaiChild `shouldReturn` False it "Decreasing the threshold ratifies a hitherto-unratifiable proposal" $ whenPostBootstrap $ do -- This sets up a stake pool with 1_000_000 Coin (drepC, hotCommitteeC, _) <- electBasicCommittee - setThreshold largerThreshold - (poolKH1, _paymentC1, _stakingC1) <- setupPoolWithStake $ Coin 2_000_000 + setCommitteeUpdateThreshold $ 1 %! 1 -- too large threshold + (poolKH1, _paymentC1, _stakingC1) <- setupPoolWithStake $ Coin 4_000_000 (poolKH2, _paymentC2, _stakingC2) <- setupPoolWithStake $ Coin 1_000_000 -- bootstrap: 1 % 2 stake yes (2_000_000); 1 % 2 stake abstain; yes / stake - abstain == 1 % 2 -- post-bootstrap: 1 % 2 stake yes (2_000_000); 1 % 4 stake didn't vote; 1 % 4 stake no @@ -395,7 +401,7 @@ paramChangeAffectsProposalsSpec = [(poolKH1, VoteYes), (poolKH2, VoteNo)] [(drepC, VoteYes)] isSpoAccepted gaiChild `shouldReturn` False - enactThreshold smallerThreshold drepC hotCommitteeC + enactCommitteeUpdateThreshold (65 %! 100) drepC hotCommitteeC -- smaller threshold isSpoAccepted gaiChild `shouldReturn` True -- Not vote on the parent too to make sure both get enacted submitYesVote_ (DRepVoter drepC) gaiParent @@ -415,20 +421,19 @@ paramChangeAffectsProposalsSpec = drepVotingThresholds <- getsPParams ppDRepVotingThresholdsL modifyPParams $ ppDRepVotingThresholdsL - .~ (drepVotingThresholds & dvtPPGovGroupL .~ smallerThreshold) + .~ (drepVotingThresholds & dvtPPGovGroupL .~ 1 %! 2) -- Submit a parent-child sequence of ParameterChange proposals and vote on -- both equally, so that both may be ratified. But, the parent increases -- the threshold, and it should prevent the child from being ratified. let paramChange parent threshold = - ParameterChange + mkParameterChangeGovAction parent ( emptyPParamsUpdate & ppuDRepVotingThresholdsL .~ SJust (drepVotingThresholds & dvtPPGovGroupL .~ threshold) ) - SNothing - parentGai <- submitGovAction $ paramChange SNothing largerThreshold - childGai <- submitGovAction $ paramChange (SJust $ GovPurposeId parentGai) smallerThreshold + parentGai <- paramChange SNothing ((90 %! 100)) >>= submitGovAction + childGai <- paramChange (SJust parentGai) (75 %! 100) >>= submitGovAction submitYesVote_ (DRepVoter drepC) parentGai submitYesVoteCCs_ hotCommitteeCs parentGai submitYesVote_ (DRepVoter drepC) childGai @@ -561,13 +566,14 @@ votingSpec = .~ SJust PoolVotingThresholds { pvtPPSecurityGroup = 1 %! 2 - , pvtMotionNoConfidence = 1 %! 2 - , pvtHardForkInitiation = 1 %! 2 - , pvtCommitteeNormal = 1 %! 2 - , pvtCommitteeNoConfidence = 1 %! 2 + , pvtMotionNoConfidence = 51 %! 100 + , pvtHardForkInitiation = 51 %! 100 + , pvtCommitteeNormal = 65 %! 100 + , pvtCommitteeNoConfidence = 65 %! 100 } - & ppuGovActionLifetimeL .~ SJust (EpochInterval 100) - gaidThreshold <- mkProposal (ParameterChange SNothing ppUpdate SNothing) >>= submitProposal + & ppuGovActionLifetimeL .~ SJust (EpochInterval 15) + ppUpdateGa <- mkParameterChangeGovAction SNothing ppUpdate + gaidThreshold <- mkProposal ppUpdateGa >>= submitProposal submitYesVote_ (DRepVoter drep) gaidThreshold submitYesVoteCCs_ ccCreds gaidThreshold logAcceptedRatio gaidThreshold @@ -575,16 +581,15 @@ votingSpec = passEpoch logAcceptedRatio gaidThreshold passEpoch - let newMinFeeA = Coin 12_345 + let newMinFeeA = Coin 1000 gaidMinFee <- do pp <- getsNES $ nesEsL . curPParamsEpochStateL impAnn "Security group threshold should be 1/2" $ (pp ^. ppPoolVotingThresholdsL . pvtPPSecurityGroupL) `shouldBe` (1 %! 2) - let ga = - ParameterChange - (SJust (GovPurposeId gaidThreshold)) - (emptyPParamsUpdate & ppuMinFeeAL .~ SJust newMinFeeA) - SNothing + ga <- + mkParameterChangeGovAction + (SJust gaidThreshold) + (emptyPParamsUpdate & ppuMinFeeAL .~ SJust newMinFeeA) gaidMinFee <- mkProposal ga >>= submitProposal submitYesVote_ (DRepVoter drep) gaidMinFee submitYesVoteCCs_ ccCreds gaidMinFee @@ -622,9 +627,9 @@ votingSpec = isDRepAccepted addCCGaid `shouldReturn` False getLastEnactedCommittee `shouldReturn` SNothing -- Bump up the UTxO delegated - -- to barely make the threshold (51 %! 100) + -- to barely make the threshold (65 %! 100) stakingKP1 <- lookupKeyPair stakingKH1 - _ <- sendCoinTo (mkAddr (paymentKP1, stakingKP1)) (inject $ Coin 200_000_000) + _ <- sendCoinTo (mkAddr (paymentKP1, stakingKP1)) (inject $ Coin 858_000_000) passNEpochs 2 -- The same vote should now successfully ratify the proposal getLastEnactedCommittee `shouldReturn` SJust (GovPurposeId addCCGaid) @@ -645,11 +650,11 @@ votingSpec = isDRepAccepted addCCGaid `shouldReturn` False getLastEnactedCommittee `shouldReturn` SNothing -- Add to the rewards of the delegator to this DRep - -- to barely make the threshold (51 %! 100) + -- to barely make the threshold (61 %! 100) modifyNES $ nesEsL . epochStateUMapL %~ UM.adjust - (\(UM.RDPair r d) -> UM.RDPair (r <> UM.CompactCoin 200_000_000) d) + (\(UM.RDPair r d) -> UM.RDPair (r <> UM.CompactCoin 858_000_000) d) staking1 . UM.RewDepUView passNEpochs 2 @@ -658,7 +663,7 @@ votingSpec = it "Rewards contribute to active voting stake even in the absence of StakeDistr" $ whenPostBootstrap $ do let govActionLifetime = 5 govActionDeposit = Coin 1_000_000 - poolDeposit = Coin 200_000 + poolDeposit = Coin 858_000 -- Only modify the applicable thresholds modifyPParams $ \pp -> pp @@ -690,7 +695,7 @@ votingSpec = isDRepAccepted addCCGaid `shouldReturn` False getLastEnactedCommittee `shouldReturn` SNothing -- Increase the rewards of the delegator to this DRep - -- to barely make the threshold (51 %! 100) + -- to barely make the threshold (65 %! 100) registerAndRetirePoolToMakeReward $ KeyHashObj stakingKH1 lookupReward (KeyHashObj stakingKH1) `shouldReturn` poolDeposit <> govActionDeposit isDRepAccepted addCCGaid `shouldReturn` True @@ -700,7 +705,7 @@ votingSpec = describe "Proposal deposits contribute to active voting stake" $ do it "Directly" $ whenPostBootstrap $ do -- Only modify the applicable thresholds - modifyPParams $ ppGovActionDepositL .~ Coin 600_000 + modifyPParams $ ppGovActionDepositL .~ Coin 1_000_000 -- Setup DRep delegation without stake #1 (drepKH1, stakingKH1) <- setupDRepWithoutStake -- Setup DRep delegation #2 @@ -793,7 +798,7 @@ votingSpec = (drep1, _, committeeGovId) <- electBasicCommittee (_, drep2Staking, _) <- setupSingleDRep 1_000_000 - paramChangeGovId <- submitParameterChange SNothing $ def & ppuMinFeeAL .~ SJust (Coin 3000) + paramChangeGovId <- submitParameterChange SNothing $ def & ppuMinFeeAL .~ SJust (Coin 1000) submitYesVote_ (DRepVoter drep1) paramChangeGovId passEpoch 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 8713977f367..9c5c479cb92 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 @@ -229,8 +229,8 @@ conwayFeaturesPlutusV1V2FailureSpec = do currentTreasuryValueTxBodyL $ inject (CurrentTreasuryFieldNotSupported @era donation) describe "VotingProcedures" $ do - let action = ParameterChange SNothing (def & ppuMinFeeAL .~ SJust (Coin 10)) SNothing it "V1" $ do + action <- mkMinFeeUpdateGovAction SNothing (ccCred :| _) <- registerInitialCommittee proposal <- submitGovAction action let badField = @@ -246,6 +246,7 @@ conwayFeaturesPlutusV1V2FailureSpec = do $ inject $ VotingProceduresFieldNotSupported badField it "V2" $ do + action <- mkMinFeeUpdateGovAction SNothing (ccCred :| _) <- registerInitialCommittee proposal <- submitGovAction action let badField = 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 4eba8f4d080..05ce3193278 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/ImpTest.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/ImpTest.hs @@ -36,6 +36,7 @@ module Test.Cardano.Ledger.Conway.ImpTest ( mkConstitutionProposal, mkProposal, mkProposalWithRewardAccount, + mkTreasuryWithdrawalsGovAction, submitTreasuryWithdrawals, submitVote, submitVote_, @@ -83,7 +84,6 @@ module Test.Cardano.Ledger.Conway.ImpTest ( getProposalsForest, logProposalsForest, logProposalsForestDiff, - constitutionShouldBe, getCCExpiry, ccShouldBeExpired, ccShouldNotBeExpired, @@ -92,6 +92,8 @@ module Test.Cardano.Ledger.Conway.ImpTest ( getLastEnactedCommittee, getLastEnactedConstitution, submitParameterChange, + mkMinFeeUpdateGovAction, + mkParameterChangeGovAction, mkUpdateCommitteeProposal, submitUpdateCommittee, expectCommitteeMemberPresence, @@ -187,7 +189,7 @@ import Cardano.Ledger.Credential (Credential (..), StakeReference (..)) import Cardano.Ledger.Crypto (Crypto (..)) import Cardano.Ledger.DRep import Cardano.Ledger.Keys (KeyHash, KeyRole (..)) -import Cardano.Ledger.Plutus.Language (Language (..), SLanguage (..)) +import Cardano.Ledger.Plutus.Language (Language (..), SLanguage (..), hashPlutusScript) import Cardano.Ledger.PoolParams (ppRewardAccount) import qualified Cardano.Ledger.Shelley.HardForks as HardForks (bootstrapPhase) import Cardano.Ledger.Shelley.LedgerState ( @@ -233,7 +235,6 @@ import Data.Maybe (fromJust, fromMaybe, isJust) import Data.Sequence.Strict (StrictSeq (..)) import qualified Data.Sequence.Strict as SSeq import qualified Data.Set as Set -import qualified Data.Text as T import Data.Tree import qualified GHC.Exts as GHC (fromList) import Lens.Micro @@ -245,6 +246,7 @@ import Test.Cardano.Ledger.Core.KeyPair (KeyPair (..), mkCred) import Test.Cardano.Ledger.Core.Rational (IsRatio (..)) import Test.Cardano.Ledger.Imp.Common import Test.Cardano.Ledger.Plutus (testingCostModel) +import Test.Cardano.Ledger.Plutus.Guardrail (guardrailScript) -- | Modify the PParams in the current state with the given function conwayModifyPParams :: @@ -283,6 +285,7 @@ instance { anchorUrl = errorFail $ textToUrl 128 "https://cardano-constitution.crypto" , anchorDataHash = hashAnchorData (AnchorData "Cardano Constitution Content") } + guardrailScriptHash = hashPlutusScript guardrailScript pure ConwayGenesis { cgUpgradePParams = @@ -290,22 +293,22 @@ instance { ucppPoolVotingThresholds = PoolVotingThresholds { pvtMotionNoConfidence = 51 %! 100 - , pvtCommitteeNormal = 51 %! 100 - , pvtCommitteeNoConfidence = 51 %! 100 + , pvtCommitteeNormal = 65 %! 100 + , pvtCommitteeNoConfidence = 65 %! 100 , pvtHardForkInitiation = 51 %! 100 , pvtPPSecurityGroup = 51 %! 100 } , ucppDRepVotingThresholds = DRepVotingThresholds { dvtMotionNoConfidence = 51 %! 100 - , dvtCommitteeNormal = 51 %! 100 - , dvtCommitteeNoConfidence = 51 %! 100 - , dvtUpdateToConstitution = 51 %! 100 + , dvtCommitteeNormal = 65 %! 100 + , dvtCommitteeNoConfidence = 65 %! 100 + , dvtUpdateToConstitution = 65 %! 100 , dvtHardForkInitiation = 51 %! 100 , dvtPPNetworkGroup = 51 %! 100 , dvtPPEconomicGroup = 51 %! 100 , dvtPPTechnicalGroup = 51 %! 100 - , dvtPPGovGroup = 51 %! 100 + , dvtPPGovGroup = 75 %! 100 , dvtTreasuryWithdrawal = 51 %! 100 } , ucppCommitteeMinSize = 1 @@ -318,7 +321,7 @@ instance , -- TODO: Replace with correct cost model. ucppPlutusV3CostModel = testingCostModel PlutusV3 } - , cgConstitution = Constitution constitutionAnchor SNothing + , cgConstitution = Constitution constitutionAnchor (SJust guardrailScriptHash) , cgCommittee = committee , cgDelegs = mempty , cgInitialDReps = mempty @@ -851,6 +854,13 @@ submitGovActions gas = do let txId = txIdTx tx pure $ NE.zipWith (\idx _ -> GovActionId txId (GovActionIx idx)) (0 NE.:| [1 ..]) gas +mkTreasuryWithdrawalsGovAction :: + ConwayEraGov era => + [(RewardAccount (EraCrypto era), Coin)] -> + ImpTestM era (GovAction era) +mkTreasuryWithdrawalsGovAction wdrls = + TreasuryWithdrawals (Map.fromList wdrls) <$> getGovPolicy + submitTreasuryWithdrawals :: ( ShelleyEraImp era , ConwayEraTxBody era @@ -858,9 +868,8 @@ submitTreasuryWithdrawals :: ) => [(RewardAccount (EraCrypto era), Coin)] -> ImpTestM era (GovActionId (EraCrypto era)) -submitTreasuryWithdrawals wdrls = do - policy <- getGovPolicy - submitGovAction $ TreasuryWithdrawals (Map.fromList wdrls) policy +submitTreasuryWithdrawals wdrls = + mkTreasuryWithdrawalsGovAction wdrls >>= submitGovAction enactTreasuryWithdrawals :: ConwayEraImp era => @@ -880,9 +889,23 @@ submitParameterChange :: StrictMaybe (GovActionId (EraCrypto era)) -> PParamsUpdate era -> ImpTestM era (GovActionId (EraCrypto era)) -submitParameterChange parent ppu = do - policy <- getGovPolicy - submitGovAction $ ParameterChange (GovPurposeId <$> parent) ppu policy +submitParameterChange parent ppu = + mkParameterChangeGovAction parent ppu >>= submitGovAction + +mkParameterChangeGovAction :: + ConwayEraImp era => + StrictMaybe (GovActionId (EraCrypto era)) -> + PParamsUpdate era -> + ImpTestM era (GovAction era) +mkParameterChangeGovAction parent ppu = + ParameterChange (GovPurposeId <$> parent) ppu <$> getGovPolicy + +mkMinFeeUpdateGovAction :: + ConwayEraImp era => + StrictMaybe (GovActionId (EraCrypto era)) -> ImpTestM era (GovAction era) +mkMinFeeUpdateGovAction p = do + minFeeValue <- uniformRM (30, 1000) + mkParameterChangeGovAction p (def & ppuMinFeeAL .~ SJust (Coin minFeeValue)) getGovPolicy :: ConwayEraGov era => ImpTestM era (StrictMaybe (ScriptHash (EraCrypto era))) getGovPolicy = @@ -1492,14 +1515,6 @@ enactConstitution prevGovId constitution dRep committeeMembers = impAnn "Enactin 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 () -constitutionShouldBe cUrl = do - Constitution {constitutionAnchor = Anchor {anchorUrl}} <- - getsNES $ newEpochStateGovStateL . constitutionGovStateL - anchorUrl `shouldBe` errorFail (textToUrl 128 $ T.pack cUrl) - expectNumDormantEpochs :: HasCallStack => EpochNo -> ImpTestM era () expectNumDormantEpochs expected = do nd <- diff --git a/libs/cardano-ledger-api/test/Test/Cardano/Ledger/Api/State/Imp/QuerySpec.hs b/libs/cardano-ledger-api/test/Test/Cardano/Ledger/Api/State/Imp/QuerySpec.hs index 80fcac1f655..284dfd8e91a 100644 --- a/libs/cardano-ledger-api/test/Test/Cardano/Ledger/Api/State/Imp/QuerySpec.hs +++ b/libs/cardano-ledger-api/test/Test/Cardano/Ledger/Api/State/Imp/QuerySpec.hs @@ -30,7 +30,6 @@ import Cardano.Ledger.DRep import Cardano.Ledger.Keys (KeyRole (..)) import qualified Cardano.Ledger.Shelley.HardForks as HF import Cardano.Ledger.Shelley.LedgerState -import Data.Default (def) import qualified Data.Map.Strict as Map import qualified Data.Set as Set import Lens.Micro @@ -91,7 +90,7 @@ spec = do expectedExpiry >>= expectActualDRepExpiry drep nes <- getsNES id - void $ submitParameterChange SNothing $ def & ppuMinFeeAL .~ SJust (Coin 3000) + mkMinFeeUpdateGovAction SNothing >>= submitGovAction_ expectedExpiry >>= expectDRepExpiry drep drepState <- drepStateFromQuery drep nes @@ -101,8 +100,6 @@ spec = do curEpochNo <- getsNES nesELL let drepActivity = 3 modifyPParams $ ppDRepActivityL .~ EpochInterval drepActivity - let submitParamChangeProposal = - submitParameterChange SNothing $ def & ppuMinFeeAL .~ SJust (Coin 3000) (drep, _, _) <- setupSingleDRep 1_000_000 nes <- getsNES id drepState <- drepStateFromQuery drep nes @@ -113,7 +110,7 @@ spec = do isDRepExpired drep `shouldReturn` False expectActualDRepExpiry drep actualExpiry expectDRepExpiry drep $ addEpochInterval curEpochNo $ EpochInterval drepActivity - void submitParamChangeProposal + mkMinFeeUpdateGovAction SNothing >>= submitGovAction_ expectDRepExpiry drep actualExpiry nes1 <- getsNES id drepState1 <- drepStateFromQuery drep nes1 @@ -126,8 +123,6 @@ spec = do curEpochNo <- getsNES nesELL let drepActivity = 3 modifyPParams $ ppDRepActivityL .~ EpochInterval drepActivity - let submitParamChangeProposal = - submitParameterChange SNothing $ def & ppuMinFeeAL .~ SJust (Coin 3000) (drep, _, _) <- setupSingleDRep 1_000_000 nes <- getsNES id drepState <- drepStateFromQuery drep nes @@ -156,7 +151,7 @@ spec = do expectDRepExpiry drep $ addEpochInterval curEpochNo $ EpochInterval drepActivity passEpoch expectNumDormantEpochs $ EpochNo (fromIntegral n + 1) - void submitParamChangeProposal + mkMinFeeUpdateGovAction SNothing >>= submitGovAction_ expectNumDormantEpochs $ EpochNo 0 nes2 <- getsNES id drepState2 <- drepStateFromQuery drep nes2 diff --git a/libs/cardano-ledger-core/CHANGELOG.md b/libs/cardano-ledger-core/CHANGELOG.md index 03edd4eee05..d039415374a 100644 --- a/libs/cardano-ledger-core/CHANGELOG.md +++ b/libs/cardano-ledger-core/CHANGELOG.md @@ -32,6 +32,8 @@ ### `testlib` +* Add `decodeHexPlutus` to `Plutus` module +* Add `Guardrail` module * Switch to using `ImpSpec` package * Remove `HasSubState`, `subStateM`, `setSubStateM`, `StateGen` and `StateGenM` as no longer useful. * Re-export `withImpInit` and `modifyImpInit` diff --git a/libs/cardano-ledger-core/cardano-ledger-core.cabal b/libs/cardano-ledger-core/cardano-ledger-core.cabal index 09ec9433a91..4d5ccb5bbf9 100644 --- a/libs/cardano-ledger-core/cardano-ledger-core.cabal +++ b/libs/cardano-ledger-core/cardano-ledger-core.cabal @@ -151,6 +151,7 @@ library testlib Test.Cardano.Ledger.Imp.Common Test.Cardano.Ledger.Plutus Test.Cardano.Ledger.Plutus.Examples + Test.Cardano.Ledger.Plutus.Guardrail Test.Cardano.Ledger.TreeDiff Test.Cardano.Ledger.Plutus.ToPlutusData Test.Cardano.Ledger.Plutus.ScriptTestContext diff --git a/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Plutus.hs b/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Plutus.hs index 93df96a2959..b31ec114acc 100644 --- a/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Plutus.hs +++ b/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Plutus.hs @@ -1,5 +1,6 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeApplications #-} module Test.Cardano.Ledger.Plutus ( PlutusArgs (..), @@ -8,6 +9,7 @@ module Test.Cardano.Ledger.Plutus ( -- * Plutus alwaysSucceedsPlutus, alwaysFailsPlutus, + decodeHexPlutus, -- * CostModel mkCostModelConst, @@ -26,6 +28,7 @@ module Test.Cardano.Ledger.Plutus ( zeroTestingCostModels, ) where +import Cardano.Ledger.Binary.Plain (decodeFullFromHexText) import Cardano.Ledger.Plutus.CostModels ( CostModel, CostModels, @@ -41,6 +44,7 @@ import Cardano.Ledger.Plutus.Language ( ) import Data.Int (Int64) import qualified Data.Map.Strict as Map +import qualified Data.Text as Text (Text) import GHC.Stack import Numeric.Natural (Natural) import qualified PlutusLedgerApi.Test.Examples as P ( @@ -127,3 +131,7 @@ alwaysSucceedsPlutus n = Plutus (PlutusBinary (P.alwaysSucceedingNAryFunction n) alwaysFailsPlutus :: Natural -> Plutus l alwaysFailsPlutus n = Plutus (PlutusBinary (P.alwaysFailingNAryFunction n)) + +decodeHexPlutus :: HasCallStack => Text.Text -> Plutus l +decodeHexPlutus = + either (error . show) (Plutus . PlutusBinary) . decodeFullFromHexText diff --git a/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Plutus/Guardrail.hs b/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Plutus/Guardrail.hs new file mode 100644 index 00000000000..fb431015ff5 --- /dev/null +++ b/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Plutus/Guardrail.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} + +module Test.Cardano.Ledger.Plutus.Guardrail (guardrailScript) +where + +import Cardano.Ledger.Plutus.Language ( + Language (..), + Plutus (..), + ) +import Test.Cardano.Ledger.Plutus (decodeHexPlutus) + +guardrailScript :: Plutus 'PlutusV3 +guardrailScript = + decodeHexPlutus + "5908545908510101003232323232323232323232323232323232323232323232323232323232323232323232323232323232259323255333573466e1d20000011180098111bab357426ae88d55cf00104554ccd5cd19b87480100044600422c6aae74004dd51aba1357446ae88d55cf1baa3255333573466e1d200a35573a002226ae84d5d11aab9e00111637546ae84d5d11aba235573c6ea800642b26006003149a2c8a4c301f801c0052000c00e0070018016006901e4070c00e003000c00d20d00fc000c0003003800a4005801c00e003002c00d20c09a0c80e1801c006001801a4101b5881380018000600700148013003801c006005801a410100078001801c006001801a4101001f8001800060070014801b0038018096007001800600690404002600060001801c0052008c00e006025801c006001801a41209d8001800060070014802b003801c006005801a410112f501c3003800c00300348202b7881300030000c00e00290066007003800c00b003482032ad7b806038403060070014803b00380180960003003800a4021801c00e003002c00d20f40380e1801c006001801a41403f800100a0c00e0029009600f0030078040c00e002900a600f003800c00b003301a483403e01a600700180060066034904801e00060001801c0052016c01e00600f801c006001801980c2402900e30000c00e002901060070030128060c00e00290116007003800c00b003483c0ba03860070018006006906432e00040283003800a40498003003800a404d802c00e00f003800c00b003301a480cb0003003800c003003301a4802b00030001801c01e0070018016006603490605c0160006007001800600660349048276000600030000c00e0029014600b003801c00c04b003800c00300348203a2489b00030001801c00e006025801c006001801a4101b11dc2df80018000c0003003800a4055802c00e007003012c00e003000c00d2080b8b872c000c0006007003801809600700180060069040607e4155016000600030000c00e00290166007003012c00e003000c00d2080c001c000c0003003800a405d801c00e003002c00d20c80180e1801c006001801a412007800100a0c00e00290186007003013c0006007001480cb005801801e006003801800e00600500403003800a4069802c00c00f003001c00c007003803c00e003002c00c05300333023480692028c0004014c00c00b003003c00c00f003003c00e00f003800c00b00301480590052008003003800a406d801c00e003002c00d2000c00d2006c00060070018006006900a600060001801c0052038c00e007001801600690006006901260003003800c003003483281300020141801c005203ac00e006027801c006001801a403d800180006007001480f3003801804e00700180060069040404af3c4e302600060001801c005203ec00e006013801c006001801a4101416f0fd20b80018000600700148103003801c006005801a403501c3003800c0030034812b00030000c00e0029021600f003800c00a01ac00e003000c00ccc08d20d00f4800b00030000c0000000000803c00c016008401e006009801c006001801807e0060298000c000401e006007801c0060018018074020c000400e00f003800c00b003010c000802180020070018006006019801805e0003000400600580180760060138000800c00b00330134805200c400e00300080330004006005801a4001801a410112f58000801c00600901260008019806a40118002007001800600690404a75ee01e00060008018046000801801e000300c4832004c025201430094800a0030028052003002c00d2002c000300648010c0092002300748028c0312000300b48018c0292012300948008c0212066801a40018000c0192008300a2233335573e00250002801994004d55ce800cd55cf0008d5d08014c00cd5d10011263009222532900389800a4d2219002912c80344c01526910c80148964cc04cdd68010034564cc03801400626601800e0071801226601800e01518010096400a3000910c008600444002600244004a664600200244246466004460044460040064600444600200646a660080080066a00600224446600644b20051800484ccc02600244666ae68cdc3801000c00200500a91199ab9a33710004003000801488ccd5cd19b89002001800400a44666ae68cdc4801000c00a00122333573466e20008006005000912a999ab9a3371200400222002220052255333573466e2400800444008440040026eb400a42660080026eb000a4264666015001229002914801c8954ccd5cd19b8700400211333573466e1c00c006001002118011229002914801c88cc044cdc100200099b82002003245200522900391199ab9a3371066e08010004cdc1001001c002004403245200522900391199ab9a3371266e08010004cdc1001001c00a00048a400a45200722333573466e20cdc100200099b820020038014000912c99807001000c40062004912c99807001000c400a2002001199919ab9a357466ae880048cc028dd69aba1003375a6ae84008d5d1000934000dd60010a40064666ae68d5d1800c0020052225933006003357420031330050023574400318010600a444aa666ae68cdc3a400000222c22aa666ae68cdc4000a4000226600666e05200000233702900000088994004cdc2001800ccdc20010008cc010008004c01088954ccd5cd19b87480000044400844cc00c004cdc300100091119803112c800c60012219002911919806912c800c4c02401a442b26600a004019130040018c008002590028c804c8888888800d1900991111111002a244b267201722222222008001000c600518000001112a999ab9a3370e004002230001155333573466e240080044600823002229002914801c88ccd5cd19b893370400800266e0800800e00100208c8c0040048c0088cc008008005"