Merge branch 'master' into PR-constrained-tree

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)

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

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,25 +1473,14 @@ submitConstitution ::
   StrictMaybe (GovPurposeId 'ConstitutionPurpose era) ->
   ImpTestM era (GovActionId (EraCrypto era), Constitution era)
 submitConstitution prevGovId = do
-  constitution <- newConstitution
+  constitution <- arbitrary
   let constitutionAction =
         NewConstitution
           prevGovId
           constitution
   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 =>

eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/UtxosSpec.hs

@@ -2,16 +2,22 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE NumericUnderscores #-}
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
 
 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