Vendor PoolDistr for query backwards-compatibility

ouroboros-consensus-cardano/changelog.d/20240617_202003_alexander.esgen_cardano_node_8_12.md

@@ -0,0 +1,5 @@
+### Breaking
+
+- Changed `GetStakeDistribution` and `GetPoolDistr` queries to return a
+  Consensus-vendored version of `PoolDistr` (instead of using the one from
+  Ledger, as it changed in a backwards-incompatible manner).

ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal

@@ -110,6 +110,7 @@ library
     Ouroboros.Consensus.Shelley.Ledger.PeerSelection
     Ouroboros.Consensus.Shelley.Ledger.Protocol
     Ouroboros.Consensus.Shelley.Ledger.Query
+    Ouroboros.Consensus.Shelley.Ledger.Query.Types
     Ouroboros.Consensus.Shelley.Ledger.SupportsProtocol
     Ouroboros.Consensus.Shelley.Node
     Ouroboros.Consensus.Shelley.Node.Common

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

@@ -83,6 +83,7 @@ import           Ouroboros.Consensus.Shelley.Ledger.Ledger
 import           Ouroboros.Consensus.Shelley.Ledger.NetworkProtocolVersion
                      (ShelleyNodeToClientVersion (..))
 import           Ouroboros.Consensus.Shelley.Ledger.Query.PParamsLegacyEncoder
+import           Ouroboros.Consensus.Shelley.Ledger.Query.Types
 import           Ouroboros.Consensus.Shelley.Protocol.Abstract (ProtoCrypto)
 import           Ouroboros.Consensus.Util (ShowProxy (..))
 import           Ouroboros.Network.Block (Serialised (..), decodePoint,
@@ -127,7 +128,7 @@ data instance BlockQuery (ShelleyBlock proto era) :: Type -> Type where
   -- an endpoint that provides all the information that the wallet wants about
   -- pools, in an extensible fashion.
   GetStakeDistribution
-    :: BlockQuery (ShelleyBlock proto era) (SL.PoolDistr (EraCrypto era))
+    :: BlockQuery (ShelleyBlock proto era) (PoolDistr (EraCrypto era))
 
   -- | Get a subset of the UTxO, filtered by address. Although this will
   -- typically return a lot less data than 'GetUTxOWhole', it requires a linear
@@ -224,7 +225,7 @@ data instance BlockQuery (ShelleyBlock proto era) :: Type -> Type where
   GetPoolDistr
     :: Maybe (Set (SL.KeyHash 'SL.StakePool (EraCrypto era)))
     -> BlockQuery (ShelleyBlock proto era)
-                  (SL.PoolDistr (EraCrypto era))
+                  (PoolDistr (EraCrypto era))
 
   GetStakeDelegDeposits
     :: Set (StakeCredential (EraCrypto era))
@@ -319,7 +320,7 @@ instance (ShelleyCompatible proto era, ProtoCrypto proto ~ crypto)
         GetProposedPParamsUpdates ->
           getProposedPPUpdates st
         GetStakeDistribution ->
-          SL.poolsByTotalStakeFraction globals st
+          fromLedgerPoolDistr $ SL.poolsByTotalStakeFraction globals st
         GetUTxOByAddress addrs ->
           SL.getFilteredUTxO st addrs
         GetUTxOWhole ->
@@ -416,7 +417,8 @@ instance (ShelleyCompatible proto era, ProtoCrypto proto ~ crypto)
 
         GetPoolDistr mPoolIds ->
           let stakeSet = SL.ssStakeSet . SL.esSnapshots $ getEpochState st in
-          SL.calculatePoolDistr' (maybe (const True) (flip Set.member) mPoolIds) stakeSet
+          fromLedgerPoolDistr $
+            SL.calculatePoolDistr' (maybe (const True) (flip Set.member) mPoolIds) stakeSet
         GetStakeDelegDeposits stakeCreds ->
           let lookupDeposit =
                 lookupDepositDState (SL.certDState $ SL.lsCertState $ SL.esLState $ SL.nesEs st)

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

@@ -0,0 +1,71 @@
+{-# LANGUAGE DataKinds                  #-}
+{-# LANGUAGE DeriveAnyClass             #-}
+{-# LANGUAGE DeriveGeneric              #-}
+{-# LANGUAGE DerivingStrategies         #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings          #-}
+
+-- | This module contains copies of older versions of types from Ledger in order
+-- to retain backwards-compatibility. Eventually, types likes this should be
+-- defined in Ledger instead of here, see
+-- <https://github.com/IntersectMBO/cardano-ledger/issues/4415>.
+module Ouroboros.Consensus.Shelley.Ledger.Query.Types (
+    IndividualPoolStake (..)
+  , PoolDistr (..)
+  , fromLedgerIndividualPoolStake
+  , fromLedgerPoolDistr
+  ) where
+
+import           Cardano.Ledger.Binary (DecCBOR (..), EncCBOR (..),
+                     decodeRecordNamed, encodeListLen)
+import           Cardano.Ledger.Crypto (Crypto)
+import           Cardano.Ledger.Keys (Hash)
+import qualified Cardano.Ledger.PoolDistr as SL
+import qualified Cardano.Ledger.Shelley.API as SL
+import           Data.Map.Strict (Map)
+import qualified Data.Map.Strict as Map
+import           GHC.Generics (Generic)
+import           NoThunks.Class
+
+-- | Copy of 'SL.IndividualPoolStake' before
+-- <https://github.com/IntersectMBO/cardano-ledger/pull/4324>.
+data IndividualPoolStake c = IndividualPoolStake {
+    individualPoolStake    :: !Rational
+  , individualPoolStakeVrf :: !(Hash c (SL.VerKeyVRF c))
+  }
+  deriving stock (Show, Eq, Generic)
+  deriving anyclass (NoThunks)
+
+fromLedgerIndividualPoolStake :: SL.IndividualPoolStake c -> IndividualPoolStake c
+fromLedgerIndividualPoolStake ips = IndividualPoolStake {
+      individualPoolStake    = SL.individualPoolStake ips
+    , individualPoolStakeVrf = SL.individualPoolStakeVrf ips
+    }
+
+instance Crypto c => EncCBOR (IndividualPoolStake c) where
+  encCBOR (IndividualPoolStake stake vrf) =
+    mconcat
+      [ encodeListLen 2
+      , encCBOR stake
+      , encCBOR vrf
+      ]
+
+instance Crypto c => DecCBOR (IndividualPoolStake c) where
+  decCBOR =
+    decodeRecordNamed "IndividualPoolStake" (const 2) $
+      IndividualPoolStake
+        <$> decCBOR
+        <*> decCBOR
+
+-- | Copy of 'SL.PoolDistr' before
+-- <https://github.com/IntersectMBO/cardano-ledger/pull/4324>.
+newtype PoolDistr c = PoolDistr {
+    unPoolDistr :: Map (SL.KeyHash SL.StakePool c) (IndividualPoolStake c)
+  }
+  deriving stock (Show, Eq, Generic)
+  deriving newtype (EncCBOR, DecCBOR)
+
+fromLedgerPoolDistr :: SL.PoolDistr c -> PoolDistr c
+fromLedgerPoolDistr pd = PoolDistr {
+      unPoolDistr = Map.map fromLedgerIndividualPoolStake $ SL.unPoolDistr pd
+    }

ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/Examples.hs

@@ -39,6 +39,7 @@ import           Ouroboros.Consensus.Protocol.TPraos (TPraos,
 import           Ouroboros.Consensus.Shelley.Eras
 import           Ouroboros.Consensus.Shelley.HFEras
 import           Ouroboros.Consensus.Shelley.Ledger
+import           Ouroboros.Consensus.Shelley.Ledger.Query.Types
 import           Ouroboros.Consensus.Shelley.Protocol.TPraos ()
 import           Ouroboros.Consensus.Storage.Serialisation
 import           Ouroboros.Network.Block (Serialised (..))
@@ -114,7 +115,7 @@ fromShelleyLedgerExamples ShelleyLedgerExamples {
         , ("EpochNo",                SomeResult GetEpochNo 10)
         , ("EmptyPParams",           SomeResult GetCurrentPParams srePParams)
         , ("ProposedPParamsUpdates", SomeResult GetProposedPParamsUpdates sreProposedPPUpdates)
-        , ("StakeDistribution",      SomeResult GetStakeDistribution srePoolDistr)
+        , ("StakeDistribution",      SomeResult GetStakeDistribution $ fromLedgerPoolDistr srePoolDistr)
         , ("NonMyopicMemberRewards", SomeResult (GetNonMyopicMemberRewards Set.empty)
                                      (NonMyopicMemberRewards $ sreNonMyopicRewards))
         , ("GenesisConfig",          SomeResult GetGenesisConfig (compactGenesis sreShelleyGenesis))
@@ -207,7 +208,7 @@ fromShelleyLedgerExamplesPraos ShelleyLedgerExamples {
         , ("EpochNo",                SomeResult GetEpochNo 10)
         , ("EmptyPParams",           SomeResult GetCurrentPParams srePParams)
         , ("ProposedPParamsUpdates", SomeResult GetProposedPParamsUpdates sreProposedPPUpdates)
-        , ("StakeDistribution",      SomeResult GetStakeDistribution srePoolDistr)
+        , ("StakeDistribution",      SomeResult GetStakeDistribution $ fromLedgerPoolDistr srePoolDistr)
         , ("NonMyopicMemberRewards", SomeResult (GetNonMyopicMemberRewards Set.empty)
                                      (NonMyopicMemberRewards $ sreNonMyopicRewards))
         , ("GenesisConfig",          SomeResult GetGenesisConfig (compactGenesis sreShelleyGenesis))

ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/Generators.hs

@@ -30,6 +30,7 @@ import           Ouroboros.Consensus.Protocol.TPraos (PraosCrypto, TPraos,
                      TPraosState (..))
 import           Ouroboros.Consensus.Shelley.Eras
 import           Ouroboros.Consensus.Shelley.Ledger
+import           Ouroboros.Consensus.Shelley.Ledger.Query.Types
 import           Ouroboros.Consensus.Shelley.Protocol.Praos ()
 import           Ouroboros.Consensus.Shelley.Protocol.TPraos ()
 import           Ouroboros.Network.Block (mkSerialised)
@@ -152,7 +153,7 @@ instance CanMock proto era => Arbitrary (SomeResult (ShelleyBlock proto era)) wh
     , SomeResult <$> (GetNonMyopicMemberRewards <$> arbitrary) <*> arbitrary
     , SomeResult GetCurrentPParams <$> arbitrary
     , SomeResult GetProposedPParamsUpdates <$> arbitrary
-    , SomeResult GetStakeDistribution <$> arbitrary
+    , SomeResult GetStakeDistribution . fromLedgerPoolDistr <$> arbitrary
     , SomeResult DebugEpochState <$> arbitrary
     , (\(SomeResult q r) ->
         SomeResult (GetCBOR q) (mkSerialised (encodeShelleyResult maxBound q) r)) <$>