Implement DRep votes cleansing

eras/conway/impl/src/Cardano/Ledger/Conway/Core.hs

@@ -29,6 +29,16 @@ module Cardano.Ledger.Conway.Core (
   ConwayEraScript (..),
   pattern VotingPurpose,
   pattern ProposingPurpose,
+  ConwayEraTxCert,
+  pattern RegDepositTxCert,
+  pattern UnRegDepositTxCert,
+  pattern DelegTxCert,
+  pattern RegDepositDelegTxCert,
+  pattern AuthCommitteeHotKeyTxCert,
+  pattern ResignCommitteeColdTxCert,
+  pattern RegDRepTxCert,
+  pattern UnRegDRepTxCert,
+  pattern UpdateDRepTxCert,
   module Cardano.Ledger.Babbage.Core,
 )
 where
@@ -67,3 +77,15 @@ import Cardano.Ledger.Conway.Scripts (
  )
 import Cardano.Ledger.Conway.Tx ()
 import Cardano.Ledger.Conway.TxBody (ConwayEraTxBody (..))
+import Cardano.Ledger.Conway.TxCert (
+  ConwayEraTxCert,
+  pattern AuthCommitteeHotKeyTxCert,
+  pattern DelegTxCert,
+  pattern RegDRepTxCert,
+  pattern RegDepositDelegTxCert,
+  pattern RegDepositTxCert,
+  pattern ResignCommitteeColdTxCert,
+  pattern UnRegDRepTxCert,
+  pattern UnRegDepositTxCert,
+  pattern UpdateDRepTxCert,
+ )

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

@@ -83,6 +83,7 @@
 module Cardano.Ledger.Conway.Governance.Proposals (
   -- * Intended interface to be used for all implementation
   Proposals,
+  mapProposals,
   proposalsIds,
   proposalsActions,
   proposalsSize,
@@ -225,6 +226,10 @@ data Proposals era = Proposals
   deriving stock (Show, Eq, Generic)
   deriving anyclass (NoThunks, NFData, Default)
 
+-- | Make sure not to change the `gasId`, otherwise all hell will break loose.
+mapProposals :: (GovActionState era -> GovActionState era) -> Proposals era -> Proposals era
+mapProposals f props = props {pProps = OMap.mapUnsafe f (pProps props)}
+
 pPropsL :: Lens' (Proposals era) (OMap.OMap (GovActionId (EraCrypto era)) (GovActionState era))
 pPropsL = lens pProps $ \x y -> x {pProps = y}
 

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

@@ -61,6 +61,7 @@ import Cardano.Ledger.CertState (
 import Cardano.Ledger.Coin (Coin (..))
 import Cardano.Ledger.Conway.Era (ConwayEra, ConwayGOV)
 import Cardano.Ledger.Conway.Governance (
+  GovAction (..),
   GovActionId (..),
   GovActionPurpose (..),
   GovActionState (..),
@@ -70,8 +71,11 @@ import Cardano.Ledger.Conway.Governance (
   Proposals,
   Voter (..),
   VotingProcedure (..),
+  VotingProcedures (..),
   foldlVotingProcedures,
+  foldrVotingProcedures,
   gasAction,
+  gasDRepVotesL,
   grHardForkL,
   indexedGovProps,
   isCommitteeVotingAllowed,
@@ -84,16 +88,13 @@ import Cardano.Ledger.Conway.Governance (
   proposalsLookupId,
   toPrevGovActionIds,
  )
-import Cardano.Ledger.Conway.Governance.Procedures (
-  GovAction (..),
-  VotingProcedures (..),
-  foldrVotingProcedures,
- )
+import Cardano.Ledger.Conway.Governance.Proposals (mapProposals)
 import Cardano.Ledger.Conway.PParams (
   ConwayEraPParams (..),
   ppGovActionDepositL,
   ppGovActionLifetimeL,
  )
+import Cardano.Ledger.Conway.TxCert
 import Cardano.Ledger.Core
 import Cardano.Ledger.Credential (Credential)
 import Cardano.Ledger.Keys (KeyRole (..))
@@ -116,6 +117,7 @@ import Control.State.Transition.Extended (
   tellEvent,
   (?!),
  )
+import qualified Data.Foldable as F
 import Data.List.NonEmpty (NonEmpty (..))
 import qualified Data.Map.Strict as Map
 import qualified Data.OSet.Strict as OSet
@@ -273,7 +275,8 @@ deriving instance (EraPParams era, Show (TxCert era)) => Show (GovSignal era)
 instance (EraPParams era, NFData (TxCert era)) => NFData (GovSignal era)
 
 instance
-  ( ConwayEraPParams era
+  ( ConwayEraTxCert era
+  , ConwayEraPParams era
   , EraRule "GOV" era ~ ConwayGOV era
   , InjectRuleFailure "GOV" ConwayGovPredFailure era
   ) =>
@@ -373,7 +376,8 @@ checkBootstrapProposal pp proposal@ProposalProcedure {pProcGovAction}
 
 govTransition ::
   forall era.
-  ( ConwayEraPParams era
+  ( ConwayEraTxCert era
+  , ConwayEraPParams era
   , STS (EraRule "GOV" era)
   , Event (EraRule "GOV" era) ~ ConwayGovEvent era
   , Signal (EraRule "GOV" era) ~ GovSignal era
@@ -504,10 +508,24 @@ govTransition = do
   let
     addVoterVote ps voter govActionId VotingProcedure {vProcVote} =
       proposalsAddVote voter vProcVote govActionId ps
-    updatedProposalStates = foldlVotingProcedures addVoterVote proposals gsVotingProcedures
+    updatedProposalStates =
+      cleanupProposalVotes $
+        foldlVotingProcedures addVoterVote proposals gsVotingProcedures
+    unregisteredDReps =
+      -- , removedAuthorizations =
+      let collectRemovals drepCreds = \case
+            UnRegDRepTxCert drepCred _ -> Set.insert drepCred drepCreds
+            _ -> drepCreds
+       in F.foldl' collectRemovals mempty gsCertificates
+    -- AuthCommitteeHotKeyTxCert
+    -- ResignCommitteeColdTxCert
+    cleanupProposalVotes =
+      let cleanupVoters gas =
+            gas & gasDRepVotesL %~ (`Map.withoutKeys` unregisteredDReps)
+       in mapProposals cleanupVoters
 
   -- Report the event
-  tellEvent $ GovNewProposals txid updatedProposalStates
+  tellEvent $ GovNewProposals txid $ updatedProposalStates
 
   pure updatedProposalStates
 

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

@@ -497,7 +497,8 @@ instance
   wrapEvent = LedgerEvent
 
 instance
-  ( ConwayEraPParams era
+  ( ConwayEraTxCert era
+  , ConwayEraPParams era
   , BaseM (ConwayLEDGER era) ~ ShelleyBase
   , PredicateFailure (EraRule "GOV" era) ~ ConwayGovPredFailure era
   , Event (EraRule "GOV" era) ~ ConwayGovEvent era

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

@@ -157,16 +157,7 @@ import Cardano.Ledger.Conway.Rules (
   validCommitteeTerm,
   withdrawalCanWithdraw,
  )
-import Cardano.Ledger.Conway.TxCert (
-  ConwayEraTxCert (..),
-  Delegatee (..),
-  pattern AuthCommitteeHotKeyTxCert,
-  pattern RegDRepTxCert,
-  pattern RegDepositDelegTxCert,
-  pattern ResignCommitteeColdTxCert,
-  pattern UnRegDRepTxCert,
-  pattern UpdateDRepTxCert,
- )
+import Cardano.Ledger.Conway.TxCert (Delegatee (..))
 import Cardano.Ledger.Credential (Credential (..), StakeReference (..))
 import Cardano.Ledger.Crypto (Crypto (..))
 import Cardano.Ledger.DRep
@@ -426,7 +417,7 @@ setupDRepWithoutStake = do
     mkBasicTx mkBasicTxBody
       & bodyTxL . certsTxBodyL
         .~ SSeq.fromList
-          [ mkRegDepositDelegTxCert @era
+          [ RegDepositDelegTxCert @era
               (KeyHashObj delegatorKH)
               (DelegVote (DRepCredential $ KeyHashObj drepKH))
               deposit
@@ -460,7 +451,7 @@ setupSingleDRep stake = do
           )
       & bodyTxL . certsTxBodyL
         .~ SSeq.fromList
-          [ mkRegDepositDelegTxCert @era
+          [ RegDepositDelegTxCert @era
               (KeyHashObj delegatorKH)
               (DelegVote (DRepCredential $ KeyHashObj drepKH))
               zero

libs/cardano-data/src/Data/OMap/Strict.hs

@@ -22,6 +22,7 @@ module Data.OMap.Strict (
   lookup,
   member,
   (!?),
+  mapUnsafe,
   fromSet,
   fromFoldable,
   fromFoldableDuplicates,
@@ -327,6 +328,11 @@ adjust f k omap@(OMap sseq kv) =
                     Nothing -> OMap (lseq <> (k' SSeq.:<| rseq)) kv'
                     Just _ -> OMap (lseq <> rseq) kv'
 
+-- | This mapping function is only safe when the key stored in the new value matches the
+-- key stored in the new value. This invariant is not checked for performance reasons
+mapUnsafe :: (v1 -> v2) -> OMap k v1 -> OMap k v2
+mapUnsafe f (OMap sseq kv) = OMap sseq (Map.map f kv)
+
 -- | \(O(1)\)
 pattern Empty :: OMap k v
 pattern Empty <- (null -> True)