diff --git a/eras/conway/impl/CHANGELOG.md b/eras/conway/impl/CHANGELOG.md index ed216229463..ecdd2f9f633 100644 --- a/eras/conway/impl/CHANGELOG.md +++ b/eras/conway/impl/CHANGELOG.md @@ -8,6 +8,18 @@ * Added `cgceCurrentCommittee` and `cgceCommitteeProposals` to `ConwayGovCertEnv` * Added `proposalsWithPurpose`, `isGovActionWithPurpose` and `ToGovActionPurpose` * Added `ConwayTxRefScriptsSizeTooBig` predicate failure to `ConwayLedgerPredFailure` +* Replaced `geCommitteeState` with `geCertState` in `GovEnv` +* Added `VotersDoNotExist` predicate failure to `ConwayGovPredFailure` +* Export `ConwayEraTxCert`, `RegDepositTxCert`, `UnRegDepositTxCert`, `DelegTxCert`, + `RegDepositDelegTxCert`, `AuthCommitteeHotKeyTxCert`, `ResignCommitteeColdTxCert`, + `RegDRepTxCert`, `UnRegDRepTxCert` and `UpdateDRepTxCert` from + `Cardano.Ledger.Conway.Core` +* Remove `GovProcedures` in favor of newly added type `GovSignal` + +### `testlib` + +* Change the return type of `resignCommitteeColdKey` +* Add an argument to `registerCommitteeHotKeys` ## 1.15.1.0 diff --git a/eras/conway/impl/cardano-ledger-conway.cabal b/eras/conway/impl/cardano-ledger-conway.cabal index 1e008fff61b..1deec5554d3 100644 --- a/eras/conway/impl/cardano-ledger-conway.cabal +++ b/eras/conway/impl/cardano-ledger-conway.cabal @@ -90,7 +90,7 @@ library cardano-ledger-allegra ^>=1.5, cardano-ledger-alonzo ^>=1.9, cardano-ledger-babbage ^>=1.8, - cardano-ledger-core ^>=1.13, + cardano-ledger-core ^>=1.13.2, cardano-ledger-mary ^>=1.6, cardano-ledger-shelley ^>=1.12.2, cardano-slotting, 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.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Governance.hs index 40bcbddd7a0..4cdef191794 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Governance.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Governance.hs @@ -40,7 +40,6 @@ module Cardano.Ledger.Conway.Governance ( foldlVotingProcedures, foldrVotingProcedures, ProposalProcedure (..), - GovProcedures (..), Anchor (..), AnchorData (..), indexedGovProps, diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Governance/Procedures.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Governance/Procedures.hs index ab671fc721d..e62c0337430 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Governance/Procedures.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Governance/Procedures.hs @@ -23,7 +23,6 @@ {-# LANGUAGE UndecidableInstances #-} module Cardano.Ledger.Conway.Governance.Procedures ( - GovProcedures (..), VotingProcedures (..), VotingProcedure (..), foldlVotingProcedures, @@ -66,7 +65,6 @@ module Cardano.Ledger.Conway.Governance.Procedures ( gasCommitteeVotesL, gasExpiresAfterL, gasProposalProcedureL, - govProceduresProposalsL, gasActionL, gasReturnAddrL, gasProposedInL, @@ -143,7 +141,6 @@ import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Maybe.Strict (StrictMaybe (..)) import qualified Data.OMap.Strict as OMap -import qualified Data.OSet.Strict as OSet import qualified Data.Sequence as Seq import Data.Set (Set) import qualified Data.Text as Text @@ -465,15 +462,6 @@ toVotingProcedurePairs vProc@(VotingProcedure _ _) = , "decision" .= vProcVote ] -data GovProcedures era = GovProcedures - { gpVotingProcedures :: !(VotingProcedures era) - , gpProposalProcedures :: !(OSet.OSet (ProposalProcedure era)) - } - deriving (Eq, Generic) - -govProceduresProposalsL :: Lens' (GovProcedures era) (OSet.OSet (ProposalProcedure era)) -govProceduresProposalsL = lens gpProposalProcedures $ \x y -> x {gpProposalProcedures = y} - -- | Attaches indices to a sequence of proposal procedures. The indices grow -- from left to right. indexedGovProps :: @@ -484,12 +472,6 @@ indexedGovProps = enumerateProps 0 enumerateProps _ Seq.Empty = Seq.Empty enumerateProps !n (x Seq.:<| xs) = (GovActionIx n, x) Seq.:<| enumerateProps (succ n) xs -instance EraPParams era => NoThunks (GovProcedures era) - -instance EraPParams era => NFData (GovProcedures era) - -deriving instance EraPParams era => Show (GovProcedures era) - data ProposalProcedure era = ProposalProcedure { pProcDeposit :: !Coin , pProcReturnAddr :: !(RewardAccount (EraCrypto era)) 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 eb4ebe520b4..9c0ebdb0a9b 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Gov.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Gov.hs @@ -21,6 +21,7 @@ module Cardano.Ledger.Conway.Rules.Gov ( ConwayGOV, GovEnv (..), + GovSignal (..), ConwayGovEvent (..), ConwayGovPredFailure (..), ) where @@ -50,22 +51,31 @@ import Cardano.Ledger.Binary.Coders ( (!>), ( DecCBOR (ConwayGovPredFailure era) where 11 -> SumD InvalidPolicyHash SumD DisallowedProposalDuringBootstrap SumD DisallowedVotesDuringBootstrap SumD VotersDoNotExist Invalid k instance EraPParams era => EncCBOR (ConwayGovPredFailure era) where @@ -232,6 +247,8 @@ instance EraPParams era => EncCBOR (ConwayGovPredFailure era) where Sum DisallowedProposalDuringBootstrap 12 !> To proposal DisallowedVotesDuringBootstrap votes -> Sum DisallowedVotesDuringBootstrap 13 !> To votes + VotersDoNotExist voters -> + Sum VotersDoNotExist 14 !> To voters instance EraPParams era => ToCBOR (ConwayGovPredFailure era) where toCBOR = toEraCBOR @era @@ -245,15 +262,28 @@ data ConwayGovEvent era instance EraPParams era => NFData (ConwayGovEvent era) +data GovSignal era = GovSignal + { gsVotingProcedures :: !(VotingProcedures era) + , gsProposalProcedures :: !(OSet.OSet (ProposalProcedure era)) + , gsCertificates :: !(SSeq.StrictSeq (TxCert era)) + } + deriving (Generic) + +deriving instance (EraPParams era, Eq (TxCert era)) => Eq (GovSignal era) +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 ) => STS (ConwayGOV era) where type State (ConwayGOV era) = Proposals era - type Signal (ConwayGOV era) = GovProcedures era + type Signal (ConwayGOV era) = GovSignal era type Environment (ConwayGOV era) = GovEnv era type BaseM (ConwayGOV era) = ShelleyBase type PredicateFailure (ConwayGOV era) = ConwayGovPredFailure era @@ -346,10 +376,11 @@ 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) ~ GovProcedures era + , Signal (EraRule "GOV" era) ~ GovSignal era , PredicateFailure (EraRule "GOV" era) ~ ConwayGovPredFailure era , BaseM (EraRule "GOV" era) ~ ShelleyBase , Environment (EraRule "GOV" era) ~ GovEnv era @@ -359,12 +390,16 @@ govTransition :: TransitionRule (EraRule "GOV" era) govTransition = do TRC - ( GovEnv txid currentEpoch pp constitutionPolicy committeeState + ( GovEnv txid currentEpoch pp constitutionPolicy CertState {certPState, certVState} , st - , gp + , GovSignal {gsVotingProcedures, gsProposalProcedures, gsCertificates} ) <- judgmentContext let prevGovActionIds = st ^. pRootsL . L.to toPrevGovActionIds + committeeState = vsCommitteeState certVState + knownDReps = vsDReps certVState + knownStakePools = psStakePoolParams certPState + knownCommitteeMembers = authorizedHotCommitteeCredentials committeeState expectedNetworkId <- liftSTS $ asks networkId @@ -437,16 +472,12 @@ govTransition = do Nothing -> ps <$ failBecause (InvalidPrevGovActionId proposal) proposals <- - foldlM' - processProposal - st - (indexedGovProps $ SSeq.fromStrict $ OSet.toStrictSeq $ gpProposalProcedures gp) - - -- Voting - let votingProcedures = gpVotingProcedures gp - -- Inversion of the keys in VotingProcedures, where we can find - -- the voters for every govActionId - (unknownGovActionIds, knownVotes) = + foldlM' processProposal st $ + indexedGovProps (SSeq.fromStrict (OSet.toStrictSeq gsProposalProcedures)) + + -- Inversion of the keys in VotingProcedures, where we can find the voters for every + -- govActionId + let (unknownGovActionIds, knownVotes) = foldrVotingProcedures -- strictness is not needed for `unknown` ( \voter gaId _ (unknown, !known) -> @@ -455,9 +486,17 @@ govTransition = do Nothing -> (gaId : unknown, known) ) ([], []) - votingProcedures + gsVotingProcedures curGovActionIds = proposalsActionsMap proposals - + isVoterKnown = \case + CommitteeVoter hotCred -> hotCred `Set.member` knownCommitteeMembers + DRepVoter cred -> cred `Map.member` knownDReps + StakePoolVoter poolId -> poolId `Map.member` knownStakePools + unknownVoters = + Map.keys $ + Map.filterWithKey (\voter _ -> not (isVoterKnown voter)) (unVotingProcedures gsVotingProcedures) + + failOnNonEmpty unknownVoters VotersDoNotExist failOnNonEmpty unknownGovActionIds GovActionsDoNotExist runTest $ checkBootstrapVotes pp knownVotes runTest $ checkVotesAreNotForExpiredActions currentEpoch knownVotes @@ -466,7 +505,18 @@ govTransition = do let addVoterVote ps voter govActionId VotingProcedure {vProcVote} = proposalsAddVote voter vProcVote govActionId ps - updatedProposalStates = foldlVotingProcedures addVoterVote proposals votingProcedures + updatedProposalStates = + cleanupProposalVotes $ + foldlVotingProcedures addVoterVote proposals gsVotingProcedures + unregisteredDReps = + let collectRemovals drepCreds = \case + UnRegDRepTxCert drepCred _ -> Set.insert drepCred drepCreds + _ -> drepCreds + in F.foldl' collectRemovals mempty gsCertificates + cleanupProposalVotes = + let cleanupVoters gas = + gas & gasDRepVotesL %~ (`Map.withoutKeys` unregisteredDReps) + in mapProposals cleanupVoters -- Report the event tellEvent $ GovNewProposals txid 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 145bc2bc942..d1732b43caa 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Ledger.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Ledger.hs @@ -55,7 +55,6 @@ import Cardano.Ledger.Conway.Era ( import Cardano.Ledger.Conway.Governance ( ConwayEraGov (..), ConwayGovState, - GovProcedures (..), Proposals, constitutionScriptL, grCommitteeL, @@ -73,6 +72,7 @@ import Cardano.Ledger.Conway.Rules.Gov ( ConwayGovEvent (..), ConwayGovPredFailure, GovEnv (..), + GovSignal (..), ) import Cardano.Ledger.Conway.Rules.GovCert (ConwayGovCertPredFailure) import Cardano.Ledger.Conway.Rules.Utxo (ConwayUtxoPredFailure) @@ -88,10 +88,8 @@ import Cardano.Ledger.Shelley.LedgerState ( LedgerState (..), UTxOState (..), asTreasuryL, - certVStateL, utxosGovStateL, utxosUtxoL, - vsCommitteeStateL, ) import Cardano.Ledger.Shelley.Rules ( LedgerEnv (..), @@ -317,7 +315,7 @@ instance , Environment (EraRule "GOV" era) ~ GovEnv era , Signal (EraRule "UTXOW" era) ~ Tx era , Signal (EraRule "CERTS" era) ~ Seq (TxCert era) - , Signal (EraRule "GOV" era) ~ GovProcedures era + , Signal (EraRule "GOV" era) ~ GovSignal era ) => STS (ConwayLEDGER era) where @@ -358,7 +356,7 @@ ledgerTransition :: , Environment (EraRule "CERTS" era) ~ CertsEnv era , Signal (EraRule "UTXOW" era) ~ Tx era , Signal (EraRule "CERTS" era) ~ Seq (TxCert era) - , Signal (EraRule "GOV" era) ~ GovProcedures era + , Signal (EraRule "GOV" era) ~ GovSignal era , BaseM (someLEDGER era) ~ ShelleyBase , STS (someLEDGER era) ) => @@ -403,16 +401,18 @@ ledgerTransition = do dUnified = dsUnified $ certDState certStateAfterCERTS delegatedAddrs = DRepUView dUnified - -- TODO enable this check once delegation is fully implemented in cardano-api + -- TODO: Finish this implementation once we are in bootstrap phase: + -- https://github.com/IntersectMBO/cardano-ledger/issues/4092 when False $ do all (`UMap.member` delegatedAddrs) wdrlCreds ?! ConwayWdrlNotDelegatedToDRep (wdrlCreds Set.\\ Map.keysSet (dRepMap dUnified)) -- Votes and proposals from signal tx - let govProcedures = - GovProcedures - { gpVotingProcedures = txBody ^. votingProceduresTxBodyL - , gpProposalProcedures = txBody ^. proposalProceduresTxBodyL + let govSignal = + GovSignal + { gsVotingProcedures = txBody ^. votingProceduresTxBodyL + , gsProposalProcedures = txBody ^. proposalProceduresTxBodyL + , gsCertificates = txBody ^. certsTxBodyL } proposalsState <- trans @(EraRule "GOV" era) $ @@ -422,9 +422,9 @@ ledgerTransition = do currentEpoch pp (govState ^. constitutionGovStateL . constitutionScriptL) - (certState ^. certVStateL . vsCommitteeStateL) + certStateAfterCERTS , proposals - , govProcedures + , govSignal ) let utxoState' = utxoState @@ -502,7 +502,7 @@ instance , Environment (EraRule "GOV" era) ~ GovEnv era , Signal (EraRule "UTXOW" era) ~ Tx era , Signal (EraRule "CERTS" era) ~ Seq (TxCert era) - , Signal (EraRule "GOV" era) ~ GovProcedures era + , Signal (EraRule "GOV" era) ~ GovSignal era , State (EraRule "UTXOW" era) ~ UTxOState era , State (EraRule "CERTS" era) ~ CertState era , State (EraRule "GOV" era) ~ Proposals era @@ -517,7 +517,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/Arbitrary.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Arbitrary.hs index ea3e6352532..c2fdaf13a81 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Arbitrary.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Arbitrary.hs @@ -599,10 +599,12 @@ instance (Era era, Arbitrary (PParamsUpdate era)) => Arbitrary (ProposalProcedur | (dep', ret', gov', anch') <- shrink (dep, ret, gov, anch) ] -instance (EraPParams era, Arbitrary (PParamsUpdate era)) => Arbitrary (GovProcedures era) where - arbitrary = - GovProcedures <$> arbitrary <*> arbitrary - shrink (GovProcedures vp pp) = [GovProcedures vp' pp' | (vp', pp') <- shrink (vp, pp)] +instance + (EraPParams era, Arbitrary (PParamsUpdate era), Arbitrary (TxCert era)) => + Arbitrary (GovSignal era) + where + arbitrary = GovSignal <$> arbitrary <*> arbitrary <*> arbitrary + shrink (GovSignal vp pp cs) = [GovSignal vp' pp' cs' | (vp', pp', cs') <- shrink (vp, pp, cs)] instance ( Era era diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/GovCertSpec.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/GovCertSpec.hs index 6bd1831a3ff..40c60e6495e 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/GovCertSpec.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/GovCertSpec.hs @@ -99,7 +99,7 @@ spec = do _hotKey <- registerCommitteeHotKey cc ccShouldNotBeResigned cc -- Have them resign - resignCommitteeColdKey cc SNothing + _ <- resignCommitteeColdKey cc SNothing ccShouldBeResigned cc -- Re-add the same CC let reAddCCAction = UpdateCommittee (SJust $ GovPurposeId addCCGaid) mempty (Map.singleton cc 20) (1 %! 2) 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 index 05ae51dfce2..8a6cf9e707c 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/GovSpec.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/GovSpec.hs @@ -541,7 +541,33 @@ proposalsSpec :: , InjectRuleFailure "LEDGER" ConwayGovPredFailure era ) => SpecWith (ImpTestState era) -proposalsSpec = +proposalsSpec = do + describe "Voters" $ do + it "VotersDoNotExist" $ do + pp <- getsNES $ nesEsL . curPParamsEpochStateL + let ProtVer major minor = pp ^. ppProtocolVersionL + gaId <- submitGovAction $ HardForkInitiation SNothing $ ProtVer major (succ minor) + hotCred <- KeyHashObj <$> freshKeyHash + submitFailingVote (CommitteeVoter hotCred) gaId $ + [injectFailure $ VotersDoNotExist [CommitteeVoter hotCred]] + poolId <- freshKeyHash + submitFailingVote (StakePoolVoter poolId) gaId $ + [injectFailure $ VotersDoNotExist [StakePoolVoter poolId]] + dRepCred <- KeyHashObj <$> freshKeyHash + whenPostBootstrap $ do + submitFailingVote (DRepVoter dRepCred) gaId $ + [injectFailure $ VotersDoNotExist [(DRepVoter dRepCred)]] + it "DRep votes are removed" $ do + pp <- getsNES $ nesEsL . curPParamsEpochStateL + gaId <- submitGovAction InfoAction + dRepCred <- KeyHashObj <$> registerDRep + submitVote_ VoteNo (DRepVoter dRepCred) gaId + gas <- getGovActionState gaId + gasDRepVotes gas `shouldBe` [(dRepCred, VoteNo)] + let deposit = pp ^. ppDRepDepositL + submitTx_ $ mkBasicTx (mkBasicTxBody & certsTxBodyL .~ [UnRegDRepTxCert dRepCred deposit]) + gasAfterRemoval <- getGovActionState gaId + gasDRepVotes gasAfterRemoval `shouldBe` [] describe "Proposals" $ do describe "Consistency" $ do it "Proposals submitted without proper parent fail" $ do @@ -827,7 +853,7 @@ votingSpec = committeeMemberVotingOnCommitteeChange it "non-committee-member voting on committee change as a committee member" $ do credCandidate <- KeyHashObj <$> freshKeyHash - credVoter <- KeyHashObj <$> freshKeyHash + hotCred :| _ <- registerInitialCommittee committeeUpdateId <- submitGovAction $ UpdateCommittee @@ -835,7 +861,7 @@ votingSpec = mempty (Map.singleton credCandidate $ EpochNo 28) (3 %! 5) - let voter = CommitteeVoter credVoter + let voter = CommitteeVoter hotCred trySubmitVote VoteNo voter committeeUpdateId `shouldReturn` Left [ injectFailure $ DisallowedVoters [(voter, committeeUpdateId)] @@ -878,8 +904,8 @@ votingSpec = , constitutionAnchor = anchor } submitYesVote_ (DRepVoter dRepCred) constitutionChangeId - resignCommitteeColdKey ccColdCred0 SNothing submitYesVote_ (CommitteeVoter ccHotKey0) constitutionChangeId + _ <- resignCommitteeColdKey ccColdCred0 SNothing submitYesVote_ (CommitteeVoter ccHotKey1) constitutionChangeId passEpoch logAcceptedRatio constitutionChangeId diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/RatifySpec.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/RatifySpec.hs index 8db8d6b4a2e..28cbc4f9b13 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/RatifySpec.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/RatifySpec.hs @@ -26,6 +26,7 @@ import qualified Cardano.Ledger.UMap as UM import Cardano.Ledger.Val ((<->)) import Data.Default.Class (def) import Data.Foldable +import qualified Data.List.NonEmpty as NE import qualified Data.Map.Strict as Map import qualified Data.Sequence.Strict as SSeq import qualified Data.Set as Set @@ -55,6 +56,22 @@ relevantDuringBootstrapSpec :: relevantDuringBootstrapSpec = do spoVotesForHardForkInitiation initiateHardForkWithLessThanMinimalCommitteeSize + it "Many CC Cold Credentials map to the same Hot Credential act as many votes" $ do + hotCred NE.:| _ <- registerInitialCommittee + (dRep, _, _) <- setupSingleDRep . getPositive =<< arbitrary + Positive deposit <- arbitrary + gaId <- submitParameterChange SNothing $ def & ppuDRepDepositL .~ SJust (Coin deposit) + submitYesVote_ (CommitteeVoter hotCred) gaId + whenPostBootstrap $ submitYesVote_ (DRepVoter dRep) gaId + passNEpochs 2 + getLastEnactedParameterChange `shouldReturn` SNothing + -- Make sure all committee members authorize the same hot credential that just voted: + committeeMembers' <- Set.toList <$> getCommitteeMembers + case committeeMembers' of + x : xs -> void $ registerCommitteeHotKeys (pure hotCred) $ x NE.:| xs + _ -> error "Expected an initial committee" + passNEpochs 2 + getLastEnactedParameterChange `shouldReturn` SJust (GovPurposeId gaId) initiateHardForkWithLessThanMinimalCommitteeSize :: forall era. @@ -68,10 +85,11 @@ initiateHardForkWithLessThanMinimalCommitteeSize = modifyPParams $ ppCommitteeMinSizeL .~ 2 committeeMembers' <- Set.toList <$> getCommitteeMembers committeeMember <- elements committeeMembers' - resignCommitteeColdKey committeeMember SNothing + anchor <- arbitrary + mHotCred <- resignCommitteeColdKey committeeMember anchor protVer <- getProtVer gai <- submitGovAction $ HardForkInitiation SNothing (majorFollow protVer) - submitYesVoteCCs_ hotCs gai + submitYesVoteCCs_ (maybe NE.toList (\hotCred -> NE.filter (/= hotCred)) mHotCred $ hotCs) gai submitYesVote_ (StakePoolVoter spoK1) gai if bootstrapPhase protVer then do @@ -143,7 +161,7 @@ committeeExpiryResignationDiscountSpec = ccShouldNotBeResigned committeeColdC2 isCommitteeAccepted gaiConstitution `shouldReturn` True -- Resign the second CC - resignCommitteeColdKey committeeColdC2 SNothing + _ <- resignCommitteeColdKey committeeColdC2 SNothing -- Check for CC acceptance should fail ccShouldBeResigned committeeColdC2 isCommitteeAccepted gaiConstitution `shouldReturn` False 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 278d84fffb2..bfc0f1cd91d 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 @@ -348,7 +339,7 @@ registerInitialCommittee :: registerInitialCommittee = do committeeMembers <- Set.toList <$> getCommitteeMembers case committeeMembers of - x : xs -> registerCommitteeHotKeys $ x NE.:| xs + x : xs -> registerCommitteeHotKeys (KeyHashObj <$> freshKeyHash) $ x NE.:| xs _ -> error "Expected an initial committee" -- | Submit a transaction that registers a new DRep and return the keyhash @@ -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 @@ -1170,32 +1161,46 @@ registerCommitteeHotKey :: Credential 'ColdCommitteeRole (EraCrypto era) -> ImpTestM era (Credential 'HotCommitteeRole (EraCrypto era)) registerCommitteeHotKey coldKey = do - hotKey NE.:| [] <- registerCommitteeHotKeys $ pure coldKey + hotKey NE.:| [] <- registerCommitteeHotKeys (KeyHashObj <$> freshKeyHash) $ pure coldKey pure hotKey registerCommitteeHotKeys :: (ShelleyEraImp era, ConwayEraTxCert era) => + -- | Hot Credential generator + ImpTestM era (Credential 'HotCommitteeRole (EraCrypto era)) -> NonEmpty (Credential 'ColdCommitteeRole (EraCrypto era)) -> ImpTestM era (NonEmpty (Credential 'HotCommitteeRole (EraCrypto era))) -registerCommitteeHotKeys coldKeys = do - keys <- forM coldKeys (\coldKey -> (,) coldKey . KeyHashObj <$> freshKeyHash) +registerCommitteeHotKeys genHotCred coldKeys = do + keys <- forM coldKeys (\coldKey -> (,) coldKey <$> genHotCred) submitTxAnn_ "Registering Committee Hot keys" $ mkBasicTx mkBasicTxBody & bodyTxL . certsTxBodyL .~ SSeq.fromList (map (uncurry AuthCommitteeHotKeyTxCert) (toList keys)) pure $ fmap snd keys --- | Submits a transaction that resigns the cold key +-- | Submits a transaction that resigns the cold key. Prior to resignation if there was +-- hot credential authorization for this committee member it will be returned. resignCommitteeColdKey :: (ShelleyEraImp era, ConwayEraTxCert era) => Credential 'ColdCommitteeRole (EraCrypto era) -> StrictMaybe (Anchor (EraCrypto era)) -> - ImpTestM era () + ImpTestM era (Maybe (Credential 'HotCommitteeRole (EraCrypto era))) resignCommitteeColdKey coldKey anchor = do + committeAuthorizations <- + getsNES $ + nesEsL + . esLStateL + . lsCertStateL + . certVStateL + . vsCommitteeStateL + . csCommitteeCredsL submitTxAnn_ "Resigning Committee Cold key" $ mkBasicTx mkBasicTxBody & bodyTxL . certsTxBodyL .~ SSeq.singleton (ResignCommitteeColdTxCert coldKey anchor) + pure $ do + CommitteeHotCredential hotCred <- Map.lookup coldKey committeAuthorizations + pure hotCred electCommittee :: forall era. diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/TreeDiff.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/TreeDiff.hs index 13f6519c6c1..162c4b52e2f 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/TreeDiff.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/TreeDiff.hs @@ -229,8 +229,9 @@ instance instance ( EraPParams era , ToExpr (PParamsHKD StrictMaybe era) + , ToExpr (TxCert era) ) => - ToExpr (GovProcedures era) + ToExpr (GovSignal era) instance ToExpr (PParams era) => ToExpr (GovEnv era) 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) diff --git a/libs/cardano-ledger-conformance/src/Test/Cardano/Ledger/Conformance/ExecSpecRule/Conway.hs b/libs/cardano-ledger-conformance/src/Test/Cardano/Ledger/Conformance/ExecSpecRule/Conway.hs index eaa07ef09d3..5cd5a0079c2 100644 --- a/libs/cardano-ledger-conformance/src/Test/Cardano/Ledger/Conformance/ExecSpecRule/Conway.hs +++ b/libs/cardano-ledger-conformance/src/Test/Cardano/Ledger/Conformance/ExecSpecRule/Conway.hs @@ -28,7 +28,6 @@ import Cardano.Ledger.Conway.Governance ( Committee (..), EnactState (..), GovActionState (..), - GovProcedures (..), Proposals, RatifyEnv (..), RatifySignal (..), @@ -41,6 +40,7 @@ import Cardano.Ledger.Conway.Governance ( ) import Cardano.Ledger.Conway.Rules ( ConwayGovPredFailure, + GovSignal (..), committeeAcceptedRatio, dRepAcceptedRatio, spoAcceptedRatio, @@ -183,7 +183,7 @@ instance testConformance ctx env st sig = property $ do (implResTest, agdaResTest) <- runConformance @"GOV" @fn @Conway ctx env st sig checkConformance @"GOV" implResTest agdaResTest - let numInputProps = OSet.size $ gpProposalProcedures sig + let numInputProps = OSet.size $ gsProposalProcedures sig pure $ label ("n input proposals = " <> show numInputProps) () instance diff --git a/libs/cardano-ledger-conformance/src/Test/Cardano/Ledger/Conformance/SpecTranslate/Conway.hs b/libs/cardano-ledger-conformance/src/Test/Cardano/Ledger/Conformance/SpecTranslate/Conway.hs index 02631d6956b..aa30b8544c2 100644 --- a/libs/cardano-ledger-conformance/src/Test/Cardano/Ledger/Conformance/SpecTranslate/Conway.hs +++ b/libs/cardano-ledger-conformance/src/Test/Cardano/Ledger/Conformance/SpecTranslate/Conway.hs @@ -55,6 +55,7 @@ import Cardano.Ledger.Conway.Rules ( ConwayUtxoPredFailure, EnactSignal (..), GovEnv (..), + GovSignal (..), ) import Cardano.Ledger.Conway.Scripts (AlonzoScript, ConwayPlutusPurpose (..)) import Cardano.Ledger.Conway.TxCert ( @@ -874,13 +875,13 @@ instance , SpecTranslate ctx (PParamsHKD StrictMaybe era) , SpecRep (PParamsHKD StrictMaybe era) ~ Agda.PParamsUpdate ) => - SpecTranslate ctx (GovProcedures era) + SpecTranslate ctx (GovSignal era) where - type SpecRep (GovProcedures era) = [Agda.GovSignal] + type SpecRep (GovSignal era) = [Agda.GovSignal] - toSpecRep GovProcedures {..} = do - votingProcedures <- toSpecRep gpVotingProcedures - proposalProcedures <- toSpecRep gpProposalProcedures + toSpecRep GovSignal {gsVotingProcedures, gsProposalProcedures} = do + votingProcedures <- toSpecRep gsVotingProcedures + proposalProcedures <- toSpecRep gsProposalProcedures pure $ mconcat [ Agda.GovSignalVote <$> votingProcedures diff --git a/libs/cardano-ledger-core/CHANGELOG.md b/libs/cardano-ledger-core/CHANGELOG.md index 961c6a36087..f7d485772ff 100644 --- a/libs/cardano-ledger-core/CHANGELOG.md +++ b/libs/cardano-ledger-core/CHANGELOG.md @@ -3,6 +3,7 @@ ## 1.13.2.0 * Add `setMinCoinTxOut` and `setMinCoinTxOutWith` +* Add `authorizedHotCommitteeCredentials` ## 1.13.1.0 diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/CertState.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/CertState.hs index 288cceefe37..0e7eb392e23 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/CertState.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/CertState.hs @@ -28,6 +28,7 @@ module Cardano.Ledger.CertState ( DRepState (..), DRep (..), CommitteeState (..), + authorizedHotCommitteeCredentials, AnchorData, lookupDepositDState, lookupRewardDState, @@ -104,9 +105,10 @@ import Control.DeepSeq (NFData (..)) import Control.Monad.Trans import Data.Aeson (KeyValue, ToJSON (..), object, pairs, (.=)) import Data.Default.Class (Default (def)) -import Data.Foldable (foldl') +import qualified Data.Foldable as F import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map +import qualified Data.Set as Set import Data.Typeable import GHC.Generics (Generic) import Lens.Micro (Lens', lens, (^.), _1, _2) @@ -320,6 +322,17 @@ newtype CommitteeState era = CommitteeState } deriving (Eq, Ord, Show, Generic) +-- | Extract all unique hot credential authorizations for the current committee. Note +-- that there is no unique mapping from Hot to Cold credential, therefore we produce a +-- Set, instead of a Map. +authorizedHotCommitteeCredentials :: + CommitteeState era -> Set.Set (Credential 'HotCommitteeRole (EraCrypto era)) +authorizedHotCommitteeCredentials CommitteeState {csCommitteeCreds} = + let toHotCredSet acc = \case + CommitteeHotCredential hotCred -> Set.insert hotCred acc + CommitteeMemberResigned {} -> acc + in F.foldl' toHotCredSet Set.empty csCommitteeCreds + instance NoThunks (CommitteeState era) instance Default (CommitteeState era) @@ -522,8 +535,8 @@ obligationCertState (CertState VState {vsDReps} PState {psDeposits} DState {dsUn let accum ans drepState = ans <> drepDeposit drepState in Obligations { oblStake = UM.fromCompact (UM.sumDepositUView (RewDepUView dsUnified)) - , oblPool = foldl' (<>) (Coin 0) psDeposits - , oblDRep = foldl' accum (Coin 0) vsDReps + , oblPool = F.foldl' (<>) (Coin 0) psDeposits + , oblDRep = F.foldl' accum (Coin 0) vsDReps , oblProposal = Coin 0 } diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/Gov.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/Gov.hs index bc03ed33e55..caa0e258999 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/Gov.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/Gov.hs @@ -15,6 +15,7 @@ import Data.Foldable import Data.Coerce import Cardano.Ledger.BaseTypes +import Cardano.Ledger.CertState import Cardano.Ledger.Conway.Governance import Cardano.Ledger.Conway.PParams import Cardano.Ledger.Conway.Rules @@ -243,7 +244,7 @@ govProceduresSpec :: IsConwayUniv fn => GovEnv (ConwayEra StandardCrypto) -> Proposals (ConwayEra StandardCrypto) -> - Specification fn (GovProcedures (ConwayEra StandardCrypto)) + Specification fn (GovSignal (ConwayEra StandardCrypto)) govProceduresSpec ge@GovEnv {..} ps = let actions f = [ gid @@ -251,26 +252,36 @@ govProceduresSpec ge@GovEnv {..} ps = , geEpoch <= act ^. gasExpiresAfterL , f (gasAction act) ] + committeeState = vsCommitteeState (certVState geCertState) + knownDReps = Map.keysSet $ vsDReps (certVState geCertState) + knownStakePools = Map.keysSet $ psStakePoolParams (certPState geCertState) + knownCommitteeAuthorizations = authorizedHotCommitteeCredentials committeeState committeeVotableActionIds = - actions (isCommitteeVotingAllowed geEpoch geCommitteeState) + actions (isCommitteeVotingAllowed geEpoch committeeState) drepVotableActionIds = actions isDRepVotingAllowed stakepoolVotableActionIds = actions isStakePoolVotingAllowed - in constrained $ \govProcs -> - match govProcs $ \votingProcs proposalProcs -> + in constrained $ \govSignal -> + match govSignal $ \votingProcs proposalProcs _certificates -> [ match votingProcs $ \votingProcsMap -> forAll votingProcsMap $ \kvp -> match kvp $ \voter mapActVote -> (caseOn voter) - ( branch $ \_c -> - subset_ (dom_ mapActVote) (lit $ Set.fromList committeeVotableActionIds) + ( branch $ \committeeHotCred -> + [ subset_ (dom_ mapActVote) (lit $ Set.fromList committeeVotableActionIds) + , member_ committeeHotCred $ lit knownCommitteeAuthorizations + ] ) - ( branch $ \_c -> - subset_ (dom_ mapActVote) (lit $ Set.fromList drepVotableActionIds) + ( branch $ \drepCred -> + [ subset_ (dom_ mapActVote) (lit $ Set.fromList drepVotableActionIds) + , member_ drepCred $ lit knownDReps + ] ) - ( branch $ \_c -> - subset_ (dom_ mapActVote) (lit $ Set.fromList stakepoolVotableActionIds) + ( branch $ \poolKeyHash -> + [ subset_ (dom_ mapActVote) (lit $ Set.fromList stakepoolVotableActionIds) + , member_ poolKeyHash $ lit knownStakePools + ] ) , forAll proposalProcs $ \proc -> match proc $ \deposit returnAddr govAction _ -> diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/Instances.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/Instances.hs index 60ba8f1cd6c..95689dee853 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/Instances.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/Instances.hs @@ -248,16 +248,17 @@ instance HasSimpleRep DeltaCoin where toSimpleRep (DeltaCoin c) = c instance IsConwayUniv fn => HasSpec fn DeltaCoin -instance HasSimpleRep (GovProcedures era) +instance HasSimpleRep (GovSignal era) instance - ( Era era + ( EraTxCert era , EraPParams era , IsConwayUniv fn , HasSimpleRep (PParamsHKD StrictMaybe era) , TypeSpec fn (SimpleRep (PParamsHKD StrictMaybe era)) ~ TypeSpec fn (PParamsHKD StrictMaybe era) , HasSpec fn (SimpleRep (PParamsHKD StrictMaybe era)) + , HasSpec fn (TxCert era) ) => - HasSpec fn (GovProcedures era) + HasSpec fn (GovSignal era) instance HasSimpleRep SlotNo instance IsConwayUniv fn => OrdLike fn SlotNo diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Fields.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Fields.hs index 078eea073b0..1a2af2b034e 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Fields.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Fields.hs @@ -62,7 +62,7 @@ import Cardano.Ledger.BaseTypes ( import Cardano.Ledger.Binary (sizedValue) import Cardano.Ledger.Coin (Coin (..)) import Cardano.Ledger.Conway.Core -import Cardano.Ledger.Conway.Governance (GovProcedures (..)) +import Cardano.Ledger.Conway.Governance (ProposalProcedure, VotingProcedures) import Cardano.Ledger.Conway.PParams (ConwayPParams (..)) import Cardano.Ledger.Conway.TxBody (ConwayTxBody (..)) import Cardano.Ledger.Credential (Credential (..), StakeReference (..)) @@ -133,7 +133,8 @@ data TxBodyField era | WppHash (StrictMaybe (ScriptIntegrityHash (EraCrypto era))) | AdHash (StrictMaybe (AuxiliaryDataHash (EraCrypto era))) | Txnetworkid (StrictMaybe Network) - | GovProcs (GovProcedures era) + | ProposalProc (OSet.OSet (ProposalProcedure era)) + | VotingProc (VotingProcedures era) | CurrentTreasuryValue (StrictMaybe Coin) | TreasuryDonation Coin @@ -453,7 +454,8 @@ abstractTxBody Conway (ConwayTxBody inp col ref out colret totcol cert wdrl fee , WppHash sih , AdHash adh , Txnetworkid net - , GovProcs $ GovProcedures vp pp + , VotingProc vp + , ProposalProc pp , CurrentTreasuryValue ctv , TreasuryDonation td ] diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/PrettyCore.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/PrettyCore.hs index f51c2ef1182..edb2f0ffec4 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/PrettyCore.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/PrettyCore.hs @@ -99,7 +99,6 @@ import Cardano.Ledger.Conway.Governance ( GovActionId (..), GovActionIx (..), GovActionState (..), - GovProcedures (..), GovPurposeId (..), GovRelation (..), PEdges (..), @@ -133,6 +132,7 @@ import Cardano.Ledger.Conway.Rules ( ConwayUtxosPredFailure, EnactSignal (..), GovEnv (..), + GovSignal (..), ) import qualified Cardano.Ledger.Conway.Rules as ConwayRules import Cardano.Ledger.Conway.Scripts (ConwayPlutusPurpose (..)) @@ -1117,7 +1117,8 @@ pcTxBodyField proof x = case x of AdHash (SJust (AuxiliaryDataHash h)) -> [("aux data hash", trim (ppSafeHash h))] Txnetworkid SNothing -> [("network id", ppString "Nothing")] Txnetworkid (SJust nid) -> [("network id", pcNetwork nid)] - GovProcs ga -> [("gov procedures", pcGovProcedures ga)] + ProposalProc props -> [("proposing procedure", ppList pcProposalProcedure (toList props))] + VotingProc votes -> [("voting procedure", pcVotingProcedures votes)] CurrentTreasuryValue ctv -> [("current treasury value", ppStrictMaybe pcCoin ctv)] TreasuryDonation td -> [("treasury donation", pcCoin td)] @@ -1549,6 +1550,7 @@ ppConwayGovPredFailure x = case x of DisallowedProposalDuringBootstrap p -> ppSexp "DisallowedProposalDuringBootstrap" [pcProposalProcedure p] DisallowedVotesDuringBootstrap m -> ppSexp "DisallowedVotesDuringBootstrap" [prettyA m] + VotersDoNotExist m -> ppSexp "VotersDoNotExist" [prettyA m] instance PrettyA (ConwayGovPredFailure era) where prettyA = ppConwayGovPredFailure @@ -2780,16 +2782,17 @@ pcTxCert Alonzo x = pcShelleyTxCert x pcTxCert Babbage x = pcShelleyTxCert x pcTxCert Conway x = pcConwayTxCert x -pcGovProcedures :: forall era. GovProcedures era -> PDoc -pcGovProcedures (GovProcedures vote proposal) = +pcGovSignal :: forall era. Reflect era => GovSignal era -> PDoc +pcGovSignal (GovSignal vote proposal certs) = ppRecord "GovProcedure" [ ("voting", pcVotingProcedures vote) - , ("proposal", ppList (pcProposalProcedure @era) (toList proposal)) + , ("proposal", ppList pcProposalProcedure (toList proposal)) + , ("certificates", ppList (pcTxCert (reify @era)) (toList certs)) ] -instance PrettyA (GovProcedures era) where - prettyA = pcGovProcedures +instance Reflect era => PrettyA (GovSignal era) where + prettyA = pcGovSignal pcVotingProcedures :: VotingProcedures era -> PDoc pcVotingProcedures (VotingProcedures m) = diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Updaters.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Updaters.hs index b52dc57d4fd..348ec91b1ca 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Updaters.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Updaters.hs @@ -21,7 +21,6 @@ import Cardano.Ledger.Alonzo.TxBody (AlonzoTxOut (..)) import Cardano.Ledger.Alonzo.TxWits (AlonzoTxWits (..), Redeemers (..), TxDats (..)) import Cardano.Ledger.Babbage.Core import Cardano.Ledger.Babbage.TxBody (BabbageTxOut (..)) -import Cardano.Ledger.Conway.Governance (GovProcedures (..)) import Cardano.Ledger.Conway.PParams ( ppCommitteeMaxTermLengthL, ppCommitteeMinSizeL, @@ -226,7 +225,8 @@ updateTxBody pf txBody dt = RefInputs refInputs -> txBody & referenceInputsTxBodyL .~ refInputs TotalCol totalCol -> txBody & totalCollateralTxBodyL .~ totalCol CollateralReturn collateralReturn -> txBody & collateralReturnTxBodyL .~ collateralReturn - GovProcs (GovProcedures vp pp) -> txBody & votingProceduresTxBodyL .~ vp & proposalProceduresTxBodyL .~ pp + VotingProc vp -> txBody & votingProceduresTxBodyL .~ vp + ProposalProc pp -> txBody & proposalProceduresTxBodyL .~ pp _ -> txBody {-# NOINLINE updateTxBody #-}