From 8c1d6c9e78995afeea0c965b384548c740515152 Mon Sep 17 00:00:00 2001 From: John Ky Date: Tue, 19 Jul 2022 17:24:05 +1000 Subject: [PATCH] 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 | 30 +++++++ cardano-api/src/Cardano/Api/Shelley.hs | 8 +- .../src/Cardano/CLI/Shelley/Commands.hs | 2 + .../src/Cardano/CLI/Shelley/Parsers.hs | 14 +++- .../src/Cardano/CLI/Shelley/Run/Query.hs | 80 ++++++++++++++++--- 5 files changed, 118 insertions(+), 16 deletions(-) diff --git a/cardano-api/src/Cardano/Api/Query.hs b/cardano-api/src/Cardano/Api/Query.hs index 0fc0c78585f..29f82bba8d7 100644 --- a/cardano-api/src/Cardano/Api/Query.hs +++ b/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. -- diff --git a/cardano-api/src/Cardano/Api/Shelley.hs b/cardano-api/src/Cardano/Api/Shelley.hs index bcdf9b7e625..6198d753456 100644 --- a/cardano-api/src/Cardano/Api/Shelley.hs +++ b/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 diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Commands.hs b/cardano-cli/src/Cardano/CLI/Shelley/Commands.hs index cee11f7c690..25033ab5eb2 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Commands.hs +++ b/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 diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Parsers.hs b/cardano-cli/src/Cardano/CLI/Shelley/Parsers.hs index 3820bf800bc..8049ad4eed6 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Parsers.hs +++ b/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 diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Run/Query.hs b/cardano-cli/src/Cardano/CLI/Shelley/Run/Query.hs index a9bb702edd8..23dd30b694b 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Run/Query.hs +++ b/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,14 +80,12 @@ 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 @@ -93,6 +93,7 @@ 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,7 +124,7 @@ 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) @@ -132,6 +132,7 @@ data ShelleyQueryCmdError | 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. +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