Fix wrong CBOR deserialisation in pool distribution query

Author: carbolymer

cardano-api/src/Cardano/Api/LedgerState.hs

@@ -119,6 +119,7 @@ import Cardano.Api.Ledger.Internal.Reexport qualified as Ledger
 import Cardano.Api.LedgerState.Internal.ConvertLedgerEvent
 import Cardano.Api.LedgerState.Internal.LedgerEvent
 import Cardano.Api.Monad.Error
+import Cardano.Api.Network (Serialised (..))
 import Cardano.Api.Network.IPC.Internal
   ( LocalChainSyncClient (LocalChainSyncClientPipelined)
   , LocalNodeClientProtocols (..)
@@ -133,7 +134,6 @@ import Cardano.Api.Query.Internal.Type.QueryInMode
   , PoolDistribution (unPoolDistr)
   , ProtocolState
   , SerialisedCurrentEpochState (..)
-  , SerialisedPoolDistribution
   , decodeCurrentEpochState
   , decodePoolDistribution
   , decodeProtocolState
@@ -1967,6 +1967,7 @@ data LeadershipError
   = LeaderErrDecodeLedgerStateFailure
   | LeaderErrDecodeProtocolStateFailure (LBS.ByteString, DecoderError)
   | LeaderErrDecodeProtocolEpochStateFailure DecoderError
+  | LeaderErrDecodePoolDistributionFailure DecoderError
   | LeaderErrGenesisSlot
   | LeaderErrStakePoolHasNoStake PoolId
   | LeaderErrStakeDistribUnstable
@@ -1995,6 +1996,8 @@ instance Api.Error LeadershipError where
       "Leadership schedule currently cannot be calculated from genesis"
     LeaderErrStakePoolHasNoStake poolId ->
       "The stake pool: " <> pshow poolId <> " has no stake"
+    LeaderErrDecodePoolDistributionFailure decoderError ->
+      "Failed to successfully decode the pool stake distribution: " <> pshow decoderError
     LeaderErrDecodeProtocolEpochStateFailure decoderError ->
       "Failed to successfully decode the current epoch state: " <> pshow decoderError
     LeaderErrStakeDistribUnstable curSlot stableAfterSlot stabWindow predictedLastSlot ->
@@ -2192,7 +2195,7 @@ currentEpochEligibleLeadershipSlots
   -> ProtocolState era
   -> PoolId
   -> SigningKey VrfKey
-  -> SerialisedPoolDistribution era
+  -> Serialised (PoolDistribution era)
   -> EpochNo
   -- ^ Current EpochInfo
   -> Either LeadershipError (Set SlotNo)
@@ -2211,9 +2214,10 @@ currentEpochEligibleLeadershipSlots sbe sGen eInfo pp ptclState poolid (VrfSigni
       first LeaderErrSlotRangeCalculationFailure $
         Slot.epochInfoRange eInfo currentEpoch
 
+    -- FUCKED UP HERE:
     setSnapshotPoolDistr <-
-      first LeaderErrDecodeProtocolEpochStateFailure
-        . fmap (SL.unPoolDistr . fromConsensusPoolDistr . unPoolDistr)
+      first LeaderErrDecodePoolDistributionFailure
+        . fmap (SL.unPoolDistr . unPoolDistr)
         $ decodePoolDistribution sbe serPoolDistr
 
     let slotRangeOfInterest :: Core.EraPParams ledgerera => Core.PParams ledgerera -> Set SlotNo
@@ -2552,22 +2556,3 @@ handleExceptions = liftEither <=< liftIO . runExceptT . flip catches handlers
     [ Handler $ throwError . FoldBlocksIOException
     , Handler $ throwError . FoldBlocksMuxError
     ]
-
--- WARNING: Do NOT use this function anywhere else except in its current call sites.
--- This is a temporary work around.
-fromConsensusPoolDistr :: Consensus.PoolDistr c -> SL.PoolDistr
-fromConsensusPoolDistr cpd =
-  SL.PoolDistr
-    { SL.unPoolDistr = Map.map toLedgerIndividualPoolStake $ Shelley.unPoolDistr cpd
-    , SL.pdTotalActiveStake = SL.CompactCoin 0
-    }
-
--- WARNING: Do NOT use this function anywhere else except in its current call sites.
--- This is a temporary work around.
-toLedgerIndividualPoolStake :: Consensus.IndividualPoolStake c -> SL.IndividualPoolStake
-toLedgerIndividualPoolStake ips =
-  SL.IndividualPoolStake
-    { SL.individualPoolStake = Shelley.individualPoolStake ips
-    , SL.individualPoolStakeVrf = SL.toVRFVerKeyHash $ Shelley.individualPoolStakeVrf ips
-    , SL.individualTotalPoolStake = SL.CompactCoin 0
-    }

cardano-api/src/Cardano/Api/Query.hs

@@ -22,7 +22,6 @@ module Cardano.Api.Query
   , SerialisedPoolState (..)
   , PoolState (..)
   , decodePoolState
-  , SerialisedPoolDistribution (..)
   , PoolDistribution (..)
   , decodePoolDistribution
   , SerialisedStakeSnapshots (..)

cardano-api/src/Cardano/Api/Query/Internal/Expr.hs

@@ -190,7 +190,7 @@ queryPoolDistribution
        QueryInMode
        r
        IO
-       (Either UnsupportedNtcVersionError (Either EraMismatch (SerialisedPoolDistribution era)))
+       (Either UnsupportedNtcVersionError (Either EraMismatch (Serialised (PoolDistribution era))))
 queryPoolDistribution eon = querySbe eon . QueryPoolDistribution
 
 queryPoolState

cardano-api/src/Cardano/Api/Query/Internal/Type/QueryInMode.hs

@@ -42,7 +42,6 @@ module Cardano.Api.Query.Internal.Type.QueryInMode
   , SerialisedPoolState (..)
   , PoolState (..)
   , decodePoolState
-  , SerialisedPoolDistribution (..)
   , PoolDistribution (..)
   , decodePoolDistribution
   , SerialisedStakeSnapshots (..)
@@ -115,7 +114,6 @@ import Ouroboros.Consensus.HardFork.History.Qry qualified as Qry
 import Ouroboros.Consensus.Ledger.Query qualified as Consensus
 import Ouroboros.Consensus.Protocol.Abstract qualified as Consensus
 import Ouroboros.Consensus.Shelley.Ledger qualified as Consensus
-import Ouroboros.Consensus.Shelley.Ledger.Query.Types qualified as Consensus
 import Ouroboros.Network.Block (Serialised (..))
 import Ouroboros.Network.PeerSelection.LedgerPeers.Type
 import Ouroboros.Network.Protocol.LocalStateQuery.Client (Some (..))
@@ -277,7 +275,7 @@ data QueryInShelleyBasedEra era result where
     -> QueryInShelleyBasedEra era SerialisedPoolState
   QueryPoolDistribution
     :: Maybe (Set PoolId)
-    -> QueryInShelleyBasedEra era (SerialisedPoolDistribution era)
+    -> QueryInShelleyBasedEra era (Serialised (PoolDistribution era))
   QueryStakeSnapshot
     :: Maybe (Set PoolId)
     -> QueryInShelleyBasedEra era (SerialisedStakeSnapshots era)
@@ -402,20 +400,16 @@ decodePoolState sbe (SerialisedPoolState (Serialised ls)) =
   shelleyBasedEraConstraints sbe $
     PoolState <$> decodeFull (Core.eraProtVerLow @(ShelleyLedgerEra era)) ls
 
-newtype SerialisedPoolDistribution era
-  = SerialisedPoolDistribution
-      (Serialised Shelley.PoolDistr)
-
 newtype PoolDistribution era = PoolDistribution
-  { unPoolDistr :: Consensus.PoolDistr StandardCrypto
+  { unPoolDistr :: Shelley.PoolDistr
   }
 
 decodePoolDistribution
   :: forall era
    . ShelleyBasedEra era
-  -> SerialisedPoolDistribution era
+  -> Serialised (PoolDistribution era)
   -> Either DecoderError (PoolDistribution era)
-decodePoolDistribution sbe (SerialisedPoolDistribution (Serialised ls)) =
+decodePoolDistribution sbe (Serialised ls) =
   PoolDistribution <$> decodeFull (eraProtVerLow sbe) ls
 
 newtype SerialisedStakeSnapshots era
@@ -958,7 +952,7 @@ fromConsensusQueryResultShelleyBased sbe sbeQuery q' r' =
     QueryPoolDistribution{} ->
       case q' of
         Consensus.GetCBOR Consensus.GetPoolDistr2{} ->
-          SerialisedPoolDistribution r'
+          Serialised . unSerialised $ r'
         _ -> fromConsensusQueryResultMismatch
     QueryStakeSnapshot{} ->
       case q' of