added 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
   = GovernanceMIRCertificate MIRPot [StakeAddress] [Lovelace] OutputFile

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

@@ -664,6 +664,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
@@ -674,10 +678,11 @@ pQueryCmd =
         <*> pMaybeOutputFile
 
     pQueryTip :: Parser QueryCmd
-    pQueryTip = QueryTip
-                  <$> pConsensusModeParams
-                  <*> pNetworkId
-                  <*> pMaybeOutputFile
+    pQueryTip =
+      QueryTip
+        <$> pConsensusModeParams
+        <*> pNetworkId
+        <*> pMaybeOutputFile
 
     pQueryUTxO :: Parser QueryCmd
     pQueryUTxO =
@@ -703,16 +708,33 @@ pQueryCmd =
         <*> pMaybeOutputFile
 
     pQueryLedgerState :: Parser QueryCmd
-    pQueryLedgerState = QueryLedgerState'
-                          <$> pConsensusModeParams
-                          <*> pNetworkId
-                          <*> pMaybeOutputFile
+    pQueryLedgerState =
+      QueryLedgerState'
+        <$> pConsensusModeParams
+        <*> pNetworkId
+        <*> pMaybeOutputFile
 
     pQueryProtocolState :: Parser QueryCmd
-    pQueryProtocolState = QueryProtocolState'
-                            <$> pConsensusModeParams
-                            <*> pNetworkId
-                            <*> pMaybeOutputFile
+    pQueryProtocolState =
+      QueryProtocolState'
+        <$> pConsensusModeParams
+        <*> pNetworkId
+        <*> pMaybeOutputFile
+
+    pQueryStakeSnapshot :: Parser QueryCmd
+    pQueryStakeSnapshot =
+      QueryStakeSnapshot'
+        <$> pConsensusModeParams
+        <*> pNetworkId
+        <*> pStakePoolVerificationKeyHash
+
+    pQueryPoolParams :: Parser QueryCmd
+    pQueryPoolParams =
+      QueryPoolParams'
+        <$> pConsensusModeParams
+        <*> pNetworkId
+        <*> pStakePoolVerificationKeyHash
+
 
 pGovernanceCmd :: Parser GovernanceCmd
 pGovernanceCmd =

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

@@ -24,6 +24,7 @@ import qualified Data.ByteString.Lazy.Char8 as LBS
 import qualified Data.HashMap.Strict as HMS
 import           Data.List (nub)
 import qualified Data.Map.Strict as Map
+import           Data.Maybe
 import qualified Data.Set as Set
 import qualified Data.Text as Text
 import qualified Data.Text.Encoding as Text
@@ -45,18 +46,24 @@ import           Cardano.CLI.Shelley.Parsers (OutputFile (..), QueryCmd (..))
 import           Cardano.CLI.Types
 
 import           Cardano.Binary (decodeFull)
-import           Cardano.Crypto.Hash (hashToBytesAsHex)
+import           Cardano.Crypto.Hash (hashFromStringAsHex, 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 +75,7 @@ data ShelleyQueryCmdError
   | ShelleyQueryCmdAcquireFailure !AcquireFailure
   | ShelleyQueryCmdEraConsensusModeMismatch !AnyCardanoEra !AnyConsensusMode
   | ShelleyQueryCmdByronEra
+  | ShelleyQueryCmdPoolIdError (Hash StakePoolKey)
   | ShelleyQueryCmdEraMismatch !EraMismatch
   deriving Show
 
@@ -80,6 +88,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 +109,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 ->
@@ -232,6 +245,71 @@ 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
+
+  case toEraInMode era cMode of
+    Just eInMode -> do
+      let qInMode = QueryInEra eInMode
+                      . QueryInShelleyBasedEra sbe
+                      $ QueryLedgerState
+      result <- executeQuery
+                  era
+                  cModeParams
+                  localNodeConnInfo
+                  qInMode
+      obtainLedgerEraClassConstraints sbe (writePoolParams poolid) result
+    Nothing -> left . ShelleyQueryCmdEraConsensusModeMismatch anyE $ AnyConsensusMode cMode
+
+
+-- | 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
+
+  case toEraInMode era cMode of
+    Just eInMode -> do
+      let qInMode = QueryInEra eInMode
+                      . QueryInShelleyBasedEra sbe
+                      $ QueryLedgerState
+      result <- executeQuery
+                  era
+                  cModeParams
+                  localNodeConnInfo
+                  qInMode
+      obtainLedgerEraClassConstraints sbe (writeStakeSnapshot poolid) result
+    Nothing -> left . ShelleyQueryCmdEraConsensusModeMismatch anyE $ AnyConsensusMode cMode
+
+
 runQueryLedgerState
   :: AnyConsensusModeParams
   -> NetworkId
@@ -379,6 +457,109 @@ writeLedgerState mOutFile qState@(SerialisedLedgerState serLedgerState) =
    decodeLedgerState (SerialisedLedgerState (Serialised ls)) =
      first (const ls) (decodeFull ls)
 
+writeStakeSnapshot :: forall era ledgerera.
+                      ShelleyLedgerEra era ~ ledgerera
+                   => Era.Era ledgerera
+                   => FromCBOR (LedgerState era)
+                   => Hash StakePoolKey
+                   -> SerialisedLedgerState era
+                   -> ExceptT ShelleyQueryCmdError IO ()
+
+writeStakeSnapshot poolId qState =
+  case decodeLedgerState qState of
+    Left bs -> firstExceptT ShelleyQueryCmdHelpersError $ pPrintCBOR bs
+    Right ledgerState ->
+      if isNothing maybehk then
+        left $ ShelleyQueryCmdPoolIdError poolId
+      else
+        liftIO . LBS.putStrLn $  encodePretty $ Stakes {markpool = markStake, setpool = setStake, gopool = goStake, marktot = markTotal, settot = setTotal, gotot = goTotal}
+      where
+        -- Ledger State
+        (LedgerState snapshot) = ledgerState
+
+        -- The three stake snapshots, obtained from the ledger state
+        (SnapShots markS setS goS _) = esSnapshots $ nesEs snapshot
+
+        -- Calculate the three pool and active stake values for the given pool
+        markStake =  getPoolStake hk markS
+        setStake = getPoolStake hk setS
+        goStake = getPoolStake hk goS
+
+        markTotal = getAllStake markS
+        setTotal = getAllStake setS
+        goTotal = getAllStake goS
+
+        -- Convert the hash string into a KeyHash for use by the ledger
+        maybehk = hashFromStringAsHex $ filter (/= '"') $ show poolId
+        hk = KeyHash $ fromJust maybehk
+ where
+   decodeLedgerState
+     :: SerialisedLedgerState era
+     -> Either LBS.ByteString (LedgerState era)
+   decodeLedgerState (SerialisedLedgerState (Serialised ls)) =
+     first (const ls) (decodeFull ls)
+
+   -- Sum all the stake that is held by the pool
+   getPoolStake :: KeyHash Shelley.Spec.Ledger.Keys.StakePool crypto
+                -> SnapShot crypto
+                -> Integer
+   getPoolStake hk ss = pStake
+      where
+        Coin pStake = fold s
+             where
+                (Stake s) = poolStake hk (_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)
+                => Hash StakePoolKey
+                -> SerialisedLedgerState era
+                -> ExceptT ShelleyQueryCmdError IO ()
+writePoolParams poolId qState =
+  case decodeLedgerState qState of
+    Left bs -> firstExceptT ShelleyQueryCmdHelpersError $ pPrintCBOR bs
+    Right ledgerState ->
+      if isNothing maybehk then
+        left $ ShelleyQueryCmdPoolIdError poolId
+      else
+        liftIO . LBS.putStrLn $  encodePretty $ Params poolparams fpoolparams retiring
+      where
+        (LedgerState snapshot)  = ledgerState
+
+        -- pool state
+        ps = _pstate $ _delegationState $ esLState $ nesEs snapshot
+
+        -- Convert the hash string into a KeyHash for use by the ledger
+        maybehk = hashFromStringAsHex $ filter (/= '"') $ show poolId
+        hk = KeyHash $ fromJust maybehk
+
+        -- pool parameters
+        poolparams = getPoolParams hk $ _pParams ps
+        fpoolparams = getPoolParams hk $ _fPParams ps
+        retiring = getPoolParams hk $ _retiring ps
+
+ where
+   decodeLedgerState
+     :: SerialisedLedgerState era
+     -> Either LBS.ByteString (LedgerState era)
+   decodeLedgerState (SerialisedLedgerState (Serialised ls)) =
+     first (const ls) (decodeFull ls)
+
+   getPoolParams :: KeyHash StakePool (Era.Crypto ledgerera)
+                 -> Map (KeyHash StakePool (Era.Crypto ledgerera)) params
+                 -> Maybe params
+   getPoolParams poolid ps = Map.lookup poolid ps
+
 
 writeProtocolState :: Crypto.Crypto StandardCrypto
                    => Maybe OutputFile

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

@@ -15,17 +15,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
@@ -62,6 +69,42 @@ 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 (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.  "marktot", "setttot", "gotot" 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, setpool, gopool :: Integer,
+      marktot, settot, gotot :: 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 ("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, 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 ("poolParams" .= p <> "futurePoolParams" .= fp <> "retiring" .= r)
+
 newtype SigningKeyFile = SigningKeyFile
   { unSigningKeyFile :: FilePath }
   deriving stock (Eq, Ord)