Add support for querying multiple stake pool.

Author: newhoggy

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

@@ -686,27 +686,27 @@ instance Crypto.Crypto crypto => ToJSON (VMap VB VP (Shelley.Credential 'Shelley
 
 -----
 
-instance ToJSON (Consensus.StakeSnapshots crypto) where
+instance Crypto.Crypto crypto => ToJSON (Consensus.StakeSnapshots crypto) where
   toJSON = object . stakeSnapshotsToPair
   toEncoding = pairs . mconcat . stakeSnapshotsToPair
 
-stakeSnapshotsToPair :: Aeson.KeyValue a => Consensus.StakeSnapshots crypto -> [a]
+stakeSnapshotsToPair :: (Aeson.KeyValue a, Crypto.Crypto crypto) => Consensus.StakeSnapshots crypto -> [a]
 stakeSnapshotsToPair Consensus.StakeSnapshots
     { Consensus.ssStakeSnapshots
     , Consensus.ssMarkTotal
     , Consensus.ssSetTotal
     , Consensus.ssGoTotal
-    } = mconcat
-    -- Only output the first pool in order to preserve backwards compatibility of the output
-    -- format.  The output format will have to change to support multiple pools when that
-    -- functionality is added.
-    [ take 1 (Map.elems ssStakeSnapshots) >>= stakeSnapshotToPair
-    , [ "activeStakeMark" .= ssMarkTotal
-      , "activeStakeSet" .= ssSetTotal
-      , "activeStakeGo" .= 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.ssMarkPool

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

@@ -250,7 +250,7 @@ data QueryInShelleyBasedEra era result where
     -> QueryInShelleyBasedEra era (SerialisedPoolState era)
 
   QueryStakeSnapshot
-    :: PoolId
+    :: Maybe (Set PoolId)
     -> QueryInShelleyBasedEra era (SerialisedStakeSnapshots era)
 
 deriving instance Show (QueryInShelleyBasedEra era result)
@@ -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.GetStakeSnapshots (Just (Set.singleton (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.

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 mPoolIds = 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 mPoolIds
   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
   => SerialisedStakeSnapshots era
   -> ExceptT ShelleyQueryCmdError IO ()
-writeStakeSnapshot qState =
+writeStakeSnapshots qState =
   case decodeStakeSnapshot qState of
     Left err -> left (ShelleyQueryCmdStakeSnapshotDecodeError err)