From 4b41c2dbcfa7d5e2fc054eea83dbc7dff561dccf Mon Sep 17 00:00:00 2001 From: Kevin Hammond <12563287+kevinhammond@users.noreply.github.com> Date: Wed, 24 Mar 2021 22:33:06 +0000 Subject: [PATCH] added stake-snapshot and pool-params queries --- .../src/Cardano/CLI/Shelley/Commands.hs | 4 + .../src/Cardano/CLI/Shelley/Parsers.hs | 46 +++-- .../src/Cardano/CLI/Shelley/Run/Query.hs | 183 +++++++++++++++++- cardano-cli/src/Cardano/CLI/Types.hs | 43 ++++ 4 files changed, 263 insertions(+), 13 deletions(-) diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Commands.hs b/cardano-cli/src/Cardano/CLI/Shelley/Commands.hs index b0e988b5285..a8c60c5904e 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Commands.hs +++ b/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 diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Parsers.hs b/cardano-cli/src/Cardano/CLI/Shelley/Parsers.hs index 7a9a1b04974..4d31403bc53 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Parsers.hs +++ b/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 = diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Run/Query.hs b/cardano-cli/src/Cardano/CLI/Shelley/Run/Query.hs index 2e198f4ad01..cbd1945643b 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Run/Query.hs +++ b/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,9 +46,10 @@ 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) @@ -55,8 +57,13 @@ 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. +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 diff --git a/cardano-cli/src/Cardano/CLI/Types.hs b/cardano-cli/src/Cardano/CLI/Types.hs index 8af52742ed4..13a4be023d5 100644 --- a/cardano-cli/src/Cardano/CLI/Types.hs +++ b/cardano-cli/src/Cardano/CLI/Types.hs @@ -15,10 +15,13 @@ 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 @@ -26,6 +29,10 @@ 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)