Add support for querying multiple stake pool.

cabal.project

@@ -263,8 +263,8 @@ source-repository-package
 source-repository-package
   type: git
   location: https://github.com/input-output-hk/ouroboros-network
-  tag: 4fcb5c7ddf69b7a568a8cf431a86c782a0f6c6fd
-  --sha256: 1mbp0h73cr32p2gbb0q63qkiacvs0qzag899n3l1mal38ppldypf
+  tag: a0d8d63b299b815d73a2d47d3617f12279bd55c8
+  --sha256: 0fchrb4cba2j2jxcc8dk9sn3hnrhc1x56pjy37q7rq9hv1lcx5y2
   subdir:
     monoidal-synchronisation
     network-mux

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

@@ -686,23 +686,34 @@ instance Crypto.Crypto crypto => ToJSON (VMap VB VP (Shelley.Credential 'Shelley
 
 -----
 
+instance Crypto.Crypto crypto => ToJSON (Consensus.StakeSnapshots crypto) where
+  toJSON = object . stakeSnapshotsToPair
+  toEncoding = pairs . mconcat . stakeSnapshotsToPair
+
+stakeSnapshotsToPair :: (Aeson.KeyValue a, Crypto.Crypto crypto) => Consensus.StakeSnapshots crypto -> [a]
+stakeSnapshotsToPair Consensus.StakeSnapshots
+    { Consensus.ssStakeSnapshots
+    , Consensus.ssMarkTotal
+    , Consensus.ssSetTotal
+    , Consensus.ssGoTotal
+    } =
+    [ "pools" .= ssStakeSnapshots
+    , "activeStakeMark" .= ssMarkTotal
+    , "activeStakeSet" .= ssSetTotal
+    , "activeStakeGo" .= ssGoTotal
+    ]
+
 instance ToJSON (Consensus.StakeSnapshot crypto) where
   toJSON = object . stakeSnapshotToPair
   toEncoding = pairs . mconcat . stakeSnapshotToPair
 
 stakeSnapshotToPair :: Aeson.KeyValue a => Consensus.StakeSnapshot crypto -> [a]
 stakeSnapshotToPair Consensus.StakeSnapshot
-    { Consensus.sMarkPool
-    , Consensus.sSetPool
-    , Consensus.sGoPool
-    , Consensus.sMarkTotal
-    , Consensus.sSetTotal
-    , Consensus.sGoTotal
+    { Consensus.ssMarkPool
+    , Consensus.ssSetPool
+    , Consensus.ssGoPool
     } =
-    [ "poolStakeMark" .= sMarkPool
-    , "poolStakeSet" .= sSetPool
-    , "poolStakeGo" .= sGoPool
-    , "activeStakeMark" .= sMarkTotal
-    , "activeStakeSet" .= sSetTotal
-    , "activeStakeGo" .= sGoTotal
+    [ "poolStakeMark" .= ssMarkPool
+    , "poolStakeSet" .= ssSetPool
+    , "poolStakeGo" .= ssGoPool
     ]

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

@@ -48,7 +48,7 @@ module Cardano.Api.Query (
     PoolState(..),
     decodePoolState,
 
-    SerialisedStakeSnapshot(..),
+    SerialisedStakeSnapshots(..),
     StakeSnapshot(..),
     decodeStakeSnapshot,
 
@@ -250,8 +250,8 @@ data QueryInShelleyBasedEra era result where
     -> QueryInShelleyBasedEra era (SerialisedPoolState era)
 
   QueryStakeSnapshot
-    :: PoolId
-    -> QueryInShelleyBasedEra era (SerialisedStakeSnapshot era)
+    :: Maybe (Set PoolId)
+    -> QueryInShelleyBasedEra era (SerialisedStakeSnapshots era)
 
 deriving instance Show (QueryInShelleyBasedEra era result)
 
@@ -411,17 +411,17 @@ decodePoolState
   -> Either DecoderError (PoolState era)
 decodePoolState (SerialisedPoolState (Serialised ls)) = PoolState <$> decodeFull ls
 
-newtype SerialisedStakeSnapshot era
-  = SerialisedStakeSnapshot (Serialised (Consensus.StakeSnapshot (Ledger.Crypto (ShelleyLedgerEra era))))
+newtype SerialisedStakeSnapshots era
+  = SerialisedStakeSnapshots (Serialised (Consensus.StakeSnapshots (Ledger.Crypto (ShelleyLedgerEra era))))
 
-newtype StakeSnapshot era = StakeSnapshot (Consensus.StakeSnapshot (Ledger.Crypto (ShelleyLedgerEra era)))
+newtype StakeSnapshot era = StakeSnapshot (Consensus.StakeSnapshots (Ledger.Crypto (ShelleyLedgerEra era)))
 
 decodeStakeSnapshot
   :: forall era. ()
-  => FromCBOR (Consensus.StakeSnapshot (Ledger.Crypto (ShelleyLedgerEra era)))
-  => SerialisedStakeSnapshot era
+  => FromCBOR (Consensus.StakeSnapshots (Ledger.Crypto (ShelleyLedgerEra era)))
+  => SerialisedStakeSnapshots era
   -> Either DecoderError (StakeSnapshot era)
-decodeStakeSnapshot (SerialisedStakeSnapshot (Serialised ls)) = StakeSnapshot <$> decodeFull ls
+decodeStakeSnapshot (SerialisedStakeSnapshots (Serialised ls)) = StakeSnapshot <$> decodeFull ls
 
 toShelleyAddrSet :: CardanoEra era
                  -> Set AddressAny
@@ -605,8 +605,8 @@ toConsensusQueryShelleyBased erainmode QueryCurrentEpochState =
 toConsensusQueryShelleyBased erainmode (QueryPoolState poolIds) =
     Some (consensusQueryInEraInMode erainmode (Consensus.GetCBOR (Consensus.GetPoolState (Set.map unStakePoolKeyHash <$> poolIds))))
 
-toConsensusQueryShelleyBased erainmode (QueryStakeSnapshot poolId) =
-    Some (consensusQueryInEraInMode erainmode (Consensus.GetCBOR (Consensus.GetStakeSnapshot (unStakePoolKeyHash poolId))))
+toConsensusQueryShelleyBased erainmode (QueryStakeSnapshot mPoolIds) =
+    Some (consensusQueryInEraInMode erainmode (Consensus.GetCBOR (Consensus.GetStakeSnapshots (fmap (Set.map unStakePoolKeyHash) mPoolIds))))
 
 consensusQueryInEraInMode
   :: forall era mode erablock modeblock result result' xs.
@@ -845,8 +845,8 @@ fromConsensusQueryResultShelleyBased _ QueryPoolState{} q' r' =
 
 fromConsensusQueryResultShelleyBased _ QueryStakeSnapshot{} q' r' =
   case q' of
-    Consensus.GetCBOR Consensus.GetStakeSnapshot {} -> SerialisedStakeSnapshot r'
-    _                                               -> fromConsensusQueryResultMismatch
+    Consensus.GetCBOR Consensus.GetStakeSnapshots {} -> SerialisedStakeSnapshots r'
+    _                                                -> fromConsensusQueryResultMismatch
 
 -- | This should /only/ happen if we messed up the mapping in 'toConsensusQuery'
 -- and 'fromConsensusQueryResult' so they are inconsistent with each other.

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

@@ -213,7 +213,7 @@ module Cardano.Api.Shelley
     decodePoolState,
 
     StakeSnapshot(..),
-    SerialisedStakeSnapshot(..),
+    SerialisedStakeSnapshots(..),
     decodeStakeSnapshot,
 
     UTxO(..),
@@ -241,8 +241,8 @@ import           Cardano.Api.Address
 import           Cardano.Api.Block
 import           Cardano.Api.Certificate
 import           Cardano.Api.Eras
-import           Cardano.Api.IPC
 import           Cardano.Api.InMode
+import           Cardano.Api.IPC
 import           Cardano.Api.KeysByron
 import           Cardano.Api.KeysPraos
 import           Cardano.Api.KeysShelley

cardano-cli/src/Cardano/CLI/Shelley/Commands.hs

@@ -365,7 +365,7 @@ data QueryCmd =
   | QueryUTxO' AnyConsensusModeParams QueryUTxOFilter NetworkId (Maybe OutputFile)
   | QueryDebugLedgerState' AnyConsensusModeParams NetworkId (Maybe OutputFile)
   | QueryProtocolState' AnyConsensusModeParams NetworkId (Maybe OutputFile)
-  | QueryStakeSnapshot' AnyConsensusModeParams NetworkId (Hash StakePoolKey)
+  | QueryStakeSnapshot' AnyConsensusModeParams NetworkId [Hash StakePoolKey]
   | QueryKesPeriodInfo
       AnyConsensusModeParams
       NetworkId

cardano-cli/src/Cardano/CLI/Shelley/Parsers.hs

@@ -1002,7 +1002,7 @@ pQueryCmd =
     pQueryStakeSnapshot = QueryStakeSnapshot'
       <$> pConsensusModeParams
       <*> pNetworkId
-      <*> pStakePoolVerificationKeyHash
+      <*> many pStakePoolVerificationKeyHash
 
     pQueryPoolState :: Parser QueryCmd
     pQueryPoolState = QueryPoolState'

cardano-cli/src/Cardano/CLI/Shelley/Run/Query.hs

@@ -187,8 +187,8 @@ runQueryCmd cmd =
       runQueryStakeAddressInfo consensusModeParams addr network mOutFile
     QueryDebugLedgerState' consensusModeParams network mOutFile ->
       runQueryLedgerState consensusModeParams network mOutFile
-    QueryStakeSnapshot' consensusModeParams network poolid ->
-      runQueryStakeSnapshot consensusModeParams network poolid
+    QueryStakeSnapshot' consensusModeParams network mPoolIds ->
+      runQueryStakeSnapshot consensusModeParams network mPoolIds
     QueryProtocolState' consensusModeParams network mOutFile ->
       runQueryProtocolState consensusModeParams network mOutFile
     QueryUTxO' consensusModeParams qFilter networkId mOutFile ->
@@ -625,9 +625,9 @@ runQueryPoolState (AnyConsensusModeParams cModeParams) network poolIds = do
 runQueryStakeSnapshot
   :: AnyConsensusModeParams
   -> NetworkId
-  -> Hash StakePoolKey
+  -> [Hash StakePoolKey]
   -> ExceptT ShelleyQueryCmdError IO ()
-runQueryStakeSnapshot (AnyConsensusModeParams cModeParams) network poolId = do
+runQueryStakeSnapshot (AnyConsensusModeParams cModeParams) network poolIds = do
   SocketPath sockPath <- firstExceptT ShelleyQueryCmdEnvVarSocketErr readEnvSocketPath
   let localNodeConnInfo = LocalNodeConnectInfo cModeParams network sockPath
 
@@ -638,9 +638,9 @@ runQueryStakeSnapshot (AnyConsensusModeParams cModeParams) network poolId = do
   eInMode <- toEraInMode era cMode
     & hoistMaybe (ShelleyQueryCmdEraConsensusModeMismatch (AnyConsensusMode cMode) anyE)
 
-  let qInMode = QueryInEra eInMode . QueryInShelleyBasedEra sbe $ QueryStakeSnapshot poolId
+  let qInMode = QueryInEra eInMode . QueryInShelleyBasedEra sbe $ QueryStakeSnapshot $ Just $ Set.fromList poolIds
   result <- executeQuery era cModeParams localNodeConnInfo qInMode
-  obtainLedgerEraClassConstraints sbe writeStakeSnapshot result
+  obtainLedgerEraClassConstraints sbe writeStakeSnapshots result
 
 
 runQueryLedgerState
@@ -789,12 +789,12 @@ writeLedgerState mOutFile qState@(SerialisedDebugLedgerState serLedgerState) =
       handleIOExceptT (ShelleyQueryCmdWriteFileError . FileIOError fpath)
         $ LBS.writeFile fpath $ unSerialised serLedgerState
 
-writeStakeSnapshot :: forall era ledgerera. ()
+writeStakeSnapshots :: forall era ledgerera. ()
   => ShelleyLedgerEra era ~ ledgerera
   => Era.Crypto ledgerera ~ StandardCrypto
-  => SerialisedStakeSnapshot era
+  => SerialisedStakeSnapshots era
   -> ExceptT ShelleyQueryCmdError IO ()
-writeStakeSnapshot qState =
+writeStakeSnapshots qState =
   case decodeStakeSnapshot qState of
     Left err -> left (ShelleyQueryCmdStakeSnapshotDecodeError err)