Add stake-snapshot and pool-params queries

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

@@ -293,6 +293,8 @@ data QueryCmd =
   | QueryUTxO' AnyConsensusModeParams QueryFilter NetworkId (Maybe OutputFile)
   | QueryLedgerState' AnyConsensusModeParams NetworkId (Maybe OutputFile)
   | QueryProtocolState' AnyConsensusModeParams NetworkId (Maybe OutputFile)
+  | QueryStakeSnapshot' AnyConsensusModeParams NetworkId (Hash StakePoolKey)
+  | QueryPoolParams' AnyConsensusModeParams NetworkId (Hash StakePoolKey)
   deriving Show
 
 renderQueryCmd :: QueryCmd -> Text
@@ -305,6 +307,8 @@ renderQueryCmd cmd =
     QueryUTxO' {} -> "query utxo"
     QueryLedgerState' {} -> "query ledger-state"
     QueryProtocolState' {} -> "query protocol-state"
+    QueryStakeSnapshot' {} -> "query stake-snapshot"
+    QueryPoolParams' {} -> "query pool-params"
 
 data GovernanceCmd
   = GovernanceMIRPayStakeAddressesCertificate

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

@@ -676,6 +676,10 @@ pQueryCmd =
         (Opt.info pQueryLedgerState $ Opt.progDesc "Dump the current ledger state of the node (Ledger.NewEpochState -- advanced command)")
     , subParser "protocol-state"
         (Opt.info pQueryProtocolState $ Opt.progDesc "Dump the current protocol state of the node (Ledger.ChainDepState -- advanced command)")
+    , 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)")
     ]
   where
     pQueryProtocolParameters :: Parser QueryCmd
@@ -726,6 +730,19 @@ pQueryCmd =
                             <*> pNetworkId
                             <*> pMaybeOutputFile
 
+    pQueryStakeSnapshot :: Parser QueryCmd
+    pQueryStakeSnapshot = QueryStakeSnapshot'
+      <$> pConsensusModeParams
+      <*> pNetworkId
+      <*> pStakePoolVerificationKeyHash
+
+    pQueryPoolParams :: Parser QueryCmd
+    pQueryPoolParams = QueryPoolParams'
+      <$> pConsensusModeParams
+      <*> pNetworkId
+      <*> pStakePoolVerificationKeyHash
+
+
 pGovernanceCmd :: Parser GovernanceCmd
 pGovernanceCmd =
  asum

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

@@ -48,13 +48,18 @@ import           Cardano.Binary (decodeFull)
 import           Cardano.Crypto.Hash (hashToBytesAsHex)
 
 import qualified Cardano.Ledger.Crypto as Crypto
+import qualified Cardano.Ledger.Era as Era
 import qualified Cardano.Ledger.Shelley.Constraints as Ledger
 import           Ouroboros.Consensus.Cardano.Block as Consensus (EraMismatch (..))
 import           Ouroboros.Consensus.Shelley.Protocol (StandardCrypto)
 import           Ouroboros.Network.Block (Serialised (..))
 import           Ouroboros.Network.Protocol.LocalStateQuery.Type as LocalStateQuery
                    (AcquireFailure (..))
 import qualified Shelley.Spec.Ledger.API.Protocol as Ledger
+import           Shelley.Spec.Ledger.Coin
+import           Shelley.Spec.Ledger.EpochBoundary
+import           Shelley.Spec.Ledger.Keys (KeyHash (..), KeyRole (..))
+import           Shelley.Spec.Ledger.LedgerState hiding (LedgerState, _delegations)
 import           Shelley.Spec.Ledger.Scripts ()
 
 {- HLINT ignore "Reduce duplication" -}
@@ -68,6 +73,7 @@ data ShelleyQueryCmdError
   | ShelleyQueryCmdAcquireFailure !AcquireFailure
   | ShelleyQueryCmdEraConsensusModeMismatch !AnyCardanoEra !AnyConsensusMode
   | ShelleyQueryCmdByronEra
+  | ShelleyQueryCmdPoolIdError (Hash StakePoolKey)
   | ShelleyQueryCmdEraMismatch !EraMismatch
   deriving Show
 
@@ -80,6 +86,7 @@ renderShelleyQueryCmdError err =
     ShelleyQueryCmdHelpersError helpersErr -> renderHelpersError helpersErr
     ShelleyQueryCmdAcquireFailure aqFail -> Text.pack $ show aqFail
     ShelleyQueryCmdByronEra -> "This query cannot be used for the Byron era"
+    ShelleyQueryCmdPoolIdError poolId -> "The pool id does not exist: " <> show poolId
     ShelleyQueryCmdEraConsensusModeMismatch (AnyCardanoEra era) (AnyConsensusMode cMode) ->
       "Consensus mode and era mismatch. Consensus mode: " <> show cMode <>
       " Era: " <> show era
@@ -100,6 +107,10 @@ runQueryCmd cmd =
       runQueryStakeAddressInfo consensusModeParams addr network mOutFile
     QueryLedgerState' consensusModeParams network mOutFile ->
       runQueryLedgerState consensusModeParams network mOutFile
+    QueryStakeSnapshot' consensusModeParams network poolid ->
+      runQueryStakeSnapshot consensusModeParams network poolid
+    QueryPoolParams' consensusModeParams network poolid ->
+      runQueryPoolParams consensusModeParams network poolid
     QueryProtocolState' consensusModeParams network mOutFile ->
       runQueryProtocolState consensusModeParams network mOutFile
     QueryUTxO' consensusModeParams qFilter networkId mOutFile ->
@@ -235,6 +246,55 @@ runQueryUTxO (AnyConsensusModeParams cModeParams)
   maybeFiltered NoFilter = Nothing
 
 
+-- | 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).
+--
+
+runQueryPoolParams
+  :: AnyConsensusModeParams
+  -> NetworkId
+  -> Hash StakePoolKey
+  -> ExceptT ShelleyQueryCmdError IO ()
+runQueryPoolParams (AnyConsensusModeParams cModeParams) network poolid = 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 anyE (AnyConsensusMode cMode))
+
+  let qInMode = QueryInEra eInMode . QueryInShelleyBasedEra sbe $ QueryLedgerState
+  result <- executeQuery era cModeParams localNodeConnInfo qInMode
+  obtainLedgerEraClassConstraints sbe (writePoolParams poolid) result
+
+
+-- | Obtain stake snapshot information for a pool, plus information about the total active stake.
+-- This information can be used for leader slot calculation, for example, and has been requested by SPOs.
+-- Obtaining the information directly is significantly more time and memory efficient than using a full ledger state dump.
+runQueryStakeSnapshot
+  :: AnyConsensusModeParams
+  -> NetworkId
+  -> Hash StakePoolKey
+  -> ExceptT ShelleyQueryCmdError IO ()
+runQueryStakeSnapshot (AnyConsensusModeParams cModeParams) network poolid = 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 anyE (AnyConsensusMode cMode))
+
+  let qInMode = QueryInEra eInMode . QueryInShelleyBasedEra sbe $ QueryLedgerState
+  result <- executeQuery era cModeParams localNodeConnInfo qInMode
+  obtainLedgerEraClassConstraints sbe (writeStakeSnapshot poolid) result
+
+
 runQueryLedgerState
   :: AnyConsensusModeParams
   -> NetworkId
@@ -375,13 +435,80 @@ writeLedgerState mOutFile qState@(SerialisedLedgerState serLedgerState) =
     Just (OutputFile fpath) ->
       handleIOExceptT (ShelleyQueryCmdWriteFileError . FileIOError fpath)
         $ LBS.writeFile fpath $ unSerialised serLedgerState
- where
-   decodeLedgerState
-     :: SerialisedLedgerState era
-     -> Either LBS.ByteString (LedgerState era)
-   decodeLedgerState (SerialisedLedgerState (Serialised ls)) =
-     first (const ls) (decodeFull ls)
 
+writeStakeSnapshot :: forall era ledgerera. ()
+  => ShelleyLedgerEra era ~ ledgerera
+  => Era.Crypto ledgerera ~ StandardCrypto
+  => FromCBOR (LedgerState era)
+  => PoolId
+  -> SerialisedLedgerState era
+  -> ExceptT ShelleyQueryCmdError IO ()
+writeStakeSnapshot (StakePoolKeyHash hk) qState =
+  case decodeLedgerState qState of
+    -- In the event of decode failure print the CBOR instead
+    Left bs -> firstExceptT ShelleyQueryCmdHelpersError $ pPrintCBOR bs
+
+    Right ledgerState -> do
+      -- Ledger State
+      let (LedgerState snapshot) = ledgerState
+
+      -- The three stake snapshots, obtained from the ledger state
+      let (SnapShots markS setS goS _) = esSnapshots $ nesEs snapshot
+
+      -- Calculate the three pool and active stake values for the given pool
+      liftIO . LBS.putStrLn $ encodePretty $ Stakes
+        { markPool = getPoolStake hk markS
+        , setPool = getPoolStake hk setS
+        , goPool = getPoolStake hk goS
+        , markTotal = getAllStake markS
+        , setTotal = getAllStake setS
+        , goTotal = getAllStake goS
+        }
+
+-- | Sum all the stake that is held by the pool
+getPoolStake :: KeyHash Shelley.Spec.Ledger.Keys.StakePool crypto -> SnapShot crypto -> Integer
+getPoolStake hash ss = pStake
+  where
+    Coin pStake = fold s
+    (Stake s) = poolStake hash (_delegations ss) (_stake ss)
+
+-- | Sum the active stake from a snapshot
+getAllStake :: SnapShot crypto -> Integer
+getAllStake (SnapShot stake _ _) = activeStake
+  where
+    Coin activeStake = fold . unStake $ stake
+
+-- | 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>
+writePoolParams :: forall era ledgerera. ()
+  => ShelleyLedgerEra era ~ ledgerera
+  => FromCBOR (LedgerState era)
+  => Crypto.Crypto (Era.Crypto ledgerera)
+  => Era.Crypto ledgerera ~ StandardCrypto
+  => PoolId
+  -> SerialisedLedgerState era
+  -> ExceptT ShelleyQueryCmdError IO ()
+writePoolParams (StakePoolKeyHash hk) qState =
+  case decodeLedgerState qState of
+    -- In the event of decode failure print the CBOR instead
+    Left bs -> firstExceptT ShelleyQueryCmdHelpersError $ pPrintCBOR bs
+
+    Right ledgerState -> do
+      let LedgerState snapshot = ledgerState
+      let poolState = _pstate $ _delegationState $ esLState $ nesEs snapshot
+
+      -- Pool parameters
+      let poolParams = Map.lookup hk $ _pParams poolState
+      let fPoolParams = Map.lookup hk $ _fPParams poolState
+      let retiring = Map.lookup hk $ _retiring poolState
+
+      liftIO . LBS.putStrLn $ encodePretty $ Params poolParams fPoolParams retiring
+
+decodeLedgerState :: forall era. ()
+  => FromCBOR (LedgerState era)
+  => SerialisedLedgerState era
+  -> Either LBS.ByteString (LedgerState era)
+decodeLedgerState (SerialisedLedgerState (Serialised ls)) = first (const ls) (decodeFull ls)
 
 writeProtocolState :: Crypto.Crypto StandardCrypto
                    => Maybe OutputFile
@@ -629,6 +756,7 @@ obtainLedgerEraClassConstraints
   -> ((Ledger.ShelleyBased ledgerera
       , ToJSON (LedgerState era)
       , FromCBOR (LedgerState era)
+      , Era.Crypto ledgerera ~ StandardCrypto
       ) => a) -> a
 obtainLedgerEraClassConstraints ShelleyBasedEraShelley f = f
 obtainLedgerEraClassConstraints ShelleyBasedEraAllegra f = f

cardano-cli/src/Cardano/CLI/Types.hs

@@ -16,17 +16,24 @@ module Cardano.CLI.Types
   , TxOutAnyEra (..)
   , UpdateProposalFile (..)
   , VerificationKeyFile (..)
+  , Stakes (..)
+  , Params (..)
   ) where
 
 import           Cardano.Prelude
 
+import           Data.Aeson (ToJSON (..), object, pairs, (.=))
 import qualified Data.Aeson as Aeson
 import qualified Data.Text as Text
 
 import qualified Cardano.Chain.Slotting as Byron
 
 import           Cardano.Api
 
+import qualified Cardano.Ledger.Crypto as Crypto
+
+import           Shelley.Spec.Ledger.TxBody (PoolParams (..))
+
 -- | Specify what the CBOR file is
 -- i.e a block, a tx, etc
 data CBORObject = CBORBlockByron Byron.EpochSlots
@@ -63,6 +70,65 @@ data QueryFilter
   | NoFilter
   deriving (Eq, Show)
 
+-- | This data structure is used to allow nicely formatted output within the query stake-snapshot command.
+--
+-- "markPool", "setPool", "goPool" are the three ledger state stake snapshots (from most recent to least recent)
+-- go is the snapshot that is used for the current epoch, set will be used in the next epoch,
+-- mark for the epoch after that.  "markTotal", "setTotal", "goTotal" record the total active stake for each snapshot.
+--
+-- This information can be used by community tools to calculate upcoming leader schedules.
+data Stakes =  Stakes
+  { markPool :: Integer
+  , setPool :: Integer
+  , goPool :: Integer
+  , markTotal :: Integer
+  , setTotal :: Integer
+  , goTotal :: Integer
+  } deriving Show
+
+-- | Pretty printing for stake information
+instance ToJSON Stakes where
+  toJSON (Stakes m s g mt st gt) = object
+    [ "poolStakeMark" .= m
+    , "poolStakeSet" .= s
+    , "poolStakeGo" .= g
+    , "activeStakeMark" .= mt
+    , "activeStakeSet" .= st
+    , "activeStakeGo" .= gt
+    ]
+
+  toEncoding  (Stakes m s g mt st gt) = pairs $ mconcat
+    [ "poolStakeMark" .= m
+    , "poolStakeSet" .= s
+    , "poolStakeGo" .= g
+    , "activeStakeMark" .= mt
+    , "activeStakeSet" .= st
+    , "activeStakeGo" .= gt
+    ]
+
+-- | This data structure is used to allow nicely formatted output in the query pool-params command.
+-- params are the current pool parameter settings, futureparams are new parameters, retiringEpoch is the
+-- epoch that has been set for pool retirement.  Any of these may be Nothing.
+data Params crypto = Params
+  { poolParameters :: Maybe (PoolParams crypto)
+  , futurePoolParameters :: Maybe (PoolParams crypto)
+  , retiringEpoch :: Maybe EpochNo
+  } deriving Show
+
+-- | Pretty printing for pool parameters
+instance Crypto.Crypto crypto =>  ToJSON (Params crypto) where
+  toJSON (Params p fp r) = object
+    [ "poolParams" .= p
+    , "futurePoolParams" .= fp
+    , "retiring" .= r
+    ]
+
+  toEncoding (Params p fp r) = pairs $ mconcat
+    [ "poolParams" .= p
+    , "futurePoolParams" .= fp
+    , "retiring" .= r
+    ]
+
 newtype SigningKeyFile = SigningKeyFile
   { unSigningKeyFile :: FilePath }
   deriving stock (Eq, Ord)

doc/index.rst

@@ -37,6 +37,7 @@ cardano-node
    stake-pool-operations/KES_period
    stake-pool-operations/core_relay
    stake-pool-operations/register_stakepool
+   stake-pool-operations/query_stakepool
    stake-pool-operations/start_your_nodes
    stake-pool-operations/withdraw-rewards
    stake-pool-operations/retire_stakepool

doc/reference/cardano-node-cli-reference.md

@@ -61,12 +61,14 @@ The `stake-pool` command contains the following sub commands:
 
 *cardano-cli query*
 The `query` command contains the following sub commands:
-* `protocol-parameters`(advanced): retrieves the node’s current pool parameters (a raw dump of `Ledger.ChainDepState`). This
+* `protocol-parameters` (advanced): retrieves the node’s current pool parameters (a raw dump of `Ledger.ChainDepState`). This
 * `tip`: gets the node’s current tip (slot number, hash, and block number)
 * `utxo`: retrieves the node’s current UTxO, filtered by address
 * `ledger-state` (advanced):  dumps the current state of the node (a raw dump of `Ledger.NewEpochState`)
 * `stake-address-info`: Get the current delegations and reward accounts filtered by stake address.
 * `stake-distribution`: Get the node's current aggregated stake distribution
+* `stake-snapshot` (advanced): Get the stake snapshot information for a stake pool
+* `pool-params` (advanced): Get the current and future parameters for a stake pool
 
 *cardano-cli governance*
 The `governance` command contains the following sub commands: