Merge pull request #4604 from IntersectMBO/lehins/fix-GovInfoEvent

Fix enacted `Set` in `GovInfoEvent`

Author: lehins

eras/conway/impl/CHANGELOG.md

@@ -1,6 +1,7 @@
 # Version history for `cardano-ledger-conway`
 
 ## 1.17.0.0
+
 * Changed `ConwayWdrlNotDelegatedToDRep` to wrap `NonEmpty`
 * Add `showGovActionType`, `acceptedByEveryone`
 * Added `unRatifySignal`
@@ -12,6 +13,7 @@
   * `reDRepStateL`
   * `reCurrentEpochL`
   * `reCommitteeStateL`
+* Add a new field to `GovInfoEvent`
 
 ### `testlib`
 

eras/conway/impl/cardano-ledger-conway.cabal

@@ -141,29 +141,29 @@ library testlib
     build-depends:
         base,
         bytestring,
-        cardano-data:{cardano-data, testlib},
-        containers,
-        cuddle >=0.3.0.0,
-        plutus-ledger-api,
-        deepseq,
-        microlens,
         cardano-crypto-class,
+        cardano-data:{cardano-data, testlib},
         cardano-ledger-allegra,
         cardano-ledger-alonzo:{cardano-ledger-alonzo, testlib},
-        cardano-ledger-binary,
+        cardano-ledger-binary:{cardano-ledger-binary, testlib},
         cardano-ledger-babbage:{cardano-ledger-babbage, testlib} >=1.8.2,
         cardano-ledger-conway,
         cardano-ledger-core:{cardano-ledger-core, testlib},
         cardano-ledger-mary,
         cardano-ledger-shelley,
         cardano-strict-containers,
+        containers,
+        cuddle >=0.3.0.0,
         data-default-class,
+        deepseq,
         FailT,
         generic-random,
+        microlens,
         microlens-mtl,
         mtl,
-        text,
-        small-steps >=1.1
+        plutus-ledger-api,
+        small-steps >=1.1,
+        text
 
 executable huddle-cddl
     main-is:          Main.hs

eras/conway/impl/src/Cardano/Ledger/Conway/Governance/Proposals.hs

@@ -449,35 +449,39 @@ proposalsApplyEnactment ::
   Set (GovActionId (EraCrypto era)) ->
   Proposals era ->
   ( Proposals era
+  , Map (GovActionId (EraCrypto era)) (GovActionState era) -- Enacted actions
   , Map (GovActionId (EraCrypto era)) (GovActionState era) -- Removed due to enactment
   , Map (GovActionId (EraCrypto era)) (GovActionState era) -- Removed due to expiry
   )
 proposalsApplyEnactment enactedGass expiredGais props =
   let (unexpiredProposals, expiredRemoved) = proposalsRemoveWithDescendants expiredGais props
-      (enactedProposalsState, removedDueToEnactment) =
-        F.foldl' enact (unexpiredProposals, Map.empty) enactedGass
-   in (enactedProposalsState, removedDueToEnactment, expiredRemoved)
+      (enactedProposalsState, enacted, removedDueToEnactment) =
+        F.foldl' enact (unexpiredProposals, Map.empty, Map.empty) enactedGass
+   in (enactedProposalsState, enacted, removedDueToEnactment, expiredRemoved)
   where
-    enact (!ps, !removed) gas = withGovActionParent gas enactWithoutRoot enactFromRoot
+    enact (!ps, !enacted, !removed) gas = withGovActionParent gas enactWithoutRoot enactFromRoot
       where
         gai = gas ^. gasIdL
         enactWithoutRoot ::
           ( Proposals era
           , Map (GovActionId (EraCrypto era)) (GovActionState era)
+          , Map (GovActionId (EraCrypto era)) (GovActionState era)
           )
         enactWithoutRoot =
-          let (newOMap, removedActions) = OMap.extractKeys (Set.singleton gai) $ ps ^. pPropsL
+          let (newOMap, enactedAction) = OMap.extractKeys (Set.singleton gai) $ ps ^. pPropsL
            in assert -- we want an AssertionFailure here for exhaustive property-testing
-                (not $ Map.null removedActions)
+                (not $ Map.null enactedAction)
                 ( ps & pPropsL .~ newOMap
-                , removed `Map.union` removedActions
+                , enacted `Map.union` enactedAction
+                , removed
                 )
         enactFromRoot ::
           (forall f. Lens' (GovRelation f era) (f (GovPurposeId p era))) ->
           StrictMaybe (GovPurposeId p era) ->
           GovPurposeId p era ->
           ( Proposals era
           , Map (GovActionId (EraCrypto era)) (GovActionState era)
+          , Map (GovActionId (EraCrypto era)) (GovActionState era)
           )
         enactFromRoot govRelationL parent gpi =
           let siblings =
@@ -500,7 +504,8 @@ proposalsApplyEnactment enactedGass expiredGais props =
            in assert
                 (ps ^. pRootsL . govRelationL . prRootL == parent)
                 ( checkInvariantAfterDeletion (Set.singleton gai) withoutSiblings newProposals
-                , removed `Map.union` removedActions `Map.union` enactedAction
+                , enacted `Map.union` enactedAction
+                , removed `Map.union` removedActions
                 )
 
 -- | Get the sequence of `GovActionState`s

eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Epoch.hs

@@ -131,9 +131,15 @@ data ConwayEpochEvent era
   | SnapEvent (Event (EraRule "SNAP" era))
   | EpochBoundaryRatifyState (RatifyState era)
   | GovInfoEvent
-      (Set (GovActionState era)) -- enacted
-      (Set (GovActionState era)) -- expired
-      (Set (GovActionId (EraCrypto era))) -- unclaimed
+      -- | Enacted actions
+      (Set (GovActionState era))
+      -- | Actions that were removed as conflicting due to enactment
+      (Set (GovActionState era))
+      -- | Actions that were removed due to expiration together with their dependees
+      (Set (GovActionState era))
+      -- | Ids of removed governance actions that had an unregistered reward account, thus
+      -- leading to unclaimed deposits being transfered to the treasury.
+      (Set (GovActionId (EraCrypto era)))
   deriving (Generic)
 
 type instance EraRuleEvent "EPOCH" (ConwayEra c) = ConwayEpochEvent (ConwayEra c)
@@ -325,7 +331,7 @@ epochTransition = do
     -- enacted actions and their sibling subtrees, as well as expired
     -- actions and their subtrees, removed, and with all the votes
     -- intact for the rest of them.
-    (newProposals, enactedActions, expiredActions) =
+    (newProposals, enactedActions, removedDueToEnactment, expiredActions) =
       proposalsApplyEnactment rsEnacted rsExpired (govState0 ^. proposalsGovStateL)
 
     -- Apply the values from the computed EnactState to the GovState
@@ -338,14 +344,15 @@ epochTransition = do
         & cgsPrevPParamsL .~ curPParams
         & cgsFuturePParamsL .~ PotentialPParamsUpdate Nothing
 
-    allRemovedGovActions = expiredActions `Map.union` enactedActions
+    allRemovedGovActions = Map.unions [expiredActions, enactedActions, removedDueToEnactment]
     (newUMap, unclaimed) =
       returnProposalDeposits allRemovedGovActions $
         dState2 ^. dsUnifiedL
 
   tellEvent $
     GovInfoEvent
       (Set.fromList $ Map.elems enactedActions)
+      (Set.fromList $ Map.elems removedDueToEnactment)
       (Set.fromList $ Map.elems expiredActions)
       (Map.keysSet unclaimed)
 

eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Arbitrary.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
@@ -69,7 +70,9 @@ import Test.Cardano.Data (genNonEmptyMap)
 import Test.Cardano.Data.Arbitrary ()
 import Test.Cardano.Ledger.Alonzo.Arbitrary (genValidAndUnknownCostModels, genValidCostModel)
 import Test.Cardano.Ledger.Babbage.Arbitrary ()
+import Test.Cardano.Ledger.Binary.Random (QC (..))
 import Test.Cardano.Ledger.Common
+import Test.Cardano.Ledger.Core.Arbitrary (uniformSubMap)
 
 instance
   (Era era, Arbitrary (PParamsUpdate era)) =>
@@ -248,9 +251,12 @@ instance
 
 data ProposalsForEnactment era
   = ProposalsForEnactment
-      (Proposals era)
-      (Seq.Seq (GovActionState era))
-      (Set.Set (GovActionId (EraCrypto era)))
+  { pfeProposals :: Proposals era
+  , pfeToEnact :: Seq.Seq (GovActionState era)
+  , pfeToRemove :: Set.Set (GovActionId (EraCrypto era))
+  , pfeToRetain :: Set.Set (GovActionId (EraCrypto era))
+  -- ^ Those that are retained can only be the ones that don't have any lineage
+  }
   deriving (Show, Eq)
 
 instance
@@ -259,22 +265,41 @@ instance
   where
   arbitrary = do
     ps <- genProposals @era (2, 50)
+    let gasHasNoLineage gas =
+          case gasAction gas of
+            InfoAction {} -> True
+            TreasuryWithdrawals {} -> True
+            _ -> False
+        hasNoLineage gaId =
+          case proposalsLookupId gaId ps of
+            Nothing -> error $ "Expected " ++ show gaId ++ " in generated proposals"
+            Just gas -> gasHasNoLineage gas
     pparamUpdates <- chooseLineage grPParamUpdateL ps Seq.Empty
     hardForks <- chooseLineage grHardForkL ps Seq.Empty
     committees <- chooseLineage grCommitteeL ps Seq.Empty
     constitutions <- chooseLineage grConstitutionL ps Seq.Empty
+    noLineageMap <- uniformSubMap Nothing (Map.filter gasHasNoLineage $ proposalsActionsMap ps) QC
+    noLineage <- Seq.fromList <$> shuffle (Map.elems noLineageMap)
     sequencedGass <-
       sequenceLineages
         ( Seq.filter
             (not . Seq.null)
-            (Seq.fromList [pparamUpdates, hardForks, committees, constitutions])
+            (Seq.fromList [pparamUpdates, hardForks, committees, constitutions, noLineage])
         )
         Seq.Empty
-    let expiredGais =
+    let notEnacted =
           Set.fromList (toList $ proposalsIds ps)
             `Set.difference` Set.fromList (gasId <$> toList sequencedGass)
-    pure $ ProposalsForEnactment ps sequencedGass expiredGais
+    let (retained, removedDueToConflict) = Set.partition hasNoLineage notEnacted
+    pure $
+      ProposalsForEnactment
+        { pfeProposals = ps
+        , pfeToEnact = sequencedGass
+        , pfeToRemove = removedDueToConflict
+        , pfeToRetain = retained
+        }
     where
+      -- Starting from the root select a path in the tree until a leaf is reached.
       chooseLineage ::
         (forall f. Lens' (GovRelation f era) (f (GovPurposeId p era))) ->
         Proposals era ->
@@ -297,6 +322,7 @@ instance
                   chooseLineage govRelL ps (lineage Seq.:|> (proposalsActionsMap ps Map.! unGovPurposeId child))
       consumeHeadAtIndex :: Int -> Seq.Seq (Seq.Seq a) -> (a, Seq.Seq (Seq.Seq a))
       consumeHeadAtIndex idx ss = (ss `Seq.index` idx `Seq.index` 0, Seq.adjust' (Seq.drop 1) idx ss)
+      -- Mix lineages at random, while preserving relative order of each lineage
       sequenceLineages :: Seq.Seq (Seq.Seq a) -> Seq.Seq a -> Gen (Seq.Seq a)
       sequenceLineages lineages sequenced = case lineages of
         Seq.Empty -> pure sequenced
@@ -338,7 +364,7 @@ genProposals range = do
   go (def & pRootsL .~ fromPrevGovActionIds pgais) i
   where
     go :: Proposals era -> Int -> Gen (Proposals era)
-    go ps n
+    go !ps n
       | n <= 0 = pure ps
       | otherwise = do
           gas <- genGovActionState @era =<< genGovAction ps

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

@@ -490,12 +490,15 @@ eventsSpec = describe "Events" $ do
       whenPostBootstrap (modifyPParams $ ppDRepVotingThresholdsL . dvtPPEconomicGroupL .~ def)
       propDeposit <- getsNES $ nesEsL . curPParamsEpochStateL . ppGovActionDepositL
       let
-        proposeCostModel = do
+        proposeParameterChange = do
           newVal <- arbitrary
-          submitParameterChange SNothing $ def & ppuCoinsPerUTxOByteL .~ SJust newVal
-      proposalA <- impAnn "proposalA" proposeCostModel
-      proposalB <- impAnn "proposalB" proposeCostModel
+          proposal <- submitParameterChange SNothing $ def & ppuCoinsPerUTxOByteL .~ SJust newVal
+          pure
+            (proposal, (getsNES $ nesEsL . curPParamsEpochStateL . ppCoinsPerUTxOByteL) `shouldReturn` newVal)
+      (proposalA, checkProposedParameterA) <- proposeParameterChange
+      (proposalB, _) <- proposeParameterChange
       rewardAccount@(RewardAccount _ rewardCred) <- registerRewardAccount
+      passEpoch -- prevent proposalC expiry and force it's deletion due to conflit.
       proposalC <- impAnn "proposalC" $ do
         newVal <- arbitrary
         submitProposal
@@ -517,9 +520,9 @@ eventsSpec = describe "Events" $ do
           (_, evs) <- listen passEpoch
           filter isGovInfoEvent evs
             `shouldBeExpr` [ SomeSTSEvent @era @"TICK" . injectEvent $
-                              GovInfoEvent mempty mempty mempty
+                              GovInfoEvent mempty mempty mempty mempty
                            ]
-      replicateM_ (fromIntegral actionLifetime) passEpochWithNoDroppedActions
+      replicateM_ (fromIntegral actionLifetime - 1) passEpochWithNoDroppedActions
       logAcceptedRatio proposalA
       submitYesVote_ (StakePoolVoter spoCred) proposalA
       submitYesVoteCCs_ ccCreds proposalA
@@ -532,12 +535,14 @@ eventsSpec = describe "Events" $ do
             .~ SSeq.singleton (UnRegTxCert rewardCred)
       passEpochWithNoDroppedActions
       (_, evs) <- listen passEpoch
+      checkProposedParameterA
       let
         filteredEvs = filter isGovInfoEvent evs
       filteredEvs
         `shouldBeExpr` [ SomeSTSEvent @era @"TICK" . injectEvent $
                           GovInfoEvent
                             (Set.singleton gasA)
-                            (Set.fromList [gasB, gasC])
+                            (Set.singleton gasC)
+                            (Set.singleton gasB)
                             (Set.singleton proposalC)
                        ]

eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Proposals.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
 module Test.Cardano.Ledger.Conway.Proposals where
@@ -10,6 +11,7 @@ import Control.Exception (AssertionFailed (..), evaluate)
 import Data.Either (isRight)
 import Data.Foldable as F (foldl', toList)
 import qualified Data.Map.Strict as Map
+import Data.MapExtras (fromElems)
 import Data.Maybe (fromMaybe)
 import Data.Sequence (fromList)
 import qualified Data.Sequence as Seq
@@ -51,33 +53,50 @@ spec = do
             `shouldThrow` \AssertionFailed {} -> True
     describe "Enactment" $ do
       prop "Adding votes preserves consistency" $
-        \(ProposalsForEnactment ps gass _ :: ProposalsForEnactment Conway, voter :: Voter era, vote :: Vote) -> do
-          case gass of
-            gas Seq.:<| _gass -> isRight . toGovRelationTreeEither $ proposalsAddVote voter vote (gasId gas) ps
-            _ -> True
+        \( ProposalsForEnactment {pfeProposals, pfeToEnact} :: ProposalsForEnactment Conway
+          , voter :: Voter era
+          , vote :: Vote
+          ) -> do
+            case pfeToEnact of
+              gas Seq.:<| _gass -> isRight . toGovRelationTreeEither $ proposalsAddVote voter vote (gasId gas) pfeProposals
+              _ -> True
       prop "Enacting exhaustive lineages reduces Proposals to their roots" $
-        \(ProposalsForEnactment ps gass _ :: ProposalsForEnactment Conway) -> do
-          let toEnact = Set.fromList $ toList gass
-              (_ps', enactedRemoved, expiredRemoved) = proposalsApplyEnactment gass Set.empty ps
-          expiredRemoved `shouldSatisfy` Map.null
-          toEnact `shouldSatisfy` (`Set.isSubsetOf` Set.fromList (Map.elems enactedRemoved))
+        \( ProposalsForEnactment {pfeProposals, pfeToEnact, pfeToRemove, pfeToRetain} ::
+            ProposalsForEnactment Conway
+          ) -> do
+            let (ps', enacted, removedDueToEnactment, expiredRemoved) = proposalsApplyEnactment pfeToEnact Set.empty pfeProposals
+            expiredRemoved `shouldSatisfy` Map.null
+            enacted `shouldBe` fromElems gasId pfeToEnact
+            Map.keysSet removedDueToEnactment `shouldBe` pfeToRemove
+            proposalsSize ps' `shouldBe` Set.size pfeToRetain
       prop "Enacting non-member nodes throws an AssertionFailure" $
         \(ProposalsNewActions ps actions :: ProposalsNewActions Conway) ->
           (evaluate . force) (proposalsApplyEnactment (fromList actions) Set.empty ps)
             `shouldThrow` \AssertionFailed {} -> True
       prop "Expiring compliments of exhaustive lineages keeps proposals consistent" $
-        \(ProposalsForEnactment ps _ gais :: ProposalsForEnactment Conway) -> do
-          let (_ps', enactedRemoved, expiredRemoved) = proposalsApplyEnactment Seq.Empty gais ps
-          enactedRemoved `shouldSatisfy` Map.null
-          gais `shouldSatisfy` (`Set.isSubsetOf` Map.keysSet expiredRemoved)
+        \( ProposalsForEnactment {pfeProposals, pfeToEnact, pfeToRemove, pfeToRetain} ::
+            ProposalsForEnactment Conway
+          ) -> do
+            let (ps', enacted, removedDueToEnactment, expiredRemoved) =
+                  proposalsApplyEnactment Seq.Empty pfeToRemove pfeProposals
+            enacted `shouldBe` mempty
+            removedDueToEnactment `shouldBe` mempty
+            Map.keysSet expiredRemoved `shouldBe` pfeToRemove
+            ps' `shouldBe` fst (proposalsRemoveWithDescendants pfeToRemove pfeProposals)
+            let enactMap = fromElems gasId pfeToEnact
+            let (emptyProposals, enactedMap) = proposalsRemoveWithDescendants (Map.keysSet enactMap) ps'
+            proposalsSize emptyProposals `shouldBe` Set.size pfeToRetain
+            enactedMap `shouldBe` enactMap
       prop "Expiring non-member nodes throws an AssertionFailure" $
         \(ProposalsNewActions ps actions :: ProposalsNewActions Conway) ->
           (evaluate . force) (proposalsApplyEnactment Seq.Empty (Set.fromList $ gasId <$> actions) ps)
             `shouldThrow` \AssertionFailed {} -> True
-      prop "Enacting and expiring exhaustive lineages reduces Proposals to their roots" $
-        \(ProposalsForEnactment ps toEnact toExpire :: ProposalsForEnactment Conway) -> do
-          let (ps', enactedRemoved, expiredRemoved) = proposalsApplyEnactment toEnact toExpire ps
-          Set.fromList (toList toEnact)
-            `shouldSatisfy` (`Set.isSubsetOf` Set.fromList (Map.elems enactedRemoved))
-          Set.fromList (toList toExpire) `shouldSatisfy` (`Set.isSubsetOf` Map.keysSet expiredRemoved)
-          proposalsSize ps' `shouldBe` 0
+      prop "Enacting and expiring conflicting proposals does not lead to removal due to enactment" $
+        \( ProposalsForEnactment {pfeProposals, pfeToEnact, pfeToRemove, pfeToRetain} ::
+            ProposalsForEnactment Conway
+          ) -> do
+            let (ps', enacted, enactedRemoved, expiredRemoved) = proposalsApplyEnactment pfeToEnact pfeToRemove pfeProposals
+            Map.keysSet expiredRemoved `shouldBe` pfeToRemove
+            enactedRemoved `shouldBe` mempty
+            enacted `shouldBe` fromElems gasId pfeToEnact
+            proposalsSize ps' `shouldBe` Set.size pfeToRetain