diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Core.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Core.hs index b11af59f28a..79282d691b2 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Core.hs +++ b/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, + ) diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Governance/Proposals.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Governance/Proposals.hs index 17c6469fbb6..3531edd39fe 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Governance/Proposals.hs +++ b/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} diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Gov.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Gov.hs index e700ce653d7..ea03b9e0bef 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Gov.hs +++ b/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 diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Ledger.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Ledger.hs index 6aa8b540ee7..659f904c101 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Ledger.hs +++ b/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 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 84964b5b06c..296dbd78d42 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/ImpTest.hs +++ b/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 diff --git a/libs/cardano-data/src/Data/OMap/Strict.hs b/libs/cardano-data/src/Data/OMap/Strict.hs index bc85b1033d7..4bb8806c565 100644 --- a/libs/cardano-data/src/Data/OMap/Strict.hs +++ b/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)