New query GetPoolDistr using more performant calculatePoolDistr' function

Author: newhoggy

cabal.project

@@ -222,8 +222,8 @@ source-repository-package
 source-repository-package
   type: git
   location: https://github.com/input-output-hk/cardano-ledger
-  tag: b8a3ea89dd33b02f11c68393b67c425dbef13acd
-  --sha256: 10bhq9zl1rjrbci26cxp8n6n9lx6jy93yqp6r3w31snfirqq4ihc
+  tag: 7f7a8ae757a5f60ed759efed8b0bc721277b95f7
+  --sha256: 1pzgcmlgrw8xa78mmw2sgfdawhkq9d42hr5bdhycm770053jr8h7
   subdir:
     eras/alonzo/impl
     eras/alonzo/test-suite

ouroboros-consensus-cardano-test/src/Test/ThreadNet/TxGen/Cardano.hs

@@ -36,11 +36,11 @@ import qualified Cardano.Chain.Common as Byron
 import           Cardano.Chain.Genesis (GeneratedSecrets (..))
 
 import qualified Cardano.Ledger.Address as SL (BootstrapAddress (..))
+import qualified Cardano.Ledger.Core as SL (TxBody, TxOut)
 import qualified Cardano.Ledger.Hashes as SL
+import qualified Cardano.Ledger.Keys.Bootstrap as SL (makeBootstrapWitness)
 import qualified Cardano.Ledger.SafeHash as SL
-import qualified Cardano.Ledger.Core as SL (TxBody, TxOut)
 import qualified Cardano.Ledger.Shelley.API as SL hiding (TxBody, TxOut)
-import qualified Cardano.Ledger.Keys.Bootstrap as SL (makeBootstrapWitness)
 import qualified Cardano.Ledger.Shelley.Tx as SL (WitnessSetHKD (..))
 import qualified Cardano.Ledger.Shelley.UTxO as SL (makeWitnessVKey)
 import           Cardano.Ledger.Val ((<->))

ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Eras.hs

@@ -64,12 +64,12 @@ import           Cardano.Ledger.Mary (MaryEra)
 import           Cardano.Ledger.Mary.Translation ()
 import           Cardano.Ledger.Shelley (ShelleyEra)
 import qualified Cardano.Ledger.Shelley.API as SL
+import qualified Cardano.Ledger.Shelley.LedgerState as SL
 import qualified Cardano.Ledger.Shelley.Rules.Ledger as SL
 import qualified Cardano.Ledger.Shelley.Rules.Utxow as SL
-import qualified Cardano.Ledger.Shelley.LedgerState as SL
 import           Cardano.Ledger.ShelleyMA ()
 import qualified Cardano.Protocol.TPraos.API as SL
-import           Control.State.Transition (State, PredicateFailure)
+import           Control.State.Transition (PredicateFailure, State)
 import           Data.Data (Proxy (Proxy))
 import           Ouroboros.Consensus.Ledger.SupportsMempool
                      (WhetherToIntervene (..))

ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Block.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE DataKinds                  #-}
 {-# LANGUAGE DeriveAnyClass             #-}
 {-# LANGUAGE DeriveGeneric              #-}
 {-# LANGUAGE DerivingVia                #-}
@@ -12,6 +13,7 @@
 {-# LANGUAGE TypeApplications           #-}
 {-# LANGUAGE TypeFamilyDependencies     #-}
 {-# LANGUAGE UndecidableSuperClasses    #-}
+
 module Ouroboros.Consensus.Shelley.Ledger.Block (
     GetHeader (..)
   , Header (..)
@@ -38,6 +40,7 @@ import           Codec.CBOR.Decoding (Decoder)
 import           Codec.CBOR.Encoding (Encoding)
 import qualified Data.ByteString.Lazy as Lazy
 import           Data.Coerce (coerce)
+import           Data.Sharing (FromSharedCBOR, Interns, Share)
 import           Data.Typeable (Typeable)
 import           GHC.Generics (Generic)
 import           NoThunks.Class (NoThunks (..))
@@ -52,6 +55,7 @@ import           Ouroboros.Consensus.Storage.Common (BinaryBlockInfo (..))
 import           Ouroboros.Consensus.Util (ShowProxy (..), hashFromBytesShortE)
 import           Ouroboros.Consensus.Util.Condense
 
+import qualified Cardano.Ledger.Core as Core
 import           Cardano.Ledger.Crypto (HASH)
 import qualified Cardano.Ledger.Era as SL (hashTxSeq)
 import qualified Cardano.Ledger.Shelley.API as SL
@@ -99,6 +103,8 @@ class
     -- Hard-fork related constraints
   , HasPartialConsensusConfig proto
   , FromCBOR (SL.PState (ProtoCrypto proto))
+  , Share (Core.TxOut era) ~ Interns (SL.Credential 'SL.Staking (ProtoCrypto proto))
+  , FromSharedCBOR (Core.TxOut era)
   ) => ShelleyCompatible proto era
 
 instance ShelleyCompatible proto era => ConvertRawHash (ShelleyBlock proto era) where

ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Mempool.hs

@@ -41,8 +41,8 @@ import           Data.Typeable (Typeable)
 import           GHC.Generics (Generic)
 import           GHC.Natural (Natural)
 import           GHC.Records
-import           NoThunks.Class (NoThunks (..))
 import           Lens.Micro ((^.))
+import           NoThunks.Class (NoThunks (..))
 
 import           Cardano.Binary (Annotator (..), FromCBOR (..),
                      FullByteString (..), ToCBOR (..))
@@ -64,9 +64,9 @@ import           Ouroboros.Consensus.Util.Condense
 import           Cardano.Ledger.Alonzo.PParams
 import           Cardano.Ledger.Alonzo.Tx (totExUnits)
 import           Cardano.Ledger.Babbage.PParams
-import           Cardano.Ledger.Core (Tx, TxSeq, bodyTxL, sizeTxF, fromTxSeq)
-import qualified Cardano.Ledger.Shelley.API as SL
 import qualified Cardano.Ledger.Block as SL (txid)
+import           Cardano.Ledger.Core (Tx, TxSeq, bodyTxL, fromTxSeq, sizeTxF)
+import qualified Cardano.Ledger.Shelley.API as SL
 
 import           Cardano.Ledger.Crypto (Crypto)
 import           Ouroboros.Consensus.Shelley.Eras

ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/NetworkProtocolVersion.hs

@@ -31,7 +31,7 @@ data ShelleyNodeToClientVersion =
     -- | New queries introduced: GetRewardInfoPools
   | ShelleyNodeToClientVersion5
 
-    -- | New queries introduced: GetPoolState, GetStakeSnapshots
+    -- | New queries introduced: GetPoolDistr, GetPoolState, GetStakeSnapshots
   | ShelleyNodeToClientVersion6
   deriving (Show, Eq, Ord, Enum, Bounded)
 

ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Query.hs

@@ -210,6 +210,11 @@ data instance BlockQuery (ShelleyBlock proto era) :: Type -> Type where
     -> BlockQuery (ShelleyBlock proto era)
                   (StakeSnapshots (EraCrypto era))
 
+  GetPoolDistr
+    :: Maybe (Set (SL.KeyHash 'SL.StakePool (EraCrypto era)))
+    -> BlockQuery (ShelleyBlock proto era)
+                  (SL.PoolDistr (EraCrypto era))
+
   -- WARNING: please add new queries to the end of the list and stick to this
   -- order in all other pattern matches on queries. This helps in particular
   -- with the en/decoders, as we want the CBOR tags to be ordered.
@@ -330,6 +335,9 @@ instance (ShelleyCompatible proto era, ProtoCrypto proto ~ crypto) => QueryLedge
                 , ssSetTotal       = getAllStake _pstakeSet
                 , ssGoTotal        = getAllStake _pstakeGo
                 }
+        GetPoolDistr mPoolIds ->
+          let stakeSet = SL._pstakeSet . SL.esSnapshots $ getEpochState st in
+          SL.calculatePoolDistr' (maybe (const True) (flip Set.member) mPoolIds) stakeSet
     where
       lcfg    = configLedger $ getExtLedgerCfg cfg
       globals = shelleyLedgerGlobals lcfg
@@ -451,6 +459,13 @@ instance SameDepIndex (BlockQuery (ShelleyBlock proto era)) where
     = Nothing
   sameDepIndex (GetStakeSnapshots _) _
     = Nothing
+  sameDepIndex (GetPoolDistr poolids) (GetPoolDistr poolids')
+    | poolids == poolids'
+    = Just Refl
+    | otherwise
+    = Nothing
+  sameDepIndex (GetPoolDistr _) _
+    = Nothing
 
 deriving instance Eq   (BlockQuery (ShelleyBlock proto era) result)
 deriving instance Show (BlockQuery (ShelleyBlock proto era) result)
@@ -478,6 +493,7 @@ instance ShelleyCompatible proto era => ShowQuery (BlockQuery (ShelleyBlock prot
       GetRewardInfoPools                         -> show
       GetPoolState {}                            -> show
       GetStakeSnapshots {}                       -> show
+      GetPoolDistr {}                            -> show
 
 -- | Is the given query supported by the given 'ShelleyNodeToClientVersion'?
 querySupportedVersion :: BlockQuery (ShelleyBlock proto era) result -> ShelleyNodeToClientVersion -> Bool
@@ -503,6 +519,7 @@ querySupportedVersion = \case
     GetRewardInfoPools                         -> (>= v5)
     GetPoolState {}                            -> (>= v6)
     GetStakeSnapshots {}                       -> (>= v6)
+    GetPoolDistr {}                            -> (>= v6)
     -- WARNING: when adding a new query, a new @ShelleyNodeToClientVersionX@
     -- must be added. See #2830 for a template on how to do this.
   where
@@ -592,6 +609,8 @@ encodeShelleyQuery query = case query of
       CBOR.encodeListLen 2 <> CBOR.encodeWord8 19 <> toCBOR poolids
     GetStakeSnapshots poolId ->
       CBOR.encodeListLen 2 <> CBOR.encodeWord8 20 <> toCBOR poolId
+    GetPoolDistr poolids ->
+      CBOR.encodeListLen 2 <> CBOR.encodeWord8 21 <> toCBOR poolids
 
 decodeShelleyQuery ::
      ShelleyBasedEra era
@@ -621,6 +640,7 @@ decodeShelleyQuery = do
       (1, 18) -> return $ SomeSecond GetRewardInfoPools
       (2, 19) -> SomeSecond . GetPoolState <$> fromCBOR
       (2, 20) -> SomeSecond . GetStakeSnapshots <$> fromCBOR
+      (2, 21) -> SomeSecond . GetPoolDistr <$> fromCBOR
       _       -> fail $
         "decodeShelleyQuery: invalid (len, tag): (" <>
         show len <> ", " <> show tag <> ")"
@@ -650,6 +670,7 @@ encodeShelleyResult query = case query of
     GetRewardInfoPools                         -> toCBOR
     GetPoolState {}                            -> toCBOR
     GetStakeSnapshots {}                       -> toCBOR
+    GetPoolDistr {}                            -> toCBOR
 
 decodeShelleyResult ::
      ShelleyCompatible proto era
@@ -677,6 +698,7 @@ decodeShelleyResult query = case query of
     GetRewardInfoPools                         -> fromCBOR
     GetPoolState {}                            -> fromCBOR
     GetStakeSnapshots {}                       -> fromCBOR
+    GetPoolDistr {}                            -> fromCBOR
 
 -- | The stake snapshot returns information about the mark, set, go ledger snapshots for a pool,
 -- plus the total active stake for each snapshot that can be used in a 'sigma' calculation.

ouroboros-consensus/docs/interface-CHANGELOG.md

@@ -56,6 +56,12 @@ may appear out of chronological order.
 The internals of each entry are organized similar to
 https://keepachangelog.com/en/1.1.0/, adapted to our plan explained above.
 
+## Circa 2022-08-08
+
+### Added
+
+- `GetPoolDistr`: Get the pool distribution for the given stake pool ids
+
 ## Circa 2022-07-26
 
 ### Added

ouroboros-network/src/Ouroboros/Network/NodeToClient/Version.hs

@@ -35,7 +35,7 @@ data NodeToClientVersion
     | NodeToClientV_13
     -- ^ enabled @CardanoNodeToClientVersion9@, i.e., Babbage
     | NodeToClientV_14
-    -- ^ added @GetPoolState, @GetSnapshots
+    -- ^ added @GetPoolDistr, @GetPoolState, @GetSnapshots
   deriving (Eq, Ord, Enum, Bounded, Show, Typeable)
 
 -- | We set 16ths bit to distinguish `NodeToNodeVersion` and