From 3f2f2e47dcdb6a29d368c05bf2b570f8098439b4 Mon Sep 17 00:00:00 2001 From: John Ky Date: Sat, 6 Aug 2022 03:34:29 +1000 Subject: [PATCH] Add support for querying multiple stake pool. --- cabal.project | 4 +-- cardano-api/src/Cardano/Api/Orphans.hs | 35 ++++++++++++------- cardano-api/src/Cardano/Api/Query.hs | 26 +++++++------- cardano-api/src/Cardano/Api/Shelley.hs | 4 +-- .../src/Cardano/CLI/Shelley/Commands.hs | 2 +- .../src/Cardano/CLI/Shelley/Parsers.hs | 2 +- .../src/Cardano/CLI/Shelley/Run/Query.hs | 18 +++++----- 7 files changed, 51 insertions(+), 40 deletions(-) diff --git a/cabal.project b/cabal.project index a8a36399250..9b05f79efb8 100644 --- a/cabal.project +++ b/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: a06a2472827df073493f64307ef0d854679aaa77 + --sha256: 0fchrb4cba2j2jxcc8dk9sn3hnrhc1x56pjy37q7rq9hv1lcx5y2 subdir: monoidal-synchronisation network-mux diff --git a/cardano-api/src/Cardano/Api/Orphans.hs b/cardano-api/src/Cardano/Api/Orphans.hs index 4516f8d220f..1033c635eb1 100644 --- a/cardano-api/src/Cardano/Api/Orphans.hs +++ b/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 ] diff --git a/cardano-api/src/Cardano/Api/Query.hs b/cardano-api/src/Cardano/Api/Query.hs index 9e6649fc39a..31ba7a09125 100644 --- a/cardano-api/src/Cardano/Api/Query.hs +++ b/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. diff --git a/cardano-api/src/Cardano/Api/Shelley.hs b/cardano-api/src/Cardano/Api/Shelley.hs index cd60d3a594d..a9ea1ef0ed0 100644 --- a/cardano-api/src/Cardano/Api/Shelley.hs +++ b/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 diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Commands.hs b/cardano-cli/src/Cardano/CLI/Shelley/Commands.hs index da0e428f0f7..c5f2a81507c 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Commands.hs +++ b/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 diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Parsers.hs b/cardano-cli/src/Cardano/CLI/Shelley/Parsers.hs index d92058e9458..356dc3bad25 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Parsers.hs +++ b/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' diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Run/Query.hs b/cardano-cli/src/Cardano/CLI/Shelley/Run/Query.hs index 9a10d4b3e7f..07c37100b43 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Run/Query.hs +++ b/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)