Removed GovRelation from GovEnv

Constrained hotfix Limited tree size Fixed a bug in prevGovActionId translation Fixed TestRep of Proposals Fixed endianness in Agda.TxId toExpr implementation Fixed up the mismatch of prevGovActionIds in EnactState and Proposals Added more debug logging Added generation timeout tests Added addtional constraints to Proposals
IntersectMBO · Apr 25, 2024 · 3a9fd64 · 3a9fd64
1 parent 2f0ad36
commit 3a9fd64
Show file tree

Hide file tree

Showing 21 changed files with 660 additions and 152 deletions.
diff --git a/cabal.project b/cabal.project
@@ -13,8 +13,8 @@ repository cardano-haskell-packages
 source-repository-package
   type: git
   location: https://github.com/input-output-hk/cardano-ledger-executable-spec.git
-  tag: 324fafa887b7b6b38e15d2b505c4eec5a3247176
-  --sha256: sha256-zpQToGA04NQ3TfkeWBJXIzisvoGLfYdWNbVQ/2BfeEI=
+  tag: 1ffb1d13b8892c0943780cd7bd9e2724b5c20cab
+  --sha256: sha256-iiC0AwhPce6XnaGYHyQBeMSIttvn2c+Legu0tUgYOEM=
 
 index-state:
   -- Bump this if you need newer packages from Hackage

diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Gov.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Gov.hs
@@ -71,10 +71,12 @@ import Cardano.Ledger.Conway.Governance (
   isCommitteeVotingAllowed,
   isDRepVotingAllowed,
   isStakePoolVotingAllowed,
+  pRootsL,
   proposalsActionsMap,
   proposalsAddAction,
   proposalsAddVote,
   proposalsLookupId,
+  toPrevGovActionIds,
  )
 import Cardano.Ledger.Conway.Governance.Procedures (GovAction (..), foldrVotingProcedures)
 import Cardano.Ledger.Conway.PParams (
@@ -112,14 +114,14 @@ import qualified Data.Sequence.Strict as SSeq
 import qualified Data.Set as Set
 import GHC.Generics (Generic)
 import Lens.Micro
+import qualified Lens.Micro as L
 import NoThunks.Class (NoThunks (..))
 import Validation (failureUnless)
 
 data GovEnv era = GovEnv
   { geTxId :: !(TxId (EraCrypto era))
   , geEpoch :: !EpochNo
   , gePParams :: !(PParams era)
-  , gePrevGovActionIds :: !(GovRelation StrictMaybe era)
   , gePPolicy :: !(StrictMaybe (ScriptHash (EraCrypto era)))
   , geCommitteeState :: !(CommitteeState era)
   }
@@ -329,11 +331,12 @@ govTransition ::
   TransitionRule (EraRule "GOV" era)
 govTransition = do
   TRC
-    ( GovEnv txid currentEpoch pp prevGovActionIds constitutionPolicy committeeState
+    ( GovEnv txid currentEpoch pp constitutionPolicy committeeState
       , st
       , gp
       ) <-
     judgmentContext
+  let prevGovActionIds = st ^. pRootsL . L.to toPrevGovActionIds
 
   expectedNetworkId <- liftSTS $ asks networkId
 

diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Ledger.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Ledger.hs
@@ -50,9 +50,7 @@ import Cardano.Ledger.Conway.Governance (
   GovProcedures (..),
   Proposals,
   constitutionScriptL,
-  pRootsL,
   proposalsGovStateL,
-  toPrevGovActionIds,
  )
 import Cardano.Ledger.Conway.Rules.Cert (CertEnv, ConwayCertPredFailure)
 import Cardano.Ledger.Conway.Rules.Certs (
@@ -390,7 +388,6 @@ ledgerTransition = do
                   (txIdTxBody txBody)
                   currentEpoch
                   pp
-                  (utxoState ^. utxosGovStateL . proposalsGovStateL . pRootsL . L.to toPrevGovActionIds)
                   (utxoState ^. utxosGovStateL . constitutionGovStateL . constitutionScriptL)
                   (certState ^. certVStateL . vsCommitteeStateL)
               , utxoState ^. utxosGovStateL . proposalsGovStateL

diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Arbitrary.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Arbitrary.hs
@@ -583,7 +583,6 @@ instance (Era era, Arbitrary (PParamsHKD Identity era)) => Arbitrary (GovEnv era
       <*> arbitrary
       <*> arbitrary
       <*> arbitrary
-      <*> arbitrary
 
 instance Era era => Arbitrary (VotingProcedure era) where
   arbitrary = VotingProcedure <$> arbitrary <*> arbitrary

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
@@ -4,6 +4,7 @@
 {-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
@@ -290,6 +291,20 @@ proposalsSpec =
           constitutionProposal
           [ injectFailure $ InvalidPrevGovActionId constitutionProposal
           ]
+      it "NoConfidence without a valid parent fails" $ do
+        pProcReturnAddr <- registerRewardAccount
+        corruptGPID <- arbitrary
+        pProcDeposit <- getsPParams ppGovActionDepositL
+        let
+          badProposal =
+            ProposalProcedure
+              { pProcGovAction = NoConfidence $ SJust corruptGPID
+              , pProcAnchor = def
+              , ..
+              }
+        submitFailingProposal
+          badProposal
+          [injectFailure $ InvalidPrevGovActionId badProposal]
       it "Subtrees are pruned when proposals expire" $ do
         modifyPParams $ ppGovActionLifetimeL .~ EpochInterval 4
         p1 <- submitInitConstitutionGovAction

diff --git a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/ImpTest.hs b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/ImpTest.hs
@@ -582,6 +582,17 @@ newtype ImpTestM era a = ImpTestM {_unImpTestM :: ReaderT (ImpTestEnv era) IO a}
     , MonadReader (ImpTestEnv era)
     )
 
+instance
+  ( Testable a
+  , ShelleyEraImp era
+  ) =>
+  Testable (ImpTestM era a)
+  where
+  property m = property . fmap ioProperty . runGenT $ do
+    st <- liftIO mkImpState
+    res <- liftGen $ runImpTestGenM st m
+    liftIO $ fst <$> res
+
 instance MonadWriter [SomeSTSEvent era] (ImpTestM era) where
   writer (x, evs) = (impEventsL %= (<> evs)) $> x
   listen act = do

diff --git a/libs/cardano-data/testlib/Test/Cardano/Data/TreeDiff.hs b/libs/cardano-data/testlib/Test/Cardano/Data/TreeDiff.hs
@@ -5,12 +5,14 @@
 
 module Test.Cardano.Data.TreeDiff where
 
+import Data.Foldable (Foldable (..))
 import Data.Foldable qualified as F
 import Data.OMap.Strict
 import Data.OSet.Strict
-import Test.Cardano.Ledger.Binary.TreeDiff (ToExpr (..))
+import Test.Cardano.Ledger.Binary.TreeDiff (Expr (..), ToExpr (..))
 
-deriving instance ToExpr a => ToExpr (OSet a)
+instance ToExpr a => ToExpr (OSet a) where
+  toExpr x = App "OSet.fromList" [toExpr $ toList x]
 
 instance (HasOKey k v, ToExpr v) => ToExpr (OMap k v) where
   listToExpr = listToExpr . F.toList

diff --git a/libs/cardano-ledger-conformance/cardano-ledger-conformance.cabal b/libs/cardano-ledger-conformance/cardano-ledger-conformance.cabal
@@ -41,6 +41,7 @@ library
         base >=4.14 && <5,
         cardano-data,
         cardano-strict-containers,
+        data-default-class,
         microlens,
         mtl,
         cardano-ledger-binary,
@@ -57,7 +58,8 @@ library
         constrained-generators,
         deepseq,
         small-steps >=1.1,
-        text
+        text,
+        unliftio
 
     if !impl(ghc >=9.2)
         ghc-options: -Wno-incomplete-patterns