New query to get SnapShots

cabal.project

@@ -194,7 +194,7 @@ source-repository-package
   type: git
   location: https://github.com/input-output-hk/cardano-prelude
   tag: 6ea36cf2247ac0bc33e08c327abec34dfd05bd99
-  --sha256: 0dk4z8b19lvav8zv88rf1b4k2kr1wzp2g9mnr8jph1yginqi109v
+  --sha256: 0z2y3wzppc12bpn9bl48776ms3nszw8j58xfsdxf97nzjgrmd62g
   subdir:
     cardano-prelude
     cardano-prelude-test

ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano/Node.hs

@@ -27,6 +27,7 @@ module Ouroboros.Consensus.Cardano.Node (
   , protocolInfoCardano
     -- * SupportedNetworkProtocolVersion
   , pattern CardanoNodeToClientVersion1
+  , pattern CardanoNodeToClientVersion10
   , pattern CardanoNodeToClientVersion2
   , pattern CardanoNodeToClientVersion3
   , pattern CardanoNodeToClientVersion4
@@ -35,7 +36,6 @@ module Ouroboros.Consensus.Cardano.Node (
   , pattern CardanoNodeToClientVersion7
   , pattern CardanoNodeToClientVersion8
   , pattern CardanoNodeToClientVersion9
-  , pattern CardanoNodeToClientVersion10
   , pattern CardanoNodeToNodeVersion1
   , pattern CardanoNodeToNodeVersion2
   , pattern CardanoNodeToNodeVersion3

ouroboros-consensus-shelley/ouroboros-consensus-shelley.cabal

@@ -75,6 +75,7 @@ library
                      , strict-containers
                      , text              >=1.2   && <1.3
                      , transformers
+                     , vector-map
 
                        -- cardano-ledger-specs
                      , cardano-ledger-alonzo

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
+    -- | New queries introduced: GetPoolState, GetStakeSnapshot
   | ShelleyNodeToClientVersion6
   deriving (Show, Eq, Ord, Enum, Bounded)
 

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

@@ -1,11 +1,13 @@
 {-# LANGUAGE DataKinds                  #-}
+{-# LANGUAGE DeriveGeneric              #-}
 {-# LANGUAGE DerivingStrategies         #-}
-{-# LANGUAGE DisambiguateRecordFields   #-}
+{-# LANGUAGE DuplicateRecordFields      #-}
 {-# LANGUAGE FlexibleInstances          #-}
 {-# LANGUAGE GADTs                      #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE LambdaCase                 #-}
 {-# LANGUAGE NamedFieldPuns             #-}
+{-# LANGUAGE OverloadedStrings          #-}
 {-# LANGUAGE PatternSynonyms            #-}
 {-# LANGUAGE RankNTypes                 #-}
 {-# LANGUAGE ScopedTypeVariables        #-}
@@ -17,6 +19,7 @@
 module Ouroboros.Consensus.Shelley.Ledger.Query (
     BlockQuery (.., GetUTxO, GetFilteredUTxO)
   , NonMyopicMemberRewards (..)
+  , StakeSnapshot (..)
   , querySupportedVersion
     -- * Serialisation
   , decodeShelleyQuery
@@ -38,7 +41,8 @@ import           Data.Type.Equality (apply)
 import           Data.Typeable (Typeable)
 import           Data.UMap (View (..), domRestrictedView)
 
-import           Cardano.Binary (FromCBOR (..), ToCBOR (..))
+import           Cardano.Binary (FromCBOR (..), ToCBOR (..), encodeListLen,
+                     enforceSize)
 
 import           Ouroboros.Network.Block (Serialised (..), decodePoint,
                      encodePoint, mkSerialised)
@@ -50,8 +54,11 @@ import           Ouroboros.Consensus.Ledger.Extended
 import           Ouroboros.Consensus.Ledger.Query
 import           Ouroboros.Consensus.Util (ShowProxy (..))
 
+import           Cardano.Ledger.Keys (KeyHash, KeyRole(..))
+import           Cardano.Ledger.Compactible (Compactible (fromCompact))
 import qualified Cardano.Ledger.Core as LC
 import qualified Cardano.Ledger.Shelley.API as SL
+import qualified Cardano.Ledger.Shelley.EpochBoundary as SL
 import qualified Cardano.Ledger.Shelley.LedgerState as SL (RewardAccounts)
 import qualified Cardano.Ledger.Shelley.RewardProvenance as SL
                      (RewardProvenance)
@@ -65,6 +72,11 @@ import           Ouroboros.Consensus.Shelley.Ledger.Ledger
 import           Ouroboros.Consensus.Shelley.Ledger.NetworkProtocolVersion
                      (ShelleyNodeToClientVersion (..))
 
+import           Control.DeepSeq (NFData)
+import           Data.Foldable (fold)
+import qualified Data.VMap as VMap
+import           GHC.Generics (Generic)
+
 {-------------------------------------------------------------------------------
   QueryLedger
 -------------------------------------------------------------------------------}
@@ -193,6 +205,11 @@ data instance BlockQuery (ShelleyBlock proto era) :: Type -> Type where
     -> BlockQuery (ShelleyBlock proto era)
                   (SL.PState (EraCrypto era))
 
+  GetStakeSnapshot
+    :: SL.KeyHash 'SL.StakePool (EraCrypto era)
+    -> BlockQuery (ShelleyBlock proto era)
+                  (StakeSnapshot (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.
@@ -273,6 +290,34 @@ instance ShelleyCompatible proto era => QueryLedger (ShelleyBlock proto era) whe
                 , SL._retiring = Map.restrictKeys (SL._retiring dpsPState) poolIds
                 }
             Nothing -> dpsPState
+        GetStakeSnapshot poolId ->
+          let SL.SnapShots
+                { _pstakeMark
+                , _pstakeSet
+                , _pstakeGo
+                } = SL.esSnapshots . SL.nesEs $ st
+
+              -- | Sum all the stake that is held by the pool
+              getPoolStake :: KeyHash 'StakePool crypto -> SL.SnapShot crypto -> Integer
+              getPoolStake hash ss = pStake
+                where
+                  SL.Coin pStake = fold (Map.map fromCompact $ VMap.toMap s)
+                  SL.Stake s = SL.poolStake hash (SL._delegations ss) (SL._stake ss)
+
+              -- | Sum the active stake from a snapshot
+              getAllStake :: SL.SnapShot crypto -> Integer
+              getAllStake (SL.SnapShot stake _ _) = activeStake
+                where
+                  SL.Coin activeStake = foldMap fromCompact (VMap.toMap (SL.unStake stake))
+          in
+          StakeSnapshot
+            { sMarkPool   = getPoolStake poolId _pstakeMark
+            , sSetPool    = getPoolStake poolId _pstakeSet
+            , sGoPool     = getPoolStake poolId _pstakeGo
+            , sMarkTotal  = getAllStake _pstakeMark
+            , sSetTotal   = getAllStake _pstakeSet
+            , sGoTotal    = getAllStake _pstakeGo
+            }
     where
       lcfg    = configLedger $ getExtLedgerCfg cfg
       globals = shelleyLedgerGlobals lcfg
@@ -387,6 +432,13 @@ instance SameDepIndex (BlockQuery (ShelleyBlock proto era)) where
     = Nothing
   sameDepIndex (GetPoolState _) _
     = Nothing
+  sameDepIndex (GetStakeSnapshot poolid) (GetStakeSnapshot poolid')
+    | poolid == poolid'
+    = Just Refl
+    | otherwise
+    = Nothing
+  sameDepIndex (GetStakeSnapshot _) _
+    = Nothing
 
 deriving instance Eq   (BlockQuery (ShelleyBlock proto era) result)
 deriving instance Show (BlockQuery (ShelleyBlock proto era) result)
@@ -413,6 +465,7 @@ instance ShelleyCompatible proto era => ShowQuery (BlockQuery (ShelleyBlock prot
       GetStakePoolParams {}                      -> show
       GetRewardInfoPools                         -> show
       GetPoolState {}                            -> show
+      GetStakeSnapshot {}                        -> show
 
 -- | Is the given query supported by the given 'ShelleyNodeToClientVersion'?
 querySupportedVersion :: BlockQuery (ShelleyBlock proto era) result -> ShelleyNodeToClientVersion -> Bool
@@ -437,6 +490,7 @@ querySupportedVersion = \case
     GetStakePoolParams {}                      -> (>= v4)
     GetRewardInfoPools                         -> (>= v5)
     GetPoolState {}                            -> (>= v6)
+    GetStakeSnapshot {}                        -> (>= v6)
     -- WARNING: when adding a new query, a new @ShelleyNodeToClientVersionX@
     -- must be added. See #2830 for a template on how to do this.
   where
@@ -524,6 +578,8 @@ encodeShelleyQuery query = case query of
       CBOR.encodeListLen 1 <> CBOR.encodeWord8 18
     GetPoolState poolids ->
       CBOR.encodeListLen 2 <> CBOR.encodeWord8 19 <> toCBOR poolids
+    GetStakeSnapshot poolId ->
+      CBOR.encodeListLen 2 <> CBOR.encodeWord8 20 <> toCBOR poolId
 
 decodeShelleyQuery ::
      ShelleyBasedEra era
@@ -552,6 +608,7 @@ decodeShelleyQuery = do
       (2, 17) -> SomeSecond . GetStakePoolParams <$> fromCBOR
       (1, 18) -> return $ SomeSecond GetRewardInfoPools
       (2, 19) -> SomeSecond . GetPoolState <$> fromCBOR
+      (2, 20) -> SomeSecond . GetStakeSnapshot <$> fromCBOR
       _       -> fail $
         "decodeShelleyQuery: invalid (len, tag): (" <>
         show len <> ", " <> show tag <> ")"
@@ -580,6 +637,7 @@ encodeShelleyResult query = case query of
     GetStakePoolParams {}                      -> toCBOR
     GetRewardInfoPools                         -> toCBOR
     GetPoolState {}                            -> toCBOR
+    GetStakeSnapshot {}                        -> toCBOR
 
 decodeShelleyResult ::
      ShelleyCompatible proto era
@@ -606,3 +664,49 @@ decodeShelleyResult query = case query of
     GetStakePoolParams {}                      -> fromCBOR
     GetRewardInfoPools                         -> fromCBOR
     GetPoolState {}                            -> fromCBOR
+    GetStakeSnapshot {}                        -> fromCBOR
+
+data StakeSnapshot crypto = StakeSnapshot
+  { sMarkPool  :: !Integer
+  , sSetPool   :: !Integer
+  , sGoPool    :: !Integer
+  , sMarkTotal :: !Integer
+  , sSetTotal  :: !Integer
+  , sGoTotal   :: !Integer
+  } deriving (Eq, Show, Generic)
+
+instance NFData (StakeSnapshot crypto)
+
+instance
+  Crypto crypto =>
+  ToCBOR (StakeSnapshot crypto)
+  where
+  toCBOR
+    StakeSnapshot
+    { sMarkPool
+    , sSetPool
+    , sGoPool
+    , sMarkTotal
+    , sSetTotal
+    , sGoTotal
+    } = encodeListLen 6
+      <> toCBOR sMarkPool
+      <> toCBOR sSetPool
+      <> toCBOR sGoPool
+      <> toCBOR sMarkTotal
+      <> toCBOR sSetTotal
+      <> toCBOR sGoTotal
+
+instance
+  Crypto crypto =>
+  FromCBOR (StakeSnapshot crypto)
+  where
+  fromCBOR = do
+    enforceSize "StakeSnapshot" 6
+    StakeSnapshot
+      <$> fromCBOR
+      <*> fromCBOR
+      <*> fromCBOR
+      <*> fromCBOR
+      <*> fromCBOR
+      <*> fromCBOR

ouroboros-consensus/docs/interface-CHANGELOG.md

@@ -62,6 +62,7 @@ https://keepachangelog.com/en/1.1.0/, adapted to our plan explained above.
 
 - New supported node to client version `NodeToClientV_14` with new queries:
   - `GetPoolState`: Get the pool state for the given stake pool ids
+  - `GetStakeSnapshot`: Get the snapshot of stake distribution
 
 ## Circa 2022-04-26
 

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
+    -- ^ added @GetPoolState, @GetSnapshots
   deriving (Eq, Ord, Enum, Bounded, Show, Typeable)
 
 -- | We set 16ths bit to distinguish `NodeToNodeVersion` and