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 605c804ba47..89050a0ecb1 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Governance.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Governance.hs @@ -191,16 +191,15 @@ import Cardano.Ledger.Binary ( DecShareCBOR (..), EncCBOR (..), FromCBOR (..), + Interns, ToCBOR (..), decNoShareCBOR, + decodeRecordNamedT, ) import Cardano.Ledger.Binary.Coders ( - Decode (..), Encode (..), - decode, encode, (!>), - ( DecShareCBOR (ConwayGovState era) where - decShareCBOR _ = - decode $ - RecD ConwayGovState - 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..a1955bb1eb6 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@(cs, ks, cd, _) = decode $ RecD PulsingSnapshot - decCBOR) (decShareCBOR cs)) + 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 - 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 - decShareCBOR _ = - decode $ - RecD GovActionState - 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 @@ -308,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 7451f8c4c79..d09b3cc093b 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,10 @@ import Cardano.Ledger.Binary ( DecCBOR (..), DecShareCBOR (..), EncCBOR (..), + Interns, + decodeListLenOrIndef, + decodeListLikeWithCountT, + decodeRecordNamedT, ) import Cardano.Ledger.Coin (Coin, CompactForm (CompactCoin)) import Cardano.Ledger.Conway.Governance.Procedures @@ -134,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) @@ -359,9 +365,20 @@ 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) + ) + 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/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Gov.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Gov.hs index 84b4a9b274d..34cd6d90d35 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 @@ -478,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 @@ -494,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) @@ -540,12 +530,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 +545,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,20 +569,21 @@ 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 _ -> 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 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/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..f9235a6a596 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, @@ -171,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 @@ -419,12 +423,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/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 8a4c502c566..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 @@ -17,8 +17,11 @@ module Cardano.Ledger.Binary.Decoding.Sharing ( decSharePlusLensCBOR, decNoShareCBOR, interns, + internsFromSet, internsFromMap, internsFromVMap, + internMap, + internSet, toMemptyLens, decShareMonadCBOR, ) @@ -34,6 +37,8 @@ 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 import Lens.Micro @@ -61,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 @@ -72,41 +88,58 @@ 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 + +internsFromSet :: Ord k => Set.Set k -> Interns k +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 = \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 - , 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) #-} @@ -179,6 +212,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/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/cardano-ledger-core/src/Cardano/Ledger/CertState.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/CertState.hs index 02de838c03e..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,12 @@ import Cardano.Ledger.Binary ( decNoShareCBOR, decSharePlusCBOR, decSharePlusLensCBOR, + decodeMap, decodeRecordNamed, decodeRecordNamedT, encodeListLen, + interns, + 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 +321,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,12 +359,19 @@ 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 - decShareCBOR _ = + 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 (cs, cd, _) = decode $ RecD VState - decCBOR) (decShareCBOR cs)) 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..a09c461d2f1 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,15 @@ module Cardano.Ledger.DRep ( ) where import Cardano.Ledger.BaseTypes -import Cardano.Ledger.Binary (DecCBOR (..), EncCBOR (..)) +import Cardano.Ledger.Binary ( + DecCBOR (..), + DecShareCBOR (..), + EncCBOR (..), + Interns, + decNoShareCBOR, + interns, + internsFromSet, + ) 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 @@ -135,13 +157,18 @@ instance NoThunks DRepState instance NFData DRepState instance DecCBOR DRepState where - decCBOR = do + decCBOR = decNoShareCBOR + +instance DecShareCBOR DRepState where + type Share DRepState = Interns (Credential 'Staking) + getShare = internsFromSet . drepDelegs + decShareCBOR is = do decode $ RecD DRepState 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. 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..a16df48c1ce 100644 --- a/libs/ledger-state/src/Cardano/Ledger/State/Schema.hs +++ b/libs/ledger-state/src/Cardano/Ledger/State/Schema.hs @@ -17,6 +17,7 @@ module Cardano.Ledger.State.Schema where import Cardano.Ledger.Babbage.TxOut (BabbageTxOut) import Cardano.Ledger.BaseTypes (TxIx (..)) import Cardano.Ledger.Coin +import Cardano.Ledger.Conway.Governance import Cardano.Ledger.Core (PParams) import qualified Cardano.Ledger.Credential as Credential import qualified Cardano.Ledger.Keys as Keys @@ -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..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.Babbage 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 @@ -46,7 +46,7 @@ import Lens.Micro import Prettyprinter import Text.Printf -type CurrentEra = BabbageEra +type CurrentEra = ConwayEra --- Loading readNewEpochState ::