From 34fe98b1b46d7ecaa7e7ac70dffe9c48299a5fd9 Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Sat, 28 Dec 2024 14:43:56 -0700 Subject: [PATCH 1/9] Implement sharing of voter credentials upon vote submission --- .../src/Cardano/Ledger/Conway/Rules/Gov.hs | 41 ++++++++++--------- .../Test/Cardano/Ledger/Conway/Imp/GovSpec.hs | 13 +----- .../Cardano/Ledger/Binary/Decoding/Sharing.hs | 32 +++++++++++---- 3 files changed, 48 insertions(+), 38 deletions(-) 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 84b4a9b274d..2d7eb59e04b 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Gov.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Gov.hs @@ -46,6 +46,8 @@ import Cardano.Ledger.Binary ( EncCBOR (..), FromCBOR (..), ToCBOR (..), + internMap, + internSet, ) import Cardano.Ledger.Binary.Coders ( Decode (..), @@ -77,7 +79,6 @@ import Cardano.Ledger.Conway.Governance ( Voter (..), VotingProcedure (..), VotingProcedures (..), - foldlVotingProcedures, foldrVotingProcedures, gasAction, gasDRepVotesL, @@ -122,6 +123,8 @@ import Control.State.Transition.Extended ( tellEvent, (?!), ) +import Data.Bifunctor (bimap) +import Data.Either (partitionEithers) import qualified Data.Foldable as F import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.Map.Strict as Map @@ -540,12 +543,11 @@ govTransition = do 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, replacedVotes) = + let knownVotes = [(voter, gas) | (voter, _vote, gas) <- knownVotesWithCast] + (unknownGovActionIds, !knownVotesWithCast, replacedVotes) = foldrVotingProcedures -- strictness is not needed for `unknown` or `replaced` - ( \voter gaId _ (unknown, !known, replaced) -> + ( \voter gaId vp (unknown, !known, replaced) -> case Map.lookup gaId curGovActionIds of Just gas -> let isVoteReplaced = @@ -556,19 +558,22 @@ govTransition = do replaced' | isVoteReplaced = Set.insert (voter, gaId) replaced | otherwise = replaced - in (unknown, (voter, gas) : known, replaced') + in (unknown, (voter, vProcVote vp, gas) : known, replaced') Nothing -> (gaId : unknown, known, replaced) ) ([], [], Set.empty) - gsVotingProcedures + (VotingProcedures knownVoters) 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) + internVoter = \case + CommitteeVoter hotCred -> CommitteeVoter <$> internSet hotCred knownCommitteeMembers + DRepVoter cred -> DRepVoter <$> internMap cred knownDReps + StakePoolVoter poolId -> StakePoolVoter <$> internMap poolId knownStakePools + (unknownVoters, knownVoters) = + bimap Set.fromList Map.fromList $ + partitionEithers + [ maybe (Left voter) (\v -> Right (v, votes)) (internVoter voter) + | (voter, votes) <- Map.toList (unVotingProcedures gsVotingProcedures) + ] failOnNonEmpty unknownVoters VotersDoNotExist failOnNonEmpty unknownGovActionIds GovActionsDoNotExist @@ -577,11 +582,9 @@ govTransition = do runTest $ checkVotersAreValid currentEpoch committeeState knownVotes let - addVoterVote ps voter govActionId VotingProcedure {vProcVote} = - proposalsAddVote voter vProcVote govActionId ps - updatedProposalStates = - cleanupProposalVotes $ - foldlVotingProcedures addVoterVote proposals gsVotingProcedures + !updatedProposalStates = + let addVoterVote ps (voter, vote, gas) = proposalsAddVote voter vote (gasId gas) ps + in cleanupProposalVotes $ F.foldl' addVoterVote proposals knownVotesWithCast unregisteredDReps = let collectRemovals drepCreds = \case UnRegDRepTxCert drepCred _ -> Set.insert drepCred drepCreds 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 ef3b01d7e49..d5361a14608 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 @@ -762,15 +762,8 @@ votingSpec = submitFailingVote (StakePoolVoter poolId) gaId $ [injectFailure $ VotersDoNotExist [StakePoolVoter poolId]] dRepCred <- KeyHashObj <$> freshKeyHash - let votersDoNotExistFailure = injectFailure $ VotersDoNotExist [DRepVoter dRepCred] - vote <- arbitrary - submitBootstrapAwareFailingVote vote (DRepVoter dRepCred) gaId $ - FailBootstrapAndPostBootstrap $ - FailBoth - { bootstrapFailures = - [votersDoNotExistFailure, disallowedVoteFailure [(DRepVoter dRepCred, gaId)]] - , postBootstrapFailures = [votersDoNotExistFailure] - } + submitFailingVote (DRepVoter dRepCred) gaId $ + [injectFailure $ VotersDoNotExist [DRepVoter dRepCred]] it "DRep votes are removed" $ do pp <- getsNES $ nesEsL . curPParamsEpochStateL gaId <- submitGovAction InfoAction @@ -876,8 +869,6 @@ votingSpec = . constitutionAnchorL expectNoCurrentProposals conAnchor `shouldNotBe` anchor - where - disallowedVoteFailure = injectFailure . DisallowedVotesDuringBootstrap constitutionSpec :: forall era. diff --git a/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Decoding/Sharing.hs b/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Decoding/Sharing.hs index 8a4c502c566..612c6b86a32 100644 --- a/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Decoding/Sharing.hs +++ b/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Decoding/Sharing.hs @@ -19,6 +19,8 @@ module Cardano.Ledger.Binary.Decoding.Sharing ( interns, internsFromMap, internsFromVMap, + internMap, + internSet, toMemptyLens, decShareMonadCBOR, ) @@ -34,6 +36,7 @@ import Data.Kind import qualified Data.Map.Strict as Map (size) import Data.Map.Strict.Internal (Map (..)) import Data.Primitive.Types (Prim) +import qualified Data.Set.Internal as Set (Set (..)) import Data.VMap (VB, VMap, VP) import qualified Data.VMap as VMap import Lens.Micro @@ -72,18 +75,31 @@ interns (Interns is) !k = go is Nothing -> go xs {-# INLINE interns #-} +internMap :: Ord k => k -> Map k a -> Maybe k +internMap k = go + where + go Tip = Nothing + go (Bin _ kx _ l r) = + case compare k kx of + LT -> go l + GT -> go r + EQ -> Just kx + +internSet :: Ord a => a -> Set.Set a -> Maybe a +internSet k = go + where + go Set.Tip = Nothing + go (Set.Bin _ kx l r) = + case compare k kx of + LT -> go l + GT -> go r + EQ -> Just kx + internsFromMap :: Ord k => Map k a -> Interns k internsFromMap m = Interns [ Intern - { internMaybe = \k -> - let go Tip = Nothing - go (Bin _ kx _ l r) = - case compare k kx of - LT -> go l - GT -> go r - EQ -> Just kx - in go m + { internMaybe = (`internMap` m) , internWeight = Map.size m } ] From 7d456f3b214284615ed4bd5c5c969a982d4c6228 Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Thu, 23 Jan 2025 22:25:00 -0700 Subject: [PATCH 2/9] Avoid iterating over proposals when there is nothing to cleanup --- .../impl/src/Cardano/Ledger/Conway/Rules/Gov.hs | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) 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 2d7eb59e04b..b8ae3bbd45a 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Gov.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Gov.hs @@ -590,10 +590,13 @@ govTransition = do 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 + cleanupProposalVotes + -- optimization: avoid iterating over proposals when there is nothing to cleanup + | Set.null unregisteredDReps = id + | otherwise = + let cleanupVoters gas = + gas & gasDRepVotesL %~ (`Map.withoutKeys` unregisteredDReps) + in mapProposals cleanupVoters -- Report the event tellEvent $ GovNewProposals txid updatedProposalStates From b06a2d209fff54f077b13ef05822ad47a8bbbb41 Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Fri, 24 Jan 2025 00:09:08 -0700 Subject: [PATCH 3/9] Improve formatting and readability of GOV rule --- .../src/Cardano/Ledger/Conway/Rules/Gov.hs | 47 +++++++------------ 1 file changed, 17 insertions(+), 30 deletions(-) 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 b8ae3bbd45a..34cd6d90d35 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Gov.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Gov.hs @@ -481,13 +481,13 @@ govTransition = do _ -> pure () -- Deposit check - let expectedDep = pp ^. ppGovActionDepositL + let expectedDeposit = pp ^. ppGovActionDepositL in pProcDeposit - == expectedDep + == expectedDeposit ?! ProposalDepositIncorrect Mismatch { mismatchSupplied = pProcDeposit - , mismatchExpected = expectedDep + , mismatchExpected = expectedDeposit } -- Return address network id check @@ -497,44 +497,31 @@ govTransition = do -- Treasury withdrawal return address and committee well-formedness checks case pProcGovAction of - TreasuryWithdrawals wdrls proposalPolicy -> + TreasuryWithdrawals wdrls proposalPolicy -> do let mismatchedAccounts = Set.filter ((/= expectedNetworkId) . raNetwork) $ Map.keysSet wdrls - in do - Set.null mismatchedAccounts - ?! TreasuryWithdrawalsNetworkIdMismatch mismatchedAccounts expectedNetworkId + Set.null mismatchedAccounts + ?! TreasuryWithdrawalsNetworkIdMismatch mismatchedAccounts expectedNetworkId - -- Policy check - runTest $ checkPolicy @era constitutionPolicy proposalPolicy + -- Policy check + runTest $ checkPolicy @era constitutionPolicy proposalPolicy - unless (HF.bootstrapPhase (pp ^. ppProtocolVersionL)) $ - -- The sum of all withdrawals must be positive - F.fold wdrls /= mempty ?! ZeroTreasuryWithdrawals pProcGovAction + unless (HF.bootstrapPhase (pp ^. ppProtocolVersionL)) $ + -- The sum of all withdrawals must be positive + F.fold wdrls /= mempty ?! ZeroTreasuryWithdrawals pProcGovAction UpdateCommittee _mPrevGovActionId membersToRemove membersToAdd _qrm -> do - checkConflictingUpdate - checkExpirationEpoch - where - checkConflictingUpdate = - let conflicting = - Set.intersection - (Map.keysSet membersToAdd) - membersToRemove - in Set.null conflicting ?! ConflictingCommitteeUpdate conflicting - checkExpirationEpoch = - let invalidMembers = Map.filter (<= currentEpoch) membersToAdd - in Map.null invalidMembers ?! ExpirationEpochTooSmall invalidMembers + let conflicting = Set.intersection (Map.keysSet membersToAdd) membersToRemove + in Set.null conflicting ?! ConflictingCommitteeUpdate conflicting + + let invalidMembers = Map.filter (<= currentEpoch) membersToAdd + in Map.null invalidMembers ?! ExpirationEpochTooSmall invalidMembers ParameterChange _ _ proposalPolicy -> runTest $ checkPolicy @era constitutionPolicy proposalPolicy _ -> pure () -- Ancestry checks and accept proposal let expiry = pp ^. ppGovActionLifetimeL - actionState = - mkGovActionState - newGaid - proposal - expiry - currentEpoch + actionState = mkGovActionState newGaid proposal expiry currentEpoch in case proposalsAddAction actionState ps of Just updatedPs -> pure updatedPs Nothing -> ps <$ failBecause (InvalidPrevGovActionId proposal) From a63101d592bab83e5722baed23035b9593f5b531 Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Thu, 9 Jan 2025 20:07:04 -0700 Subject: [PATCH 4/9] Adjust ledger-state to use ConwayEra --- libs/ledger-state/ledger-state.cabal | 1 + libs/ledger-state/src/Cardano/Ledger/State/Orphans.hs | 5 +++++ libs/ledger-state/src/Cardano/Ledger/State/Query.hs | 4 ++-- libs/ledger-state/src/Cardano/Ledger/State/Schema.hs | 3 ++- libs/ledger-state/src/Cardano/Ledger/State/UTxO.hs | 4 ++-- 5 files changed, 12 insertions(+), 5 deletions(-) diff --git a/libs/ledger-state/ledger-state.cabal b/libs/ledger-state/ledger-state.cabal index 13dd4872465..cfe67e5a628 100644 --- a/libs/ledger-state/ledger-state.cabal +++ b/libs/ledger-state/ledger-state.cabal @@ -42,6 +42,7 @@ library cardano-ledger-alonzo, cardano-ledger-babbage, cardano-ledger-binary, + cardano-ledger-conway, cardano-ledger-core, cardano-ledger-mary, cardano-ledger-shelley, diff --git a/libs/ledger-state/src/Cardano/Ledger/State/Orphans.hs b/libs/ledger-state/src/Cardano/Ledger/State/Orphans.hs index 2eadabe2b7b..b5679962e74 100644 --- a/libs/ledger-state/src/Cardano/Ledger/State/Orphans.hs +++ b/libs/ledger-state/src/Cardano/Ledger/State/Orphans.hs @@ -14,6 +14,7 @@ import Cardano.Ledger.Babbage.TxBody import Cardano.Ledger.BaseTypes (TxIx (..)) import Cardano.Ledger.Binary import Cardano.Ledger.Coin +import Cardano.Ledger.Conway.Governance import Cardano.Ledger.Core import Cardano.Ledger.Credential import Cardano.Ledger.Hashes (unsafeMakeSafeHash) @@ -118,6 +119,10 @@ deriving via Enc (ShelleyGovState CurrentEra) instance PersistField (ShelleyGovS deriving via Enc (ShelleyGovState CurrentEra) instance PersistFieldSql (ShelleyGovState CurrentEra) +deriving via Enc (ConwayGovState CurrentEra) instance PersistField (ConwayGovState CurrentEra) + +deriving via Enc (ConwayGovState CurrentEra) instance PersistFieldSql (ConwayGovState CurrentEra) + deriving via Enc (AlonzoTxOut CurrentEra) instance PersistField (AlonzoTxOut CurrentEra) deriving via Enc (AlonzoTxOut CurrentEra) instance PersistFieldSql (AlonzoTxOut CurrentEra) diff --git a/libs/ledger-state/src/Cardano/Ledger/State/Query.hs b/libs/ledger-state/src/Cardano/Ledger/State/Query.hs index 3022877a3e3..7a51401de9c 100644 --- a/libs/ledger-state/src/Cardano/Ledger/State/Query.hs +++ b/libs/ledger-state/src/Cardano/Ledger/State/Query.hs @@ -65,7 +65,7 @@ insertUTxOState Shelley.UTxOState {..} = do UtxoState { utxoStateDeposited = utxosDeposited , utxoStateFees = utxosFees - , utxoStatePpups = utxosGovState + , utxoStateGovState = utxosGovState , utxoStateDonation = utxosDonation } @@ -515,7 +515,7 @@ getLedgerState utxo LedgerState {..} dstate = do utxo utxoStateDeposited utxoStateFees - utxoStatePpups -- Maintain invariant + utxoStateGovState -- Maintain invariant utxoStateDonation , Shelley.lsCertState = Shelley.CertState diff --git a/libs/ledger-state/src/Cardano/Ledger/State/Schema.hs b/libs/ledger-state/src/Cardano/Ledger/State/Schema.hs index 827ee4d89f4..6dd70affb9f 100644 --- a/libs/ledger-state/src/Cardano/Ledger/State/Schema.hs +++ b/libs/ledger-state/src/Cardano/Ledger/State/Schema.hs @@ -18,6 +18,7 @@ import Cardano.Ledger.Babbage.TxOut (BabbageTxOut) import Cardano.Ledger.BaseTypes (TxIx (..)) import Cardano.Ledger.Coin import Cardano.Ledger.Core (PParams) +import Cardano.Ledger.Conway.Governance import qualified Cardano.Ledger.Credential as Credential import qualified Cardano.Ledger.Keys as Keys import qualified Cardano.Ledger.PoolParams as Shelley @@ -78,7 +79,7 @@ LedgerState UtxoState deposited Coin fees Coin - ppups (Shelley.ShelleyGovState CurrentEra) + govState (ConwayGovState CurrentEra) donation Coin DState fGenDelegs FGenDelegs diff --git a/libs/ledger-state/src/Cardano/Ledger/State/UTxO.hs b/libs/ledger-state/src/Cardano/Ledger/State/UTxO.hs index acef138020a..fdc8d9985e2 100644 --- a/libs/ledger-state/src/Cardano/Ledger/State/UTxO.hs +++ b/libs/ledger-state/src/Cardano/Ledger/State/UTxO.hs @@ -14,7 +14,7 @@ module Cardano.Ledger.State.UTxO where import Cardano.Ledger.Address import Cardano.Ledger.Alonzo.TxBody -import Cardano.Ledger.Babbage +import Cardano.Ledger.Conway import Cardano.Ledger.BaseTypes import Cardano.Ledger.Binary.Plain as Plain import Cardano.Ledger.Coin @@ -46,7 +46,7 @@ import Lens.Micro import Prettyprinter import Text.Printf -type CurrentEra = BabbageEra +type CurrentEra = ConwayEra --- Loading readNewEpochState :: From 84af9f6b09187368f84ba605cf78f909e89af0bf Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Sun, 29 Dec 2024 21:24:44 -0700 Subject: [PATCH 5/9] Implement sharing for Conway related deserializers --- .../src/Cardano/Ledger/Conway/Governance.hs | 13 +++++-- .../Ledger/Conway/Governance/Procedures.hs | 11 +++++- .../Ledger/Conway/Governance/Proposals.hs | 17 ++++++++- .../src/Cardano/Ledger/Shelley/Governance.hs | 16 ++++++++ .../Ledger/Shelley/LedgerState/Types.hs | 38 +++++++++++-------- libs/cardano-data/CHANGELOG.md | 4 +- libs/cardano-data/cardano-data.cabal | 2 +- libs/cardano-data/src/Data/OMap/Strict.hs | 17 ++++++--- .../Cardano/Ledger/Binary/Decoding/Sharing.hs | 11 ++++++ .../src/Cardano/Ledger/CertState.hs | 33 +++++++++++++--- .../src/Cardano/Ledger/DRep.hs | 16 +++++++- .../src/Cardano/Ledger/UMap.hs | 18 +++++---- 12 files changed, 150 insertions(+), 46 deletions(-) diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Governance.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Governance.hs index 605c804ba47..efc5e478437 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Governance.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Governance.hs @@ -191,6 +191,7 @@ import Cardano.Ledger.Binary ( DecShareCBOR (..), EncCBOR (..), FromCBOR (..), + Interns, ToCBOR (..), decNoShareCBOR, ) @@ -351,12 +352,18 @@ mkEnactState gs = , ensPrevGovActionIds = govStatePrevGovActionIds gs } --- TODO: Implement Sharing: https://github.com/intersectmbo/cardano-ledger/issues/3486 instance EraPParams era => DecShareCBOR (ConwayGovState era) where - decShareCBOR _ = + type + Share (ConwayGovState era) = + ( Interns (Credential 'Staking) + , Interns (KeyHash 'StakePool) + , Interns (Credential 'DRepRole) + , Interns (Credential 'HotCommitteeRole) + ) + decShareCBOR is = decode $ RecD ConwayGovState - NoThunks (GovActionState era) instance EraPParams era => NFData (GovActionState era) --- TODO: Implement Sharing: https://github.com/intersectmbo/cardano-ledger/issues/3486 instance EraPParams era => DecShareCBOR (GovActionState era) where + type + Share (GovActionState era) = + ( Interns (Credential 'Staking) + , Interns (KeyHash 'StakePool) + , Interns (Credential 'DRepRole) + , Interns (Credential 'HotCommitteeRole) + ) decShareCBOR _ = decode $ RecD GovActionState 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 7451f8c4c79..350516cb5dc 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Governance/Proposals.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Governance/Proposals.hs @@ -15,6 +15,7 @@ {-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -- | This module isolates all the types and functionality around @@ -125,6 +126,8 @@ import Cardano.Ledger.Binary ( DecCBOR (..), DecShareCBOR (..), EncCBOR (..), + Interns, + decodeListLenOf, ) import Cardano.Ledger.Coin (Coin, CompactForm (CompactCoin)) import Cardano.Ledger.Conway.Governance.Procedures @@ -359,9 +362,19 @@ instance EraPParams era => EncCBOR (Proposals era) where instance EraPParams era => DecCBOR (Proposals era) where decCBOR = decCBOR >>= uncurry mkProposals --- TODO: Implement Sharing: https://github.com/intersectmbo/cardano-ledger/issues/3486 instance EraPParams era => DecShareCBOR (Proposals era) where - decShareCBOR _ = decCBOR + type + Share (Proposals era) = + ( Interns (Credential 'Staking) + , Interns (KeyHash 'StakePool) + , Interns (Credential 'DRepRole) + , Interns (Credential 'HotCommitteeRole) + ) + decShareCBOR is = do + decodeListLenOf 2 + gaid <- decCBOR + omap <- OMap.decodeOMap (decShareCBOR is) + mkProposals gaid omap -- | Add a vote to an existing `GovActionState`. This is a no-op if the -- provided `GovActionId` does not already exist diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Governance.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Governance.hs index 0c528c9f9eb..db6c07c45b8 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Governance.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Governance.hs @@ -10,6 +10,7 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableSuperClasses #-} @@ -36,12 +37,14 @@ import Cardano.Ledger.Binary ( DecShareCBOR (..), EncCBOR (encCBOR), FromCBOR (..), + Interns, ToCBOR (..), decNoShareCBOR, ) import Cardano.Ledger.Binary.Coders (Decode (..), Encode (..), decode, encode, (!>), ( DecShareCBOR (ShelleyGovState era) where + type + Share (ShelleyGovState era) = + ( Interns (Credential 'Staking) + , Interns (KeyHash 'StakePool) + , Interns (Credential 'DRepRole) + , Interns (Credential 'HotCommitteeRole) + ) decShareCBOR _ = decode $ RecD ShelleyGovState diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState/Types.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState/Types.hs index 16526aea33f..a7d42759a20 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState/Types.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState/Types.hs @@ -33,8 +33,8 @@ import Cardano.Ledger.Binary ( FromCBOR (..), Interns, ToCBOR (..), - decNoShareCBOR, decShareLensCBOR, + decSharePlusLensCBOR, decodeRecordNamed, decodeRecordNamedT, encodeListLen, @@ -179,7 +179,9 @@ instance flip evalStateT mempty $ do esAccountState <- lift decCBOR esLState <- decSharePlusCBOR - esSnapshots <- decSharePlusCBOR + esSnapshots <- + decSharePlusLensCBOR $ + lens (\(cs, ks, _, _) -> (cs, ks)) (\(_, _, cd, ch) (cs, ks) -> (cs, ks, cd, ch)) esNonMyopic <- decShareLensCBOR _2 pure EpochState {esAccountState, esSnapshots, esLState, esNonMyopic} @@ -330,21 +332,21 @@ instance !> To sd !> To don -instance - ( EraTxOut era - , EraGov era - ) => - DecShareCBOR (UTxOState era) - where - type Share (UTxOState era) = Interns (Credential 'Staking) - decShareCBOR credInterns = +instance (EraTxOut era, EraGov era) => DecShareCBOR (UTxOState era) where + type + Share (UTxOState era) = + ( Interns (Credential 'Staking) + , Interns (KeyHash 'StakePool) + , Interns (Credential 'DRepRole) + , Interns (Credential 'HotCommitteeRole) + ) + decShareCBOR is@(cs, _, _, _) = decodeRecordNamed "UTxOState" (const 6) $ do - utxosUtxo <- decShareCBOR credInterns + utxosUtxo <- decShareCBOR cs utxosDeposited <- decCBOR utxosFees <- decCBOR - -- TODO: implement proper sharing: https://github.com/intersectmbo/cardano-ledger/issues/3486 - utxosGovState <- decNoShareCBOR - utxosStakeDistr <- decShareCBOR credInterns + utxosGovState <- decShareCBOR is + utxosStakeDistr <- decShareCBOR cs utxosDonation <- decCBOR pure UTxOState {..} @@ -531,11 +533,15 @@ instance where type Share (LedgerState era) = - (Interns (Credential 'Staking), Interns (KeyHash 'StakePool)) + ( Interns (Credential 'Staking) + , Interns (KeyHash 'StakePool) + , Interns (Credential 'DRepRole) + , Interns (Credential 'HotCommitteeRole) + ) decSharePlusCBOR = decodeRecordNamedT "LedgerState" (const 2) $ do lsCertState <- decSharePlusCBOR - lsUTxOState <- decShareLensCBOR _1 + lsUTxOState <- decSharePlusCBOR pure LedgerState {lsUTxOState, lsCertState} instance (EraTxOut era, EraGov era) => ToCBOR (LedgerState era) where diff --git a/libs/cardano-data/CHANGELOG.md b/libs/cardano-data/CHANGELOG.md index 29510b3dd59..e6cc2fe61fc 100644 --- a/libs/cardano-data/CHANGELOG.md +++ b/libs/cardano-data/CHANGELOG.md @@ -1,8 +1,8 @@ # Version history for `cardano-data` -## 1.2.3.2 +## 1.2.4.0 -* +* Add `decodeOMap` ## 1.2.3.1 diff --git a/libs/cardano-data/cardano-data.cabal b/libs/cardano-data/cardano-data.cabal index a0d732da6a9..c29be732be4 100644 --- a/libs/cardano-data/cardano-data.cabal +++ b/libs/cardano-data/cardano-data.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: cardano-data -version: 1.2.3.1 +version: 1.2.4.0 license: Apache-2.0 maintainer: operations@iohk.io author: IOHK diff --git a/libs/cardano-data/src/Data/OMap/Strict.hs b/libs/cardano-data/src/Data/OMap/Strict.hs index 64c17a24d11..11535d3099e 100644 --- a/libs/cardano-data/src/Data/OMap/Strict.hs +++ b/libs/cardano-data/src/Data/OMap/Strict.hs @@ -44,11 +44,13 @@ module Data.OMap.Strict ( extractKeys, adjust, filter, + decodeOMap, ) where import Cardano.Ledger.Binary ( DecCBOR, + Decoder, EncCBOR (encCBOR), decodeListLenOrIndef, decodeListLikeEnforceNoDuplicates, @@ -419,12 +421,15 @@ instance (Typeable k, EncCBOR v, Ord k) => EncCBOR (OMap k v) where encCBOR omap = encodeStrictSeq encCBOR (toStrictSeq omap) instance (Typeable k, HasOKey k v, DecCBOR v, Eq v) => DecCBOR (OMap k v) where - decCBOR = - decodeListLikeEnforceNoDuplicates - decodeListLenOrIndef - (flip snoc) - (\omap -> (size omap, omap)) - decCBOR + decCBOR = decodeOMap decCBOR + +decodeOMap :: HasOKey k v => Decoder s v -> Decoder s (OMap k v) +decodeOMap decValue = + decodeListLikeEnforceNoDuplicates + decodeListLenOrIndef + (flip snoc) + (\omap -> (size omap, omap)) + decValue -- | \( O(n \log n) \) filter :: Ord k => (v -> Bool) -> OMap k v -> OMap k v diff --git a/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Decoding/Sharing.hs b/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Decoding/Sharing.hs index 612c6b86a32..3f97fc55ff4 100644 --- a/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Decoding/Sharing.hs +++ b/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Decoding/Sharing.hs @@ -17,6 +17,7 @@ module Cardano.Ledger.Binary.Decoding.Sharing ( decSharePlusLensCBOR, decNoShareCBOR, interns, + internsFromSet, internsFromMap, internsFromVMap, internMap, @@ -36,6 +37,7 @@ import Data.Kind import qualified Data.Map.Strict as Map (size) import Data.Map.Strict.Internal (Map (..)) import Data.Primitive.Types (Prim) +import qualified Data.Set as Set (size) import qualified Data.Set.Internal as Set (Set (..)) import Data.VMap (VB, VMap, VP) import qualified Data.VMap as VMap @@ -95,6 +97,15 @@ internSet k = go GT -> go r EQ -> Just kx +internsFromSet :: Ord k => Set.Set k -> Interns k +internsFromSet m = + Interns + [ Intern + { internMaybe = (`internSet` m) + , internWeight = Set.size m + } + ] + internsFromMap :: Ord k => Map k a -> Interns k internsFromMap m = Interns diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/CertState.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/CertState.hs index 02de838c03e..cabfcbbcdf6 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/CertState.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/CertState.hs @@ -75,6 +75,7 @@ import Cardano.Ledger.Binary ( decodeRecordNamed, decodeRecordNamedT, encodeListLen, + internsFromSet, toMemptyLens, ) import Cardano.Ledger.Binary.Coders (Decode (..), Encode (..), decode, encode, (!>), ( EncCBOR (DState era) where <> encCBOR ir instance DecShareCBOR (DState era) where - type Share (DState era) = (Interns (Credential 'Staking), Interns (KeyHash 'StakePool)) + type + Share (DState era) = + (Interns (Credential 'Staking), Interns (KeyHash 'StakePool), Interns (Credential 'DRepRole)) decSharePlusCBOR = decodeRecordNamedT "DState" (const 4) $ do unified <- decSharePlusCBOR @@ -316,8 +319,9 @@ authorizedHotCommitteeCredentials CommitteeState {csCommitteeCreds} = CommitteeMemberResigned {} -> acc in F.foldl' toHotCredSet Set.empty csCommitteeCreds --- TODO: Implement sharing: https://github.com/intersectmbo/cardano-ledger/issues/3486 instance Era era => DecShareCBOR (CommitteeState era) where + type Share (CommitteeState era) = Interns (Credential 'HotCommitteeRole) + getShare = internsFromSet . authorizedHotCommitteeCredentials decShareCBOR _ = CommitteeState <$> decCBOR instance Era era => DecCBOR (CommitteeState era) where @@ -353,8 +357,15 @@ instance NoThunks (VState era) instance NFData (VState era) --- TODO: Implement sharing: https://github.com/intersectmbo/cardano-ledger/issues/3486 instance Era era => DecShareCBOR (VState era) where + type + Share (VState era) = + ( Interns (Credential 'Staking) + , Interns (Credential 'DRepRole) + , Interns (Credential 'HotCommitteeRole) + ) + getShare VState {vsDReps, vsCommitteeState} = + (internsFromSet (foldMap drepDelegs vsDReps), fst (getShare vsDReps), getShare vsCommitteeState) decShareCBOR _ = decode $ RecD VState @@ -408,11 +419,21 @@ instance Era era => EncCBOR (CertState era) where <> encCBOR certDState instance Era era => DecShareCBOR (CertState era) where - type Share (CertState era) = (Interns (Credential 'Staking), Interns (KeyHash 'StakePool)) + type + Share (CertState era) = + ( Interns (Credential 'Staking) + , Interns (KeyHash 'StakePool) + , Interns (Credential 'DRepRole) + , Interns (Credential 'HotCommitteeRole) + ) decSharePlusCBOR = decodeRecordNamedT "CertState" (const 3) $ do - certVState <- lift decNoShareCBOR -- TODO: add sharing of DRep credentials + certVState <- + decSharePlusLensCBOR $ + lens (\(cs, _, cd, ch) -> (cs, cd, ch)) (\(_, ks, _, _) (cs, cd, ch) -> (cs, ks, cd, ch)) certPState <- decSharePlusLensCBOR _2 - certDState <- decSharePlusCBOR + certDState <- + decSharePlusLensCBOR $ + lens (\(cs, ks, cd, _) -> (cs, ks, cd)) (\(_, _, _, ch) (cs, ks, cd) -> (cs, ks, cd, ch)) pure CertState {certPState, certDState, certVState} instance Default (CertState era) where diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/DRep.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/DRep.hs index b4fdac3a356..a2eb4699a7f 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/DRep.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/DRep.hs @@ -5,6 +5,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} module Cardano.Ledger.DRep ( @@ -17,7 +18,7 @@ module Cardano.Ledger.DRep ( ) where import Cardano.Ledger.BaseTypes -import Cardano.Ledger.Binary (DecCBOR (..), EncCBOR (..)) +import Cardano.Ledger.Binary (DecCBOR (..), DecShareCBOR (..), EncCBOR (..), Interns, interns) import Cardano.Ledger.Binary.Coders (Decode (..), Encode (..), decode, encode, (!>), ( SumD DRepAlwaysNoConfidence k -> Invalid k +instance DecShareCBOR DRep where + type Share DRep = Interns (Credential 'DRepRole) + decShareCBOR cd = do + dRep <- decCBOR + pure $! + case dRepToCred dRep of + Nothing -> dRep + Just cred -> credToDRep $ interns cd cred + dRepToCred :: DRep -> Maybe (Credential 'DRepRole) dRepToCred (DRepKeyHash kh) = Just $ KeyHashObj kh dRepToCred (DRepScriptHash sh) = Just $ ScriptHashObj sh dRepToCred _ = Nothing +credToDRep :: Credential 'DRepRole -> DRep +credToDRep (KeyHashObj kh) = DRepKeyHash kh +credToDRep (ScriptHashObj sh) = DRepScriptHash sh + instance ToJSON DRep where toJSON = String . dRepToText diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/UMap.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/UMap.hs index a97aa4e1888..98770bde3bd 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/UMap.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/UMap.hs @@ -238,14 +238,14 @@ instance EncCBOR UMElem where encodeListLen 4 <> encCBOR rd <> encCBOR ptrSet <> encCBOR sPool <> encCBOR dRep instance DecShareCBOR UMElem where - type Share UMElem = Interns (KeyHash 'StakePool) - decShareCBOR is = + type Share UMElem = (Interns (KeyHash 'StakePool), Interns (Credential 'DRepRole)) + decShareCBOR (ks, cd) = decodeRecordNamed "UMElem" (const 4) $ UMElem <$> decCBOR <*> ifDecoderVersionAtLeast (natVersion @9) (mempty <$ dropCBOR (Proxy @(Set Ptr))) decCBOR - <*> decShareMonadCBOR is - <*> decCBOR + <*> decShareMonadCBOR ks + <*> decodeStrictMaybe (decShareCBOR cd) -- | A n-Tuple view of the `UMElem`. -- We can view all of the constructors as an `UMElem`. @@ -460,19 +460,21 @@ instance EncCBOR UMap where encodeListLen 2 <> encodeMap encCBOR encCBOR umElems <> encodeMap encCBOR encCBOR umPtrs instance DecShareCBOR UMap where - type Share UMap = (Interns (Credential 'Staking), Interns (KeyHash 'StakePool)) + type + Share UMap = + (Interns (Credential 'Staking), Interns (KeyHash 'StakePool), Interns (Credential 'DRepRole)) decSharePlusCBOR = StateT - ( \(a, b) -> + ( \(a, b, c) -> decodeRecordNamed "UMap" (const 2) $ do - umElems <- decodeMap (interns a <$> decCBOR) (decShareCBOR b) + umElems <- decodeMap (interns a <$> decCBOR) (decShareCBOR (b, c)) let a' = internsFromMap umElems <> a umPtrs <- ifDecoderVersionAtLeast (natVersion @9) (mempty <$ dropCBOR (Proxy @(Map (Credential 'Staking) (Set Ptr)))) $ decodeMap decCBOR (interns a' <$> decCBOR) - pure (UMap {umElems, umPtrs}, (a', b)) + pure (UMap {umElems, umPtrs}, (a', b, c)) ) -- | It is worthwhile stating the invariant that holds on a Unified Map. From 5625b9268b8c246acb71460abb0c84da68161b9e Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Thu, 9 Jan 2025 14:45:49 -0700 Subject: [PATCH 6/9] Most of sharing for DRepPulser --- .../src/Cardano/Ledger/Conway/Governance.hs | 2 +- .../Ledger/Conway/Governance/DRepPulser.hs | 43 ++++++++++++------- .../Ledger/Conway/Governance/Internal.hs | 29 +++++++++---- 3 files changed, 49 insertions(+), 25 deletions(-) diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Governance.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Governance.hs index efc5e478437..46ccf08b6c7 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Governance.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Governance.hs @@ -369,7 +369,7 @@ instance EraPParams era => DecShareCBOR (ConwayGovState era) where DecCBOR (ConwayGovState era) where decCBOR = decNoShareCBOR diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Governance/DRepPulser.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Governance/DRepPulser.hs index 946c9deec67..9209b0f303a 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Governance/DRepPulser.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Governance/DRepPulser.hs @@ -43,7 +43,12 @@ import Cardano.Ledger.Binary ( DecShareCBOR (..), EncCBOR (..), FromCBOR (..), + Interns, ToCBOR (..), + decNoShareCBOR, + decodeMap, + decodeStrictSeq, + interns, ) import Cardano.Ledger.Binary.Coders ( Decode (..), @@ -146,24 +151,24 @@ instance EraPParams era => EncCBOR (PulsingSnapshot era) where !> To psDRepState !> To psPoolDistr --- TODO: Implement Sharing: https://github.com/intersectmbo/cardano-ledger/issues/3486 instance EraPParams era => DecShareCBOR (PulsingSnapshot era) where - decShareCBOR _ = + type + Share (PulsingSnapshot era) = + ( Interns (Credential 'Staking) + , Interns (KeyHash 'StakePool) + , Interns (Credential 'DRepRole) + , Interns (Credential 'HotCommitteeRole) + ) + decShareCBOR is@(_, ks, cd, _) = decode $ RecD PulsingSnapshot - decCBOR) decCBOR) --TODO: implement sharing for DRepState + decCBOR) decCBOR) instance EraPParams era => DecCBOR (PulsingSnapshot era) where - decCBOR = - decode $ - RecD PulsingSnapshot - ToCBOR (PulsingSnapshot era) where toCBOR = toEraCBOR @era @@ -436,13 +441,19 @@ instance EraPParams era => EncCBOR (DRepPulsingState era) where where (snap, ratstate) = finishDRepPulser x --- TODO: Implement Sharing: https://github.com/intersectmbo/cardano-ledger/issues/3486 instance EraPParams era => DecShareCBOR (DRepPulsingState era) where - decShareCBOR _ = + type + Share (DRepPulsingState era) = + ( Interns (Credential 'Staking) + , Interns (KeyHash 'StakePool) + , Interns (Credential 'DRepRole) + , Interns (Credential 'HotCommitteeRole) + ) + decShareCBOR is = decode $ RecD DRComplete DecCBOR (DRepPulsingState era) where decCBOR = decode (RecD DRComplete Default (EnactState era) where instance EraPParams era => DecCBOR (EnactState era) where decCBOR = decNoShareCBOR --- TODO: Implement Sharing: https://github.com/intersectmbo/cardano-ledger/issues/3486 instance EraPParams era => DecShareCBOR (EnactState era) where - decShareCBOR _ = + type Share (EnactState era) = Interns (Credential 'Staking) + decShareCBOR is = decode $ RecD EnactState DecShareCBOR (EnactState era) where decCBOR) decCBOR) EncCBOR (EnactState era) where @@ -263,7 +268,9 @@ data RatifyState era = RatifyState -- ^ This is the currently active `EnactState`. It contains all the changes -- that were applied to it at the last epoch boundary by all the proposals -- that were enacted. - , rsEnacted :: !(Seq (GovActionState era)) + , -- TODO: switch rsEnacted to StrictSeq for the sake of avoiding + -- space leaks during ledger state deserialization + rsEnacted :: !(Seq (GovActionState era)) -- ^ Governance actions that are going to be enacted at the next epoch -- boundary. , rsExpired :: !(Set GovActionId) @@ -678,12 +685,18 @@ instance EraPParams era => DecCBOR (RatifySignal era) where instance EraPParams era => DecCBOR (RatifyState era) where decCBOR = decode (RecD RatifyState DecShareCBOR (RatifyState era) where - decShareCBOR _ = + type + Share (RatifyState era) = + ( Interns (Credential 'Staking) + , Interns (KeyHash 'StakePool) + , Interns (Credential 'DRepRole) + , Interns (Credential 'HotCommitteeRole) + ) + decShareCBOR is@(cs, _, _, _) = decode $ RecD RatifyState - Date: Thu, 9 Jan 2025 15:32:17 -0700 Subject: [PATCH 7/9] Complete sharing during deserialization of DRepPulser --- .../Ledger/Conway/Governance/DRepPulser.hs | 6 +++--- .../Cardano/Ledger/Binary/Decoding/Sharing.hs | 5 +++++ .../src/Cardano/Ledger/CertState.hs | 6 ++++-- .../src/Cardano/Ledger/DRep.hs | 19 ++++++++++++++++--- 4 files changed, 28 insertions(+), 8 deletions(-) diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Governance/DRepPulser.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Governance/DRepPulser.hs index 9209b0f303a..a1955bb1eb6 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Governance/DRepPulser.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Governance/DRepPulser.hs @@ -159,12 +159,12 @@ instance EraPParams era => DecShareCBOR (PulsingSnapshot era) where , Interns (Credential 'DRepRole) , Interns (Credential 'HotCommitteeRole) ) - decShareCBOR is@(_, ks, cd, _) = + decShareCBOR is@(cs, ks, cd, _) = decode $ RecD PulsingSnapshot decCBOR) decCBOR) --TODO: implement sharing for DRepState + decCBOR) (decShareCBOR cs)) decCBOR) decCBOR) instance EraPParams era => DecCBOR (PulsingSnapshot era) where @@ -452,7 +452,7 @@ instance EraPParams era => DecShareCBOR (DRepPulsingState era) where decShareCBOR is = decode $ RecD DRComplete - DecCBOR (DRepPulsingState era) where diff --git a/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Decoding/Sharing.hs b/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Decoding/Sharing.hs index 3f97fc55ff4..27fcf2bc2c7 100644 --- a/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Decoding/Sharing.hs +++ b/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Decoding/Sharing.hs @@ -206,6 +206,11 @@ decSharePlusLensCBOR l = do decNoShareCBOR :: DecShareCBOR a => Decoder s a decNoShareCBOR = decShareCBOR mempty +instance (Ord k, DecCBOR k) => DecShareCBOR (Set.Set k) where + type Share (Set.Set k) = Interns k + decShareCBOR kis = decodeSet (interns kis <$> decCBOR) + getShare = internsFromSet + instance (Ord k, DecCBOR k, DecCBOR v) => DecShareCBOR (Map k v) where type Share (Map k v) = (Interns k, Interns v) decShareCBOR (kis, vis) = do diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/CertState.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/CertState.hs index cabfcbbcdf6..eef187537ad 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/CertState.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/CertState.hs @@ -72,9 +72,11 @@ import Cardano.Ledger.Binary ( decNoShareCBOR, decSharePlusCBOR, decSharePlusLensCBOR, + decodeMap, decodeRecordNamed, decodeRecordNamedT, encodeListLen, + interns, internsFromSet, toMemptyLens, ) @@ -366,10 +368,10 @@ instance Era era => DecShareCBOR (VState era) where ) getShare VState {vsDReps, vsCommitteeState} = (internsFromSet (foldMap drepDelegs vsDReps), fst (getShare vsDReps), getShare vsCommitteeState) - decShareCBOR _ = + decShareCBOR (cs, cd, _) = decode $ RecD VState - decCBOR) (decShareCBOR cs)) ), ( Date: Thu, 9 Jan 2025 21:04:32 -0700 Subject: [PATCH 8/9] Add sharing for GovActionState --- .../src/Cardano/Ledger/Conway/Governance/Procedures.hs | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) 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 0ae5b1a3968..ce61c0763d9 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Governance/Procedures.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Governance/Procedures.hs @@ -98,6 +98,7 @@ import Cardano.Ledger.Binary ( ToCBOR (toCBOR), decNoShareCBOR, decodeEnumBounded, + decodeMap, decodeMapByKey, decodeNullStrictMaybe, decodeRecordNamed, @@ -105,6 +106,7 @@ import Cardano.Ledger.Binary ( encodeListLen, encodeNullStrictMaybe, encodeWord8, + interns, invalidKey, ) import Cardano.Ledger.Binary.Coders ( @@ -291,13 +293,13 @@ instance EraPParams era => DecShareCBOR (GovActionState era) where , Interns (Credential 'DRepRole) , Interns (Credential 'HotCommitteeRole) ) - decShareCBOR _ = + decShareCBOR (cs, ks, cd, ch) = decode $ RecD GovActionState decCBOR) decCBOR) + decCBOR) decCBOR) + decCBOR) decCBOR) Date: Thu, 9 Jan 2025 23:21:45 -0700 Subject: [PATCH 9/9] Implement and confirm sharing for decoding `GovAction`s --- eras/conway/impl/cardano-ledger-conway.cabal | 1 + .../src/Cardano/Ledger/Conway/Governance.hs | 25 ++++--- .../Ledger/Conway/Governance/Procedures.hs | 33 +++++---- .../Ledger/Conway/Governance/Proposals.hs | 16 +++-- libs/cardano-data/src/Data/OMap/Strict.hs | 2 + libs/cardano-ledger-binary/CHANGELOG.md | 4 ++ .../Cardano/Ledger/Binary/Decoding/Decoder.hs | 33 +++++++++ .../Cardano/Ledger/Binary/Decoding/Sharing.hs | 70 ++++++++++--------- libs/cardano-ledger-core/CHANGELOG.md | 1 + .../src/Cardano/Ledger/State/Schema.hs | 2 +- .../src/Cardano/Ledger/State/UTxO.hs | 2 +- 11 files changed, 123 insertions(+), 66 deletions(-) diff --git a/eras/conway/impl/cardano-ledger-conway.cabal b/eras/conway/impl/cardano-ledger-conway.cabal index 8ca46934b68..0e20732f200 100644 --- a/eras/conway/impl/cardano-ledger-conway.cabal +++ b/eras/conway/impl/cardano-ledger-conway.cabal @@ -105,6 +105,7 @@ library deepseq, mempack, microlens, + mtl, nothunks, plutus-ledger-api >=1.37, set-algebra, diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Governance.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Governance.hs index 46ccf08b6c7..89050a0ecb1 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Governance.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Governance.hs @@ -194,14 +194,12 @@ import Cardano.Ledger.Binary ( Interns, ToCBOR (..), decNoShareCBOR, + decodeRecordNamedT, ) import Cardano.Ledger.Binary.Coders ( - Decode (..), Encode (..), - decode, encode, (!>), - ( DecShareCBOR (ConwayGovState era) where , Interns (Credential 'DRepRole) , Interns (Credential 'HotCommitteeRole) ) - decShareCBOR is = - decode $ - RecD ConwayGovState - DecCBOR (ConwayGovState era) where decCBOR = decNoShareCBOR 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 ce61c0763d9..844c32c760d 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Governance/Procedures.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Governance/Procedures.hs @@ -98,15 +98,15 @@ import Cardano.Ledger.Binary ( ToCBOR (toCBOR), decNoShareCBOR, decodeEnumBounded, - decodeMap, decodeMapByKey, decodeNullStrictMaybe, decodeRecordNamed, + decodeRecordNamedT, encodeEnum, encodeListLen, encodeNullStrictMaybe, encodeWord8, - interns, + internsFromMap, invalidKey, ) import Cardano.Ledger.Binary.Coders ( @@ -125,6 +125,8 @@ import Cardano.Ledger.TxIn (TxId (..)) import Cardano.Slotting.Slot (EpochNo) import Control.DeepSeq (NFData (..), deepseq) import Control.Monad (when) +import Control.Monad.Trans (lift) +import Control.Monad.Trans.State.Strict (get, put) import Data.Aeson ( FromJSON (..), KeyValue (..), @@ -293,16 +295,22 @@ instance EraPParams era => DecShareCBOR (GovActionState era) where , Interns (Credential 'DRepRole) , Interns (Credential 'HotCommitteeRole) ) - decShareCBOR (cs, ks, cd, ch) = - decode $ - RecD GovActionState - decCBOR) decCBOR) - decCBOR) decCBOR) - decCBOR) decCBOR) - internsFromMap gasStakePoolVotes, cd, ch <> internsFromMap gasCommitteeVotes) + + gasProposalProcedure <- lift decCBOR + gasProposedIn <- lift decCBOR + gasExpiresAfter <- lift decCBOR + pure GovActionState {..} instance EraPParams era => DecCBOR (GovActionState era) where decCBOR = decNoShareCBOR @@ -319,7 +327,6 @@ instance EraPParams era => EncCBOR (GovActionState era) where !> To gasProposedIn !> To gasExpiresAfter --- Ref: https://gitlab.haskell.org/ghc/ghc/-/issues/14046 instance OMap.HasOKey GovActionId (GovActionState era) where okeyL = lens gasId $ \gas gi -> gas {gasId = gi} 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 350516cb5dc..d09b3cc093b 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Governance/Proposals.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Governance/Proposals.hs @@ -127,7 +127,9 @@ import Cardano.Ledger.Binary ( DecShareCBOR (..), EncCBOR (..), Interns, - decodeListLenOf, + decodeListLenOrIndef, + decodeListLikeWithCountT, + decodeRecordNamedT, ) import Cardano.Ledger.Coin (Coin, CompactForm (CompactCoin)) import Cardano.Ledger.Conway.Governance.Procedures @@ -137,6 +139,7 @@ import Cardano.Ledger.UMap (addCompact, toCompact) import Control.DeepSeq (NFData) import Control.Exception (assert) import Control.Monad (unless) +import Control.Monad.Trans (lift) import Data.Aeson (ToJSON (..)) import Data.Default (Default (..)) import Data.Either (partitionEithers) @@ -370,11 +373,12 @@ instance EraPParams era => DecShareCBOR (Proposals era) where , Interns (Credential 'DRepRole) , Interns (Credential 'HotCommitteeRole) ) - decShareCBOR is = do - decodeListLenOf 2 - gaid <- decCBOR - omap <- OMap.decodeOMap (decShareCBOR is) - mkProposals gaid omap + decSharePlusCBOR = do + decodeRecordNamedT "Proposals" (const 2) $ do + gaid <- lift decCBOR + (_, omap) <- decodeListLikeWithCountT (lift decodeListLenOrIndef) (flip (OMap.|>)) $ \_ -> + decSharePlusCBOR + mkProposals gaid omap -- | Add a vote to an existing `GovActionState`. This is a no-op if the -- provided `GovActionId` does not already exist diff --git a/libs/cardano-data/src/Data/OMap/Strict.hs b/libs/cardano-data/src/Data/OMap/Strict.hs index 11535d3099e..f9235a6a596 100644 --- a/libs/cardano-data/src/Data/OMap/Strict.hs +++ b/libs/cardano-data/src/Data/OMap/Strict.hs @@ -173,6 +173,8 @@ cons' v (OMap sseq kv) infixr 5 <|| +-- TODO: export along with others that are hidden or remove them completely. + -- | \(O(\log n)\). Checks membership before snoc'ing. snoc :: HasOKey k v => OMap k v -> v -> OMap k v snoc omap@(OMap sseq kv) v diff --git a/libs/cardano-ledger-binary/CHANGELOG.md b/libs/cardano-ledger-binary/CHANGELOG.md index ca1fdcf4a9e..ae94829bc70 100644 --- a/libs/cardano-ledger-binary/CHANGELOG.md +++ b/libs/cardano-ledger-binary/CHANGELOG.md @@ -2,6 +2,10 @@ ## 1.6.0.0 +* Add `decodeListLikeWithCountT` +* Add `internMap`, `internSet`, ` internsFromSet` +* Add `DecShareCBOR` for `Set` +* Add `Semigroup` instance for `Interns` * Add `encodeMemPack` and `decodeMemPack` helper functions. * Remove `encodeSignKeyKES` and `decodeSignKeyKES` * Remove `EncCBOR` and `DecCBOR` instances for `SignKeyKES` diff --git a/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Decoding/Decoder.hs b/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Decoding/Decoder.hs index dd14a7b4d83..f4af27ecfa2 100644 --- a/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Decoding/Decoder.hs +++ b/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Decoding/Decoder.hs @@ -74,6 +74,7 @@ module Cardano.Ledger.Binary.Decoding.Decoder ( decodeStrictSeq, decodeSetTag, decodeListLikeWithCount, + decodeListLikeWithCountT, decodeSetLikeEnforceNoDuplicates, decodeListLikeEnforceNoDuplicates, decodeMapContents, @@ -907,6 +908,10 @@ decodeListLikeWithCount :: -- | Decoder for the values. Current accumulator is supplied as an argument (b -> Decoder s a) -> Decoder s (Int, b) +-- TODO: define as +-- decodeListLikeWithCount decodeLenOrIndef insert decodeElement = +-- runIndentityT $ decodeListLikeWithCountT (lift decodeLenOrIndef) insert (lift decodeElement) +-- and add a SPECIALIZE pragma decodeListLikeWithCount decodeLenOrIndef insert decodeElement = do decodeLenOrIndef >>= \case Just len -> loop (\x -> pure (x >= len)) 0 mempty @@ -925,6 +930,34 @@ decodeListLikeWithCount decodeLenOrIndef insert decodeElement = do {-# INLINE loop #-} {-# INLINE decodeListLikeWithCount #-} +decodeListLikeWithCountT :: + forall t s a b. + (MonadTrans t, Monad (t (Decoder s)), Monoid b) => + -- | Length decoder that produces the expected number of elements. When `Nothing` is + -- decoded the `decodeBreakOr` will be used as termination indicator. + t (Decoder s) (Maybe Int) -> + -- | Add an element into the decoded List like data structure + (a -> b -> b) -> + -- | Decoder for the values. Current accumulator is supplied as an argument + (b -> t (Decoder s) a) -> + t (Decoder s) (Int, b) +decodeListLikeWithCountT decodeLenOrIndef insert decodeElement = do + decodeLenOrIndef >>= \case + Just len -> loop (\x -> pure (x >= len)) 0 mempty + Nothing -> loop (\_ -> lift decodeBreakOr) 0 mempty + where + loop condition = go + where + go !count !acc = do + shouldStop <- condition count + if shouldStop + then pure (count, acc) + else do + element <- decodeElement acc + go (count + 1) (insert element acc) + {-# INLINE loop #-} +{-# INLINE decodeListLikeWithCountT #-} + -- | Decode a collection of values with ability to supply length decoder. Duplicates are not -- allowed. decodeListLikeEnforceNoDuplicates :: diff --git a/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Decoding/Sharing.hs b/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Decoding/Sharing.hs index 27fcf2bc2c7..32ffc42c286 100644 --- a/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Decoding/Sharing.hs +++ b/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Decoding/Sharing.hs @@ -66,6 +66,17 @@ data Intern a = Intern newtype Interns a = Interns [Intern a] deriving (Monoid) +instance Semigroup (Interns a) where + (<>) is1 (Interns []) = is1 + (<>) (Interns []) is2 = is2 + (<>) (Interns is1) (Interns is2) = + Interns (F.foldr insertIntoSortedInterns is2 is1) + where + insertIntoSortedInterns i [] = [i] + insertIntoSortedInterns i (a : as) + | internWeight a > internWeight i = a : insertIntoSortedInterns i as + | otherwise = i : a : as + interns :: Interns k -> k -> k interns (Interns []) !k = k -- optimize for common case when there are no interns interns (Interns is) !k = go is @@ -98,42 +109,37 @@ internSet k = go EQ -> Just kx internsFromSet :: Ord k => Set.Set k -> Interns k -internsFromSet m = - Interns - [ Intern - { internMaybe = (`internSet` m) - , internWeight = Set.size m - } - ] +internsFromSet s + | Set.size s == 0 = mempty + | otherwise = + Interns + [ Intern + { internMaybe = (`internSet` s) + , internWeight = Set.size s + } + ] internsFromMap :: Ord k => Map k a -> Interns k -internsFromMap m = - Interns - [ Intern - { internMaybe = (`internMap` m) - , internWeight = Map.size m - } - ] +internsFromMap m + | Map.size m == 0 = mempty + | otherwise = + Interns + [ Intern + { internMaybe = (`internMap` m) + , internWeight = Map.size m + } + ] internsFromVMap :: Ord k => VMap VB kv k a -> Interns k -internsFromVMap m = - Interns - [ Intern - { internMaybe = \k -> VMap.internMaybe k m - , internWeight = VMap.size m - } - ] - -instance Semigroup (Interns a) where - (<>) is1 (Interns []) = is1 - (<>) (Interns []) is2 = is2 - (<>) (Interns is1) (Interns is2) = - Interns (F.foldr insertIntoSortedInterns is2 is1) - where - insertIntoSortedInterns i [] = [i] - insertIntoSortedInterns i (a : as) - | internWeight a > internWeight i = a : insertIntoSortedInterns i as - | otherwise = i : a : as +internsFromVMap m + | VMap.size m == 0 = mempty + | otherwise = + Interns + [ Intern + { internMaybe = \k -> VMap.internMaybe k m + , internWeight = VMap.size m + } + ] class Monoid (Share a) => DecShareCBOR a where {-# MINIMAL (decShareCBOR | decSharePlusCBOR) #-} diff --git a/libs/cardano-ledger-core/CHANGELOG.md b/libs/cardano-ledger-core/CHANGELOG.md index 801869e0c4f..42863596219 100644 --- a/libs/cardano-ledger-core/CHANGELOG.md +++ b/libs/cardano-ledger-core/CHANGELOG.md @@ -2,6 +2,7 @@ ## 1.17.0.0 +* Add `DecShareCBOR` instances for `DRep` and `DRepState` * Added `ToPlutusData` instance for `NonZero` * `maxpool'` now expects `nOpt` to be a `NonZero Word16` * Add `HasZero` instance for `Coin` together with lifted conversion functions: diff --git a/libs/ledger-state/src/Cardano/Ledger/State/Schema.hs b/libs/ledger-state/src/Cardano/Ledger/State/Schema.hs index 6dd70affb9f..a16df48c1ce 100644 --- a/libs/ledger-state/src/Cardano/Ledger/State/Schema.hs +++ b/libs/ledger-state/src/Cardano/Ledger/State/Schema.hs @@ -17,8 +17,8 @@ module Cardano.Ledger.State.Schema where import Cardano.Ledger.Babbage.TxOut (BabbageTxOut) import Cardano.Ledger.BaseTypes (TxIx (..)) import Cardano.Ledger.Coin -import Cardano.Ledger.Core (PParams) import Cardano.Ledger.Conway.Governance +import Cardano.Ledger.Core (PParams) import qualified Cardano.Ledger.Credential as Credential import qualified Cardano.Ledger.Keys as Keys import qualified Cardano.Ledger.PoolParams as Shelley diff --git a/libs/ledger-state/src/Cardano/Ledger/State/UTxO.hs b/libs/ledger-state/src/Cardano/Ledger/State/UTxO.hs index fdc8d9985e2..8254bc22488 100644 --- a/libs/ledger-state/src/Cardano/Ledger/State/UTxO.hs +++ b/libs/ledger-state/src/Cardano/Ledger/State/UTxO.hs @@ -14,10 +14,10 @@ module Cardano.Ledger.State.UTxO where import Cardano.Ledger.Address import Cardano.Ledger.Alonzo.TxBody -import Cardano.Ledger.Conway import Cardano.Ledger.BaseTypes import Cardano.Ledger.Binary.Plain as Plain import Cardano.Ledger.Coin +import Cardano.Ledger.Conway import Cardano.Ledger.Core import Cardano.Ledger.Credential import Cardano.Ledger.EpochBoundary