New query pool-state command which obsoletes query pool-params.

It uses a lot less memory and CPU than the older command.

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

@@ -43,6 +43,10 @@ module Cardano.Api.Query (
     CurrentEpochState(..),
     decodeCurrentEpochState,
 
+    SerialisedPoolState(..),
+    PoolState(..),
+    decodePoolState,
+
     EraHistory(..),
     SystemStart(..),
 
@@ -234,6 +238,10 @@ data QueryInShelleyBasedEra era result where
   QueryCurrentEpochState
     :: QueryInShelleyBasedEra era (SerialisedCurrentEpochState era)
 
+  QueryPoolState
+    :: Maybe (Set PoolId)
+    -> QueryInShelleyBasedEra era (SerialisedPoolState era)
+
 deriving instance Show (QueryInShelleyBasedEra era result)
 
 
@@ -357,6 +365,18 @@ decodeCurrentEpochState
   -> Either DecoderError (CurrentEpochState era)
 decodeCurrentEpochState (SerialisedCurrentEpochState (Serialised ls)) = CurrentEpochState <$> decodeFull ls
 
+newtype SerialisedPoolState era
+  = SerialisedPoolState (Serialised (Shelley.PState (Ledger.Crypto (ShelleyLedgerEra era))))
+
+newtype PoolState era = PoolState (Shelley.PState (Ledger.Crypto (ShelleyLedgerEra era)))
+
+decodePoolState
+  :: forall era. ()
+  => FromCBOR (Shelley.PState (Ledger.Crypto (ShelleyLedgerEra era)))
+  => SerialisedPoolState era
+  -> Either DecoderError (PoolState era)
+decodePoolState (SerialisedPoolState (Serialised ls)) = PoolState <$> decodeFull ls
+
 toShelleyAddrSet :: CardanoEra era
                  -> Set AddressAny
                  -> Set (Shelley.Addr Consensus.StandardCrypto)
@@ -536,6 +556,11 @@ toConsensusQueryShelleyBased erainmode QueryProtocolState =
 toConsensusQueryShelleyBased erainmode QueryCurrentEpochState =
     Some (consensusQueryInEraInMode erainmode (Consensus.GetCBOR Consensus.DebugEpochState))
 
+toConsensusQueryShelleyBased erainmode (QueryPoolState poolIds) =
+    Some (consensusQueryInEraInMode erainmode (Consensus.GetCBOR (Consensus.GetPoolState (getPoolIds <$> poolIds))))
+  where
+    getPoolIds :: Set PoolId -> Set (Shelley.KeyHash Shelley.StakePool Consensus.StandardCrypto)
+    getPoolIds = Set.map (\(StakePoolKeyHash kh) -> kh)
 
 consensusQueryInEraInMode
   :: forall era mode erablock modeblock result result' xs.
@@ -767,6 +792,11 @@ fromConsensusQueryResultShelleyBased _ QueryCurrentEpochState q' r' =
     Consensus.GetCBOR Consensus.DebugEpochState -> SerialisedCurrentEpochState r'
     _                                           -> fromConsensusQueryResultMismatch
 
+fromConsensusQueryResultShelleyBased _ QueryPoolState{} q' r' =
+  case q' of
+    Consensus.GetCBOR Consensus.GetPoolState {} -> SerialisedPoolState r'
+    _                                           -> error "moomoo"
+
 -- | 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

@@ -204,8 +204,12 @@ module Cardano.Api.Shelley
     ProtocolState(..),
     decodeProtocolState,
     SerialisedDebugLedgerState(..),
+    CurrentEpochState(..),
     SerialisedCurrentEpochState(..),
     decodeCurrentEpochState,
+    PoolState(..),
+    SerialisedPoolState(..),
+    decodePoolState,
     UTxO(..),
 
     -- ** Various calculations
@@ -228,10 +232,10 @@ 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.KeysPraos
+import           Cardano.Api.IPC
 import           Cardano.Api.KeysByron
+import           Cardano.Api.KeysPraos
 import           Cardano.Api.KeysShelley
 import           Cardano.Api.LedgerState
 import           Cardano.Api.NetworkId

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

@@ -375,6 +375,7 @@ data QueryCmd =
       FilePath
       -- ^ Node operational certificate
       (Maybe OutputFile)
+  | QueryPoolState' AnyConsensusModeParams NetworkId [Hash StakePoolKey]
   deriving Show
 
 renderQueryCmd :: QueryCmd -> Text
@@ -392,6 +393,7 @@ renderQueryCmd cmd =
     QueryStakeSnapshot' {} -> "query stake-snapshot"
     QueryPoolParams' {} -> "query pool-params"
     QueryKesPeriodInfo {} -> "query kes-period-info"
+    QueryPoolState' {} -> "query pool-state"
 
 data GovernanceCmd
   = GovernanceMIRPayStakeAddressesCertificate

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

@@ -35,8 +35,8 @@ import           Options.Applicative hiding (help, str)
 import qualified Options.Applicative as Opt
 import qualified Options.Applicative.Help as H
 import           Prettyprinter (line, pretty)
-import           Text.Parsec ((<?>))
 import qualified Text.Parsec as Parsec
+import           Text.Parsec ((<?>))
 import qualified Text.Parsec.Error as Parsec
 import qualified Text.Parsec.Language as Parsec
 import qualified Text.Parsec.String as Parsec
@@ -49,12 +49,12 @@ import           Ouroboros.Consensus.BlockchainTime (SystemStart (..))
 import           Cardano.Api
 import           Cardano.Api.Shelley
 
+import           Cardano.Chain.Common (BlockCount (BlockCount))
 import           Cardano.CLI.Shelley.Commands
 import           Cardano.CLI.Shelley.Key (InputFormat (..), PaymentVerifier (..),
                    StakeVerifier (..), VerificationKeyOrFile (..), VerificationKeyOrHashOrFile (..),
                    VerificationKeyTextOrFile (..), deserialiseInput, renderInputDecodeError)
 import           Cardano.CLI.Types
-import           Cardano.Chain.Common (BlockCount (BlockCount))
 
 {- HLINT ignore "Use <$>" -}
 
@@ -935,11 +935,13 @@ pQueryCmd =
     , subParser "stake-snapshot"
         (Opt.info pQueryStakeSnapshot $ Opt.progDesc "Obtain the three stake snapshots for a pool, plus the total active stake (advanced command)")
     , subParser "pool-params"
-        (Opt.info pQueryPoolParams $ Opt.progDesc "Dump the pool parameters (Ledger.NewEpochState.esLState._delegationState._pState._pParams -- advanced command)")
+        (Opt.info pQueryPoolParams $ Opt.progDesc "DEPRECATE.  Use query pool-state instead.  Dump the pool parameters (Ledger.NewEpochState.esLState._delegationState._pState._pParams -- advanced command)")
     , subParser "leadership-schedule"
         (Opt.info pLeadershipSchedule $ Opt.progDesc "Get the slots the node is expected to mint a block in (advanced command)")
     , subParser "kes-period-info"
         (Opt.info pKesPeriodInfo $ Opt.progDesc "Get information about the current KES period and your node's operational certificate.")
+    , subParser "pool-state"
+        (Opt.info pQueryPoolState $ Opt.progDesc "Dump the pool state")
     ]
   where
     pQueryProtocolParameters :: Parser QueryCmd
@@ -1009,6 +1011,12 @@ pQueryCmd =
       <*> pNetworkId
       <*> pStakePoolVerificationKeyHash
 
+    pQueryPoolState :: Parser QueryCmd
+    pQueryPoolState = QueryPoolState'
+      <$> pConsensusModeParams
+      <*> pNetworkId
+      <*> many pStakePoolVerificationKeyHash
+
     pLeadershipSchedule :: Parser QueryCmd
     pLeadershipSchedule = QueryLeadershipSchedule
       <$> pConsensusModeParams

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

@@ -6,6 +6,7 @@
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeApplications #-}
 
 {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}
@@ -61,12 +62,13 @@ import           Cardano.Ledger.Shelley.EpochBoundary
 import           Cardano.Ledger.Shelley.LedgerState (DPState (..),
                    EpochState (esLState, esSnapshots), LedgerState (..), NewEpochState (nesEs),
                    PState (_fPParams, _pParams, _retiring))
+import qualified Cardano.Ledger.Shelley.LedgerState as SL
 import qualified Cardano.Ledger.Shelley.PParams as Shelley
 import           Cardano.Ledger.Shelley.Scripts ()
 import           Cardano.Slotting.EpochInfo (EpochInfo (..), epochInfoSlotToUTCTime, hoistEpochInfo)
 import           Control.Monad.Trans.Except (except)
-import           Control.Monad.Trans.Except.Extra (firstExceptT, handleIOExceptT, hoistMaybe, left,
-                   newExceptT, hoistEither)
+import           Control.Monad.Trans.Except.Extra (firstExceptT, handleIOExceptT, hoistEither,
+                   hoistMaybe, left, newExceptT)
 import           Data.Aeson.Encode.Pretty (encodePretty)
 import           Data.Aeson.Types as Aeson
 import           Data.Coerce (coerce)
@@ -78,21 +80,20 @@ import           Data.Time.Clock
 import           Ouroboros.Consensus.BlockchainTime.WallClock.Types (RelativeTime (..),
                    SystemStart (..), toRelativeTime)
 import           Ouroboros.Consensus.Cardano.Block as Consensus (EraMismatch (..))
--- import qualified Ouroboros.Consensus.Protocol.Praos as Praos
 import           Ouroboros.Consensus.Protocol.TPraos
 import           Ouroboros.Network.Block (Serialised (..))
 import           Ouroboros.Network.Protocol.LocalStateQuery.Type (AcquireFailure (..))
 import           Text.Printf (printf)
 
 import qualified Data.ByteString.Lazy.Char8 as LBS
-import qualified Data.VMap as VMap
 import qualified Data.Map.Strict as Map
 import qualified Data.Set as Set
 import qualified Data.Text as Text
 import qualified Data.Text.Encoding as Text
 import qualified Data.Text.IO as T
 import qualified Data.Text.IO as Text
 import qualified Data.Vector as Vector
+import qualified Data.VMap as VMap
 import           Formatting.Buildable (build)
 import           Numeric (showEFloat)
 import qualified Ouroboros.Consensus.HardFork.History as Consensus
@@ -103,7 +104,6 @@ import qualified Ouroboros.Consensus.HardFork.History.Qry as Qry
 import qualified Ouroboros.Network.Protocol.LocalStateQuery.Type as LocalStateQuery
 import qualified System.IO as IO
 
-
 {- HLINT ignore "Reduce duplication" -}
 {- HLINT ignore "Use const" -}
 {- HLINT ignore "Use let" -}
@@ -124,14 +124,15 @@ data ShelleyQueryCmdError
   | ShelleyQueryCmdGenesisReadError !ShelleyGenesisCmdError
   | ShelleyQueryCmdLeaderShipError !LeadershipError
   | ShelleyQueryCmdTextEnvelopeReadError !(FileError TextEnvelopeError)
-  | ShelleyQueryCmdTextReadError !(FileError InputDecodeError )
+  | ShelleyQueryCmdTextReadError !(FileError InputDecodeError)
   | ShelleyQueryCmdColdKeyReadFileError !(FileError InputDecodeError)
   | ShelleyQueryCmdOpCertCounterReadError !(FileError TextEnvelopeError)
   | ShelleyQueryCmdProtocolStateDecodeFailure !(LBS.ByteString, DecoderError)
   | ShelleyQueryCmdSlotToUtcError Text
   | ShelleyQueryCmdNodeUnknownStakePool
       FilePath
       -- ^ Operational certificate of the unknown stake pool.
+  | ShelleyQueryCmdDecodeError Text DecoderError
 
   deriving Show
 
@@ -167,7 +168,8 @@ renderShelleyQueryCmdError err =
       Text.pack $ "The stake pool associated with: " <> nodeOpCert <> " was not found. Ensure the correct KES key has been " <>
                   "specified and that the stake pool is registered. If you have submitted a stake pool registration certificate " <>
                   "in the current epoch, you must wait until the following epoch for the registration to take place."
-
+    ShelleyQueryCmdDecodeError typeName decoderError ->
+      "Failed to decode " <> typeName <> ".  Error: " <> Text.pack (show decoderError)
 
 runQueryCmd :: QueryCmd -> ExceptT ShelleyQueryCmdError IO ()
 runQueryCmd cmd =
@@ -196,6 +198,8 @@ runQueryCmd cmd =
       runQueryUTxO consensusModeParams qFilter networkId mOutFile
     QueryKesPeriodInfo consensusModeParams network nodeOpCert mOutFile ->
       runQueryKesPeriodInfo consensusModeParams network nodeOpCert mOutFile
+    QueryPoolState' consensusModeParams network poolid ->
+      runQueryPoolState consensusModeParams network poolid
 
 runQueryProtocolParameters
   :: AnyConsensusModeParams
@@ -602,7 +606,9 @@ runQueryPoolParams
   -> NetworkId
   -> Hash StakePoolKey
   -> ExceptT ShelleyQueryCmdError IO ()
-runQueryPoolParams (AnyConsensusModeParams cModeParams) network poolid = do
+runQueryPoolParams (AnyConsensusModeParams cModeParams) network poolIds = do
+  liftIO . IO.hPutStrLn IO.stderr $ "WARNING: The query pool-params command is deprecated.  Use query pool-state instead"
+
   SocketPath sockPath <- firstExceptT ShelleyQueryCmdEnvVarSocketErr readEnvSocketPath
   let localNodeConnInfo = LocalNodeConnectInfo cModeParams network sockPath
 
@@ -615,7 +621,31 @@ runQueryPoolParams (AnyConsensusModeParams cModeParams) network poolid = do
 
   let qInMode = QueryInEra eInMode . QueryInShelleyBasedEra sbe $ QueryDebugLedgerState
   result <- executeQuery era cModeParams localNodeConnInfo qInMode
-  obtainLedgerEraClassConstraints sbe (writePoolParams poolid) result
+  obtainLedgerEraClassConstraints sbe (writePoolParams poolIds) result
+
+
+-- | Query the current and future parameters for a stake pool, including the retirement date.
+-- Any of these may be empty (in which case a null will be displayed).
+--
+runQueryPoolState
+  :: AnyConsensusModeParams
+  -> NetworkId
+  -> [Hash StakePoolKey]
+  -> ExceptT ShelleyQueryCmdError IO ()
+runQueryPoolState (AnyConsensusModeParams cModeParams) network poolIds = do
+  SocketPath sockPath <- firstExceptT ShelleyQueryCmdEnvVarSocketErr readEnvSocketPath
+  let localNodeConnInfo = LocalNodeConnectInfo cModeParams network sockPath
+
+  anyE@(AnyCardanoEra era) <- determineEra cModeParams localNodeConnInfo
+  let cMode = consensusModeOnly cModeParams
+  sbe <- getSbe $ cardanoEraStyle era
+
+  eInMode <- toEraInMode era cMode
+    & hoistMaybe (ShelleyQueryCmdEraConsensusModeMismatch (AnyConsensusMode cMode) anyE)
+
+  let qInMode = QueryInEra eInMode . QueryInShelleyBasedEra sbe $ QueryPoolState $ Just $ Set.fromList poolIds
+  result <- executeQuery era cModeParams localNodeConnInfo qInMode
+  obtainLedgerEraClassConstraints sbe writePoolState result
 
 
 -- | Obtain stake snapshot information for a pool, plus information about the total active stake.
@@ -838,7 +868,7 @@ writePoolParams :: forall era ledgerera. ()
   => Era.Crypto ledgerera ~ StandardCrypto
   => PoolId
   -> SerialisedDebugLedgerState era
-  -> ExceptT ShelleyQueryCmdError IO ()
+    -> ExceptT ShelleyQueryCmdError IO ()
 writePoolParams (StakePoolKeyHash hk) qState =
   case decodeDebugLedgerState qState of
     -- In the event of decode failure print the CBOR instead
@@ -857,6 +887,35 @@ writePoolParams (StakePoolKeyHash hk) qState =
 
       liftIO . LBS.putStrLn $ encodePretty $ Params poolParams fPoolParams retiring
 
+-- | This function obtains the pool parameters, equivalent to the following jq query on the output of query ledger-state
+--   .nesEs.esLState._delegationState._pstate._pParams.<pool_id>
+writePoolState :: forall era ledgerera. ()
+  => ShelleyLedgerEra era ~ ledgerera
+  => Era.Crypto ledgerera ~ StandardCrypto
+  => Ledger.Era ledgerera
+  => SerialisedPoolState era
+  -> ExceptT ShelleyQueryCmdError IO ()
+writePoolState serialisedCurrentEpochState =
+  case decodePoolState serialisedCurrentEpochState of
+    Left err -> left (ShelleyQueryCmdDecodeError "PoolState" err)
+
+    Right (PoolState poolState) -> do
+      let hks = Set.toList $ Set.fromList $ Map.keys (_pParams poolState) <> Map.keys (_fPParams poolState) <> Map.keys (_retiring poolState)
+
+      let poolStates :: Map (KeyHash 'StakePool StandardCrypto) (Params StandardCrypto)
+          poolStates = Map.fromList $ hks <&>
+            ( \hk ->
+              ( hk
+              , Params
+                { poolParameters        = Map.lookup hk (SL._pParams  poolState)
+                , futurePoolParameters  = Map.lookup hk (SL._fPParams poolState)
+                , retiringEpoch         = Map.lookup hk (SL._retiring poolState)
+                }
+              )
+            )
+
+      liftIO . LBS.putStrLn $ encodePretty poolStates
+
 writeProtocolState ::
   ( FromCBOR (Consensus.ChainDepState (ConsensusProtocol era))
   , ToJSON (Consensus.ChainDepState (ConsensusProtocol era))
@@ -1341,7 +1400,6 @@ obtainLedgerEraClassConstraints
       , ToJSON (DebugLedgerState era)
       , FromCBOR (DebugLedgerState era)
       , Era.Crypto ledgerera ~ StandardCrypto
-      , ToJSON (Core.PParams ledgerera)
       ) => a) -> a
 obtainLedgerEraClassConstraints ShelleyBasedEraShelley f = f
 obtainLedgerEraClassConstraints ShelleyBasedEraAllegra f = f