diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Commands/Query.hs b/cardano-cli/src/Cardano/CLI/EraBased/Commands/Query.hs index 99d4b1fe14..f4fbb6b612 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Commands/Query.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Commands/Query.hs @@ -1,8 +1,25 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE LambdaCase #-} module Cardano.CLI.EraBased.Commands.Query ( QueryCmds (..) + , QueryLeadershipScheduleCmdArgs(..) + , QueryProtocolParametersCmdArgs(..) + , QueryConstitutionHashCmdArgs(..) + , QueryTipCmdArgs(..) + , QueryStakePoolsCmdArgs(..) + , QueryStakeDistributionCmdArgs(..) + , QueryStakeAddressInfoCmdArgs(..) + , QueryUTxOCmdArgs(..) + , QueryLedgerStateCmdArgs(..) + , QueryProtocolStateCmdArgs(..) + , QueryStakeSnapshotCmdArgs(..) + , QueryKesPeriodInfoCmdArgs(..) + , QueryPoolStateCmdArgs(..) + , QueryTxMempoolCmdArgs(..) + , QuerySlotNumberCmdArgs(..) , renderQueryCmds ) where @@ -13,126 +30,172 @@ import Cardano.CLI.Types.Key import Data.Text (Text) import Data.Time.Clock +import GHC.Generics -data QueryCmds era = - QueryLeadershipSchedule - SocketPath - AnyConsensusModeParams - NetworkId - GenesisFile - (VerificationKeyOrHashOrFile StakePoolKey) - (SigningKeyFile In) - EpochLeadershipSchedule - (Maybe (File () Out)) - | QueryProtocolParameters' - SocketPath - AnyConsensusModeParams - NetworkId - (Maybe (File () Out)) - | QueryConstitutionHash - SocketPath - AnyConsensusModeParams - NetworkId - (Maybe (File () Out)) - | QueryTip - SocketPath - AnyConsensusModeParams - NetworkId - (Maybe (File () Out)) - | QueryStakePools' - SocketPath - AnyConsensusModeParams - NetworkId - (Maybe (File () Out)) - | QueryStakeDistribution' - SocketPath - AnyConsensusModeParams - NetworkId - (Maybe (File () Out)) - | QueryStakeAddressInfo - SocketPath - AnyConsensusModeParams - StakeAddress - NetworkId - (Maybe (File () Out)) - | QueryUTxO' - SocketPath - AnyConsensusModeParams - QueryUTxOFilter - NetworkId - (Maybe (File () Out)) - | QueryDebugLedgerState' - SocketPath - AnyConsensusModeParams - NetworkId - (Maybe (File () Out)) - | QueryProtocolState' - SocketPath - AnyConsensusModeParams - NetworkId - (Maybe (File () Out)) - | QueryStakeSnapshot' - SocketPath - AnyConsensusModeParams - NetworkId - (AllOrOnly [Hash StakePoolKey]) - (Maybe (File () Out)) - | QueryKesPeriodInfo - SocketPath - AnyConsensusModeParams - NetworkId - (File () In) - -- ^ Node operational certificate - (Maybe (File () Out)) - | QueryPoolState' - SocketPath - AnyConsensusModeParams - NetworkId - [Hash StakePoolKey] - | QueryTxMempool - SocketPath - AnyConsensusModeParams - NetworkId - TxMempoolQuery - (Maybe (File () Out)) - | QuerySlotNumber - SocketPath - AnyConsensusModeParams - NetworkId - UTCTime - deriving Show +data QueryCmds era + = QueryLeadershipScheduleCmd !QueryLeadershipScheduleCmdArgs + | QueryProtocolParametersCmd !QueryProtocolParametersCmdArgs + | QueryConstitutionHashCmd !QueryConstitutionHashCmdArgs + | QueryTipCmd !QueryTipCmdArgs + | QueryStakePoolsCmd !QueryStakePoolsCmdArgs + | QueryStakeDistributionCmd !QueryStakeDistributionCmdArgs + | QueryStakeAddressInfoCmd !QueryStakeAddressInfoCmdArgs + | QueryUTxOCmd !QueryUTxOCmdArgs + | QueryLedgerStateCmd !QueryLedgerStateCmdArgs + | QueryProtocolStateCmd !QueryProtocolStateCmdArgs + | QueryStakeSnapshotCmd !QueryStakeSnapshotCmdArgs + | QueryKesPeriodInfoCmd !QueryKesPeriodInfoCmdArgs + | QueryPoolStateCmd !QueryPoolStateCmdArgs + | QueryTxMempoolCmd !QueryTxMempoolCmdArgs + | QuerySlotNumberCmd !QuerySlotNumberCmdArgs + deriving (Generic, Show) + +data QueryLeadershipScheduleCmdArgs = QueryLeadershipScheduleCmdArgs + { nodeSocketPath :: !SocketPath + , consensusModeParams :: !AnyConsensusModeParams + , networkId :: !NetworkId + , genesisFp :: !GenesisFile + , poolColdVerKeyFile :: !(VerificationKeyOrHashOrFile StakePoolKey) + , vrkSkeyFp :: !(SigningKeyFile In) + , whichSchedule :: !EpochLeadershipSchedule + , mOutFile :: !(Maybe (File () Out)) + } deriving (Generic, Show) + +data QueryProtocolParametersCmdArgs = QueryProtocolParametersCmdArgs + { nodeSocketPath :: !SocketPath + , consensusModeParams :: !AnyConsensusModeParams + , networkId :: !NetworkId + , mOutFile :: !(Maybe (File () Out)) + } deriving (Generic, Show) + +data QueryConstitutionHashCmdArgs = QueryConstitutionHashCmdArgs + { nodeSocketPath :: !SocketPath + , consensusModeParams :: !AnyConsensusModeParams + , networkId :: !NetworkId + , mOutFile :: !(Maybe (File () Out)) + } deriving (Generic, Show) + +data QueryTipCmdArgs = QueryTipCmdArgs + { nodeSocketPath :: !SocketPath + , consensusModeParams :: !AnyConsensusModeParams + , networkId :: !NetworkId + , mOutFile :: !(Maybe (File () Out)) + } deriving (Generic, Show) + +data QueryStakePoolsCmdArgs = QueryStakePoolsCmdArgs + { nodeSocketPath :: !SocketPath + , consensusModeParams :: !AnyConsensusModeParams + , networkId :: !NetworkId + , mOutFile :: !(Maybe (File () Out)) + } deriving (Generic, Show) + +data QueryStakeDistributionCmdArgs = QueryStakeDistributionCmdArgs + { nodeSocketPath :: !SocketPath + , consensusModeParams :: !AnyConsensusModeParams + , networkId :: !NetworkId + , mOutFile :: !(Maybe (File () Out)) + } deriving (Generic, Show) + +data QueryStakeAddressInfoCmdArgs = QueryStakeAddressInfoCmdArgs + { nodeSocketPath :: !SocketPath + , consensusModeParams :: !AnyConsensusModeParams + , addr :: !StakeAddress + , networkId :: !NetworkId + , mOutFile :: !(Maybe (File () Out)) + } deriving (Generic, Show) + +data QueryUTxOCmdArgs = QueryUTxOCmdArgs + { nodeSocketPath :: !SocketPath + , consensusModeParams :: !AnyConsensusModeParams + , queryFilter :: !QueryUTxOFilter + , networkId :: !NetworkId + , mOutFile :: !(Maybe (File () Out)) + } deriving (Generic, Show) + +data QueryLedgerStateCmdArgs = QueryLedgerStateCmdArgs + { nodeSocketPath :: !SocketPath + , consensusModeParams :: !AnyConsensusModeParams + , networkId :: !NetworkId + , mOutFile :: !(Maybe (File () Out)) + } deriving (Generic, Show) + +data QueryProtocolStateCmdArgs = QueryProtocolStateCmdArgs + { nodeSocketPath :: !SocketPath + , consensusModeParams :: !AnyConsensusModeParams + , networkId :: !NetworkId + , mOutFile :: !(Maybe (File () Out)) + } deriving (Generic, Show) + +data QueryStakeSnapshotCmdArgs = QueryStakeSnapshotCmdArgs + { nodeSocketPath :: !SocketPath + , consensusModeParams :: !AnyConsensusModeParams + , networkId :: !NetworkId + , allOrOnlyPoolIds :: !(AllOrOnly [Hash StakePoolKey]) + , mOutFile :: !(Maybe (File () Out)) + } deriving (Generic, Show) + +data QueryKesPeriodInfoCmdArgs = QueryKesPeriodInfoCmdArgs + { nodeSocketPath :: !SocketPath + , consensusModeParams :: !AnyConsensusModeParams + , networkId :: !NetworkId + , nodeOpCertFp :: !(File () In) -- ^ Node operational certificate + , mOutFile :: !(Maybe (File () Out)) + } deriving (Generic, Show) + +data QueryPoolStateCmdArgs = QueryPoolStateCmdArgs + { nodeSocketPath :: !SocketPath + , consensusModeParams :: !AnyConsensusModeParams + , networkId :: !NetworkId + , poolIds :: ![Hash StakePoolKey] + } deriving (Generic, Show) + +data QueryTxMempoolCmdArgs = QueryTxMempoolCmdArgs + { nodeSocketPath :: !SocketPath + , consensusModeParams :: !AnyConsensusModeParams + , networkId :: !NetworkId + , query :: !TxMempoolQuery + , mOutFile :: !(Maybe (File () Out)) + } + deriving (Generic, Show) + +data QuerySlotNumberCmdArgs = QuerySlotNumberCmdArgs + { nodeSocketPath :: !SocketPath + , consensusModeParams :: !AnyConsensusModeParams + , networkId :: !NetworkId + , utcTime :: !UTCTime + } deriving (Generic, Show) renderQueryCmds :: QueryCmds era -> Text renderQueryCmds = \case - QueryLeadershipSchedule {} -> + QueryLeadershipScheduleCmd {} -> "query leadership-schedule" - QueryProtocolParameters' {} -> + QueryProtocolParametersCmd {} -> "query protocol-parameters " - QueryConstitutionHash {} -> + QueryConstitutionHashCmd {} -> "query constitution-hash " - QueryTip {} -> + QueryTipCmd {} -> "query tip" - QueryStakePools' {} -> + QueryStakePoolsCmd {} -> "query stake-pools" - QueryStakeDistribution' {} -> + QueryStakeDistributionCmd {} -> "query stake-distribution" - QueryStakeAddressInfo {} -> + QueryStakeAddressInfoCmd {} -> "query stake-address-info" - QueryUTxO' {} -> + QueryUTxOCmd {} -> "query utxo" - QueryDebugLedgerState' {} -> + QueryLedgerStateCmd {} -> "query ledger-state" - QueryProtocolState' {} -> + QueryProtocolStateCmd {} -> "query protocol-state" - QueryStakeSnapshot' {} -> + QueryStakeSnapshotCmd {} -> "query stake-snapshot" - QueryKesPeriodInfo {} -> + QueryKesPeriodInfoCmd {} -> "query kes-period-info" - QueryPoolState' {} -> + QueryPoolStateCmd {} -> "query pool-state" - QueryTxMempool _ _ _ query _ -> - "query tx-mempool" <> renderTxMempoolQuery query - QuerySlotNumber {} -> + QueryTxMempoolCmd (QueryTxMempoolCmdArgs _ _ _ q _) -> + "query tx-mempool" <> renderTxMempoolQuery q + QuerySlotNumberCmd {} -> "query slot-number" renderTxMempoolQuery :: TxMempoolQuery -> Text diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Options/Query.hs b/cardano-cli/src/Cardano/CLI/EraBased/Options/Query.hs index e556f26843..36fcca6068 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Options/Query.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Options/Query.hs @@ -35,156 +35,165 @@ pQueryCmds envCli = ) [ Just $ subParser "protocol-parameters" - $ Opt.info (pQueryProtocolParameters envCli) + $ Opt.info (pQueryProtocolParametersCmd envCli) $ Opt.progDesc "Get the node's current protocol parameters" , Just $ subParser "constitution-hash" - $ Opt.info (pQueryConstitutionHash envCli) + $ Opt.info (pQueryConstitutionHashCmd envCli) $ Opt.progDesc "Get the constitution hash" , Just $ subParser "tip" - $ Opt.info (pQueryTip envCli) + $ Opt.info (pQueryTipCmd envCli) $ Opt.progDesc "Get the node's current tip (slot no, hash, block no)" , Just $ subParser "stake-pools" - $ Opt.info (pQueryStakePools envCli) + $ Opt.info (pQueryStakePoolsCmd envCli) $ Opt.progDesc "Get the node's current set of stake pool ids" , Just $ subParser "stake-distribution" - $ Opt.info (pQueryStakeDistribution envCli) + $ Opt.info (pQueryStakeDistributionCmd envCli) $ Opt.progDesc "Get the node's current aggregated stake distribution" , Just $ subParser "stake-address-info" - $ Opt.info (pQueryStakeAddressInfo envCli) + $ Opt.info (pQueryStakeAddressInfoCmd envCli) $ Opt.progDesc $ mconcat [ "Get the current delegations and reward accounts filtered by stake address." ] , Just $ subParser "utxo" - $ Opt.info (pQueryUTxO envCli) + $ Opt.info (pQueryUTxOCmd envCli) $ Opt.progDesc $ mconcat [ "Get a portion of the current UTxO: by tx in, by address or the whole." ] , Just $ subParser "ledger-state" - $ Opt.info (pQueryLedgerState envCli) + $ Opt.info (pQueryLedgerStateCmd envCli) $ Opt.progDesc $ mconcat [ "Dump the current ledger state of the node (Ledger.NewEpochState -- advanced command)" ] , Just $ subParser "protocol-state" - $ Opt.info (pQueryProtocolState envCli) + $ Opt.info (pQueryProtocolStateCmd envCli) $ Opt.progDesc $ mconcat [ "Dump the current protocol state of the node (Ledger.ChainDepState -- advanced command)" ] , Just $ subParser "stake-snapshot" - $ Opt.info (pQueryStakeSnapshot envCli) + $ Opt.info (pQueryStakeSnapshotCmd envCli) $ Opt.progDesc $ mconcat [ "Obtain the three stake snapshots for a pool, plus the total active stake (advanced command)" ] , Just $ hiddenSubParser "pool-params" - $ Opt.info (pQueryPoolState envCli) + $ Opt.info (pQueryPoolStateCmd envCli) $ Opt.progDesc $ mconcat [ "DEPRECATED. Use query pool-state instead. Dump the pool parameters " , "(Ledger.NewEpochState.esLState._delegationState._pState._pParams -- advanced command)" ] , Just $ subParser "leadership-schedule" - $ Opt.info (pLeadershipSchedule envCli) + $ Opt.info (pLeadershipScheduleCmd envCli) $ Opt.progDesc "Get the slots the node is expected to mint a block in (advanced command)" , Just $ subParser "kes-period-info" - $ Opt.info (pKesPeriodInfo envCli) + $ Opt.info (pKesPeriodInfoCmd envCli) $ Opt.progDesc "Get information about the current KES period and your node's operational certificate." , Just $ subParser "pool-state" - $ Opt.info (pQueryPoolState envCli) + $ Opt.info (pQueryPoolStateCmd envCli) $ Opt.progDesc "Dump the pool state" , Just $ subParser "tx-mempool" - $ Opt.info (pQueryTxMempool envCli) + $ Opt.info (pQueryTxMempoolCmd envCli) $ Opt.progDesc "Local Mempool info" , Just $ subParser "slot-number" - $ Opt.info (pQuerySlotNumber envCli) + $ Opt.info (pQuerySlotNumberCmd envCli) $ Opt.progDesc "Query slot number for UTC timestamp" ] -pQueryProtocolParameters :: EnvCli -> Parser (QueryCmds era) -pQueryProtocolParameters envCli = - QueryProtocolParameters' - <$> pSocketPath envCli - <*> pConsensusModeParams - <*> pNetworkId envCli - <*> pMaybeOutputFile +pQueryProtocolParametersCmd :: EnvCli -> Parser (QueryCmds era) +pQueryProtocolParametersCmd envCli = + fmap QueryProtocolParametersCmd $ + QueryProtocolParametersCmdArgs + <$> pSocketPath envCli + <*> pConsensusModeParams + <*> pNetworkId envCli + <*> pMaybeOutputFile -pQueryConstitutionHash :: EnvCli -> Parser (QueryCmds era) -pQueryConstitutionHash envCli = - QueryConstitutionHash - <$> pSocketPath envCli - <*> pConsensusModeParams - <*> pNetworkId envCli - <*> pMaybeOutputFile +pQueryConstitutionHashCmd :: EnvCli -> Parser (QueryCmds era) +pQueryConstitutionHashCmd envCli = + fmap QueryConstitutionHashCmd $ + QueryConstitutionHashCmdArgs + <$> pSocketPath envCli + <*> pConsensusModeParams + <*> pNetworkId envCli + <*> pMaybeOutputFile -pQueryTip :: EnvCli -> Parser (QueryCmds era) -pQueryTip envCli = - QueryTip - <$> pSocketPath envCli - <*> pConsensusModeParams - <*> pNetworkId envCli - <*> pMaybeOutputFile +pQueryTipCmd :: EnvCli -> Parser (QueryCmds era) +pQueryTipCmd envCli = + fmap QueryTipCmd $ + QueryTipCmdArgs + <$> pSocketPath envCli + <*> pConsensusModeParams + <*> pNetworkId envCli + <*> pMaybeOutputFile -pQueryUTxO :: EnvCli -> Parser (QueryCmds era) -pQueryUTxO envCli = - QueryUTxO' - <$> pSocketPath envCli - <*> pConsensusModeParams - <*> pQueryUTxOFilter - <*> pNetworkId envCli - <*> pMaybeOutputFile +pQueryUTxOCmd :: EnvCli -> Parser (QueryCmds era) +pQueryUTxOCmd envCli = + fmap QueryUTxOCmd $ + QueryUTxOCmdArgs + <$> pSocketPath envCli + <*> pConsensusModeParams + <*> pQueryUTxOFilter + <*> pNetworkId envCli + <*> pMaybeOutputFile -pQueryStakePools :: EnvCli -> Parser (QueryCmds era) -pQueryStakePools envCli = - QueryStakePools' - <$> pSocketPath envCli - <*> pConsensusModeParams - <*> pNetworkId envCli - <*> pMaybeOutputFile +pQueryStakePoolsCmd :: EnvCli -> Parser (QueryCmds era) +pQueryStakePoolsCmd envCli = + fmap QueryStakePoolsCmd $ + QueryStakePoolsCmdArgs + <$> pSocketPath envCli + <*> pConsensusModeParams + <*> pNetworkId envCli + <*> pMaybeOutputFile -pQueryStakeDistribution :: EnvCli -> Parser (QueryCmds era) -pQueryStakeDistribution envCli = - QueryStakeDistribution' - <$> pSocketPath envCli - <*> pConsensusModeParams - <*> pNetworkId envCli - <*> pMaybeOutputFile +pQueryStakeDistributionCmd :: EnvCli -> Parser (QueryCmds era) +pQueryStakeDistributionCmd envCli = + fmap QueryStakeDistributionCmd $ + QueryStakeDistributionCmdArgs + <$> pSocketPath envCli + <*> pConsensusModeParams + <*> pNetworkId envCli + <*> pMaybeOutputFile -pQueryStakeAddressInfo :: EnvCli -> Parser (QueryCmds era) -pQueryStakeAddressInfo envCli = - QueryStakeAddressInfo - <$> pSocketPath envCli - <*> pConsensusModeParams - <*> pFilterByStakeAddress - <*> pNetworkId envCli - <*> pMaybeOutputFile +pQueryStakeAddressInfoCmd :: EnvCli -> Parser (QueryCmds era) +pQueryStakeAddressInfoCmd envCli = + fmap QueryStakeAddressInfoCmd $ + QueryStakeAddressInfoCmdArgs + <$> pSocketPath envCli + <*> pConsensusModeParams + <*> pFilterByStakeAddress + <*> pNetworkId envCli + <*> pMaybeOutputFile -pQueryLedgerState :: EnvCli -> Parser (QueryCmds era) -pQueryLedgerState envCli = - QueryDebugLedgerState' - <$> pSocketPath envCli - <*> pConsensusModeParams - <*> pNetworkId envCli - <*> pMaybeOutputFile +pQueryLedgerStateCmd :: EnvCli -> Parser (QueryCmds era) +pQueryLedgerStateCmd envCli = + fmap QueryLedgerStateCmd $ + QueryLedgerStateCmdArgs + <$> pSocketPath envCli + <*> pConsensusModeParams + <*> pNetworkId envCli + <*> pMaybeOutputFile -pQueryProtocolState :: EnvCli -> Parser (QueryCmds era) -pQueryProtocolState envCli = - QueryProtocolState' - <$> pSocketPath envCli - <*> pConsensusModeParams - <*> pNetworkId envCli - <*> pMaybeOutputFile +pQueryProtocolStateCmd :: EnvCli -> Parser (QueryCmds era) +pQueryProtocolStateCmd envCli = + fmap QueryProtocolStateCmd $ + QueryProtocolStateCmdArgs + <$> pSocketPath envCli + <*> pConsensusModeParams + <*> pNetworkId envCli + <*> pMaybeOutputFile pAllStakePoolsOrOnly :: Parser (AllOrOnly [Hash StakePoolKey]) pAllStakePoolsOrOnly = pAll <|> pOnly @@ -196,31 +205,34 @@ pAllStakePoolsOrOnly = pAll <|> pOnly pOnly :: Parser (AllOrOnly [Hash StakePoolKey]) pOnly = Only <$> many (pStakePoolVerificationKeyHash Nothing) -pQueryStakeSnapshot :: EnvCli -> Parser (QueryCmds era) -pQueryStakeSnapshot envCli = - QueryStakeSnapshot' - <$> pSocketPath envCli - <*> pConsensusModeParams - <*> pNetworkId envCli - <*> pAllStakePoolsOrOnly - <*> pMaybeOutputFile +pQueryStakeSnapshotCmd :: EnvCli -> Parser (QueryCmds era) +pQueryStakeSnapshotCmd envCli = + fmap QueryStakeSnapshotCmd $ + QueryStakeSnapshotCmdArgs + <$> pSocketPath envCli + <*> pConsensusModeParams + <*> pNetworkId envCli + <*> pAllStakePoolsOrOnly + <*> pMaybeOutputFile -pQueryPoolState :: EnvCli -> Parser (QueryCmds era) -pQueryPoolState envCli = - QueryPoolState' - <$> pSocketPath envCli - <*> pConsensusModeParams - <*> pNetworkId envCli - <*> many (pStakePoolVerificationKeyHash Nothing) +pQueryPoolStateCmd :: EnvCli -> Parser (QueryCmds era) +pQueryPoolStateCmd envCli = + fmap QueryPoolStateCmd $ + QueryPoolStateCmdArgs + <$> pSocketPath envCli + <*> pConsensusModeParams + <*> pNetworkId envCli + <*> many (pStakePoolVerificationKeyHash Nothing) -pQueryTxMempool :: EnvCli -> Parser (QueryCmds era) -pQueryTxMempool envCli = - QueryTxMempool - <$> pSocketPath envCli - <*> pConsensusModeParams - <*> pNetworkId envCli - <*> pTxMempoolQuery - <*> pMaybeOutputFile +pQueryTxMempoolCmd :: EnvCli -> Parser (QueryCmds era) +pQueryTxMempoolCmd envCli = + fmap QueryTxMempoolCmd $ + QueryTxMempoolCmdArgs + <$> pSocketPath envCli + <*> pConsensusModeParams + <*> pNetworkId envCli + <*> pTxMempoolQuery + <*> pMaybeOutputFile where pTxMempoolQuery :: Parser TxMempoolQuery pTxMempoolQuery = asum @@ -234,37 +246,40 @@ pQueryTxMempool envCli = $ Opt.info (TxMempoolQueryTxExists <$> argument Opt.str (metavar "TX_ID")) $ Opt.progDesc "Query if a particular transaction exists in the mempool" ] -pLeadershipSchedule :: EnvCli -> Parser (QueryCmds era) -pLeadershipSchedule envCli = - QueryLeadershipSchedule - <$> pSocketPath envCli - <*> pConsensusModeParams - <*> pNetworkId envCli - <*> pGenesisFile "Shelley genesis filepath" - <*> pStakePoolVerificationKeyOrHashOrFile Nothing - <*> pVrfSigningKeyFile - <*> pWhichLeadershipSchedule - <*> pMaybeOutputFile +pLeadershipScheduleCmd :: EnvCli -> Parser (QueryCmds era) +pLeadershipScheduleCmd envCli = + fmap QueryLeadershipScheduleCmd $ + QueryLeadershipScheduleCmdArgs + <$> pSocketPath envCli + <*> pConsensusModeParams + <*> pNetworkId envCli + <*> pGenesisFile "Shelley genesis filepath" + <*> pStakePoolVerificationKeyOrHashOrFile Nothing + <*> pVrfSigningKeyFile + <*> pWhichLeadershipSchedule + <*> pMaybeOutputFile -pKesPeriodInfo :: EnvCli -> Parser (QueryCmds era) -pKesPeriodInfo envCli = - QueryKesPeriodInfo - <$> pSocketPath envCli - <*> pConsensusModeParams - <*> pNetworkId envCli - <*> pOperationalCertificateFile - <*> pMaybeOutputFile +pKesPeriodInfoCmd :: EnvCli -> Parser (QueryCmds era) +pKesPeriodInfoCmd envCli = + fmap QueryKesPeriodInfoCmd $ + QueryKesPeriodInfoCmdArgs + <$> pSocketPath envCli + <*> pConsensusModeParams + <*> pNetworkId envCli + <*> pOperationalCertificateFile + <*> pMaybeOutputFile -pQuerySlotNumber :: EnvCli -> Parser (QueryCmds era) -pQuerySlotNumber envCli = - QuerySlotNumber - <$> pSocketPath envCli - <*> pConsensusModeParams - <*> pNetworkId envCli - <*> pUtcTimestamp - where - pUtcTimestamp = - convertTime <$> (Opt.strArgument . mconcat) - [ Opt.metavar "TIMESTAMP" - , Opt.help "UTC timestamp in YYYY-MM-DDThh:mm:ssZ format" - ] +pQuerySlotNumberCmd :: EnvCli -> Parser (QueryCmds era) +pQuerySlotNumberCmd envCli = + fmap QuerySlotNumberCmd $ + QuerySlotNumberCmdArgs + <$> pSocketPath envCli + <*> pConsensusModeParams + <*> pNetworkId envCli + <*> pUtcTimestamp + where + pUtcTimestamp = + convertTime <$> (Opt.strArgument . mconcat) + [ Opt.metavar "TIMESTAMP" + , Opt.help "UTC timestamp in YYYY-MM-DDThh:mm:ssZ format" + ] diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Run/Query.hs b/cardano-cli/src/Cardano/CLI/EraBased/Run/Query.hs index 8555b87c97..106a356653 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Run/Query.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Run/Query.hs @@ -5,6 +5,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -42,15 +43,14 @@ import Cardano.Api.Byron hiding (QueryInShelleyBasedEra (..)) import qualified Cardano.Api.Ledger as Ledger import Cardano.Api.Shelley hiding (QueryInShelleyBasedEra (..)) -import Cardano.CLI.EraBased.Commands.Query +import qualified Cardano.CLI.EraBased.Commands.Query as Cmd import Cardano.CLI.EraBased.Run.Genesis (readAndDecodeShelleyGenesis) import Cardano.CLI.Helpers (pPrintCBOR) import Cardano.CLI.Pretty import Cardano.CLI.Types.Common import Cardano.CLI.Types.Errors.QueryCmdError import Cardano.CLI.Types.Errors.QueryCmdLocalStateQueryError -import Cardano.CLI.Types.Key (VerificationKeyOrHashOrFile, - readVerificationKeyOrHashOrFile) +import Cardano.CLI.Types.Key import qualified Cardano.CLI.Types.Output as O import Cardano.Crypto.Hash (hashToBytesAsHex) import qualified Cardano.Crypto.Hash.Blake2b as Blake2b @@ -104,47 +104,35 @@ import Text.Printf (printf) {- HLINT ignore "Move brackets to avoid $" -} {- HLINT ignore "Redundant flip" -} -runQueryCmds :: QueryCmds era -> ExceptT QueryCmdError IO () +runQueryCmds :: Cmd.QueryCmds era -> ExceptT QueryCmdError IO () runQueryCmds = \case - QueryLeadershipSchedule mNodeSocketPath consensusModeParams network shelleyGenFp poolid vrkSkeyFp whichSchedule outputAs -> - runQueryLeadershipScheduleCmd mNodeSocketPath consensusModeParams network shelleyGenFp poolid vrkSkeyFp whichSchedule outputAs - QueryProtocolParameters' mNodeSocketPath consensusModeParams network mOutFile -> - runQueryProtocolParametersCmd mNodeSocketPath consensusModeParams network mOutFile - QueryConstitutionHash mNodeSocketPath consensusModeParams network mOutFile -> - runQueryConstitutionHashCmd mNodeSocketPath consensusModeParams network mOutFile - QueryTip mNodeSocketPath consensusModeParams network mOutFile -> - runQueryTipCmd mNodeSocketPath consensusModeParams network mOutFile - QueryStakePools' mNodeSocketPath consensusModeParams network mOutFile -> - runQueryStakePoolsCmd mNodeSocketPath consensusModeParams network mOutFile - QueryStakeDistribution' mNodeSocketPath consensusModeParams network mOutFile -> - runQueryStakeDistributionCmd mNodeSocketPath consensusModeParams network mOutFile - QueryStakeAddressInfo mNodeSocketPath consensusModeParams addr network mOutFile -> - runQueryStakeAddressInfoCmd mNodeSocketPath consensusModeParams addr network mOutFile - QueryDebugLedgerState' mNodeSocketPath consensusModeParams network mOutFile -> - runQueryLedgerStateCmd mNodeSocketPath consensusModeParams network mOutFile - QueryStakeSnapshot' mNodeSocketPath consensusModeParams network allOrOnlyPoolIds mOutFile -> - runQueryStakeSnapshotCmd mNodeSocketPath consensusModeParams network allOrOnlyPoolIds mOutFile - QueryProtocolState' mNodeSocketPath consensusModeParams network mOutFile -> - runQueryProtocolStateCmd mNodeSocketPath consensusModeParams network mOutFile - QueryUTxO' mNodeSocketPath consensusModeParams qFilter networkId mOutFile -> - runQueryUTxOCmd mNodeSocketPath consensusModeParams qFilter networkId mOutFile - QueryKesPeriodInfo mNodeSocketPath consensusModeParams network nodeOpCert mOutFile -> - runQueryKesPeriodInfoCmd mNodeSocketPath consensusModeParams network nodeOpCert mOutFile - QueryPoolState' mNodeSocketPath consensusModeParams network poolid -> - runQueryPoolStateCmd mNodeSocketPath consensusModeParams network poolid - QueryTxMempool mNodeSocketPath consensusModeParams network op mOutFile -> - runQueryTxMempoolCmd mNodeSocketPath consensusModeParams network op mOutFile - QuerySlotNumber mNodeSocketPath consensusModeParams network utcTime -> - runQuerySlotNumberCmd mNodeSocketPath consensusModeParams network utcTime - -runQueryConstitutionHashCmd - :: SocketPath - -> AnyConsensusModeParams - -> NetworkId - -> Maybe (File () Out) + Cmd.QueryLeadershipScheduleCmd args -> runQueryLeadershipScheduleCmd args + Cmd.QueryProtocolParametersCmd args -> runQueryProtocolParametersCmd args + Cmd.QueryConstitutionHashCmd args -> runQueryConstitutionHashCmd args + Cmd.QueryTipCmd args -> runQueryTipCmd args + Cmd.QueryStakePoolsCmd args -> runQueryStakePoolsCmd args + Cmd.QueryStakeDistributionCmd args -> runQueryStakeDistributionCmd args + Cmd.QueryStakeAddressInfoCmd args -> runQueryStakeAddressInfoCmd args + Cmd.QueryLedgerStateCmd args -> runQueryLedgerStateCmd args + Cmd.QueryStakeSnapshotCmd args -> runQueryStakeSnapshotCmd args + Cmd.QueryProtocolStateCmd args -> runQueryProtocolStateCmd args + Cmd.QueryUTxOCmd args -> runQueryUTxOCmd args + Cmd.QueryKesPeriodInfoCmd args -> runQueryKesPeriodInfoCmd args + Cmd.QueryPoolStateCmd args -> runQueryPoolStateCmd args + Cmd.QueryTxMempoolCmd args -> runQueryTxMempoolCmd args + Cmd.QuerySlotNumberCmd args -> runQuerySlotNumberCmd args + +runQueryConstitutionHashCmd :: () + => Cmd.QueryConstitutionHashCmdArgs -> ExceptT QueryCmdError IO () -runQueryConstitutionHashCmd socketPath (AnyConsensusModeParams cModeParams) network mOutFile = do - let localNodeConnInfo = LocalNodeConnectInfo cModeParams network socketPath +runQueryConstitutionHashCmd + Cmd.QueryConstitutionHashCmdArgs + { Cmd.nodeSocketPath + , Cmd.consensusModeParams = AnyConsensusModeParams cModeParams + , Cmd.networkId + , Cmd.mOutFile + } = do + let localNodeConnInfo = LocalNodeConnectInfo cModeParams networkId nodeSocketPath result <- liftIO $ executeLocalStateQueryExpr localNodeConnInfo Nothing $ runExceptT $ do anyE@(AnyCardanoEra era) <- lift (determineEraExpr cModeParams) @@ -175,14 +163,17 @@ runQueryConstitutionHashCmd socketPath (AnyConsensusModeParams cModeParams) netw handleIOExceptT (QueryCmdWriteFileError . FileIOError fpath) $ LBS.writeFile fpath (encodePretty cHash) -runQueryProtocolParametersCmd - :: SocketPath - -> AnyConsensusModeParams - -> NetworkId - -> Maybe (File () Out) +runQueryProtocolParametersCmd :: () + => Cmd.QueryProtocolParametersCmdArgs -> ExceptT QueryCmdError IO () -runQueryProtocolParametersCmd socketPath (AnyConsensusModeParams cModeParams) network mOutFile = do - let localNodeConnInfo = LocalNodeConnectInfo cModeParams network socketPath +runQueryProtocolParametersCmd + Cmd.QueryProtocolParametersCmdArgs + { Cmd.nodeSocketPath + , Cmd.consensusModeParams = AnyConsensusModeParams cModeParams + , Cmd.networkId + , Cmd.mOutFile + } = do + let localNodeConnInfo = LocalNodeConnectInfo cModeParams networkId nodeSocketPath anyE@(AnyCardanoEra era) <- firstExceptT QueryCmdAcquireFailure $ newExceptT $ determineEra cModeParams localNodeConnInfo sbe <- case cardanoEraStyle era of LegacyByronEra -> left QueryCmdByronEra @@ -244,16 +235,19 @@ queryChainTipViaChainSync localNodeConnInfo = do "Warning: Local header state query unavailable. Falling back to chain sync query" liftIO $ getLocalChainTip localNodeConnInfo -runQueryTipCmd - :: SocketPath - -> AnyConsensusModeParams - -> NetworkId - -> Maybe (File () Out) +runQueryTipCmd :: () + => Cmd.QueryTipCmdArgs -> ExceptT QueryCmdError IO () -runQueryTipCmd socketPath (AnyConsensusModeParams cModeParams) network mOutFile = do +runQueryTipCmd + Cmd.QueryTipCmdArgs + { Cmd.nodeSocketPath + , Cmd.consensusModeParams = AnyConsensusModeParams cModeParams + , Cmd.networkId + , Cmd.mOutFile + } = do case consensusModeOnly cModeParams of CardanoMode -> do - let localNodeConnInfo = LocalNodeConnectInfo cModeParams network socketPath + let localNodeConnInfo = LocalNodeConnectInfo cModeParams networkId nodeSocketPath eLocalState <- ExceptT $ fmap sequence $ executeLocalStateQueryExpr localNodeConnInfo Nothing $ runExceptT $ do @@ -328,16 +322,18 @@ runQueryTipCmd socketPath (AnyConsensusModeParams cModeParams) network mOutFile -- | Query the UTxO, filtered by a given set of addresses, from a Shelley node -- via the local state query protocol. -runQueryUTxOCmd - :: SocketPath - -> AnyConsensusModeParams - -> QueryUTxOFilter - -> NetworkId - -> Maybe (File () Out) +runQueryUTxOCmd :: () + => Cmd.QueryUTxOCmdArgs -> ExceptT QueryCmdError IO () -runQueryUTxOCmd socketPath (AnyConsensusModeParams cModeParams) - qfilter network mOutFile = do - let localNodeConnInfo = LocalNodeConnectInfo cModeParams network socketPath +runQueryUTxOCmd + Cmd.QueryUTxOCmdArgs + { Cmd.nodeSocketPath + , Cmd.consensusModeParams = AnyConsensusModeParams cModeParams + , Cmd.queryFilter + , Cmd.networkId + , Cmd.mOutFile + } = do + let localNodeConnInfo = LocalNodeConnectInfo cModeParams networkId nodeSocketPath join $ lift ( executeLocalStateQueryExpr localNodeConnInfo Nothing $ runExceptT $ do @@ -356,7 +352,7 @@ runQueryUTxOCmd socketPath (AnyConsensusModeParams cModeParams) requireNotByronEraInByronMode eraInMode - utxo <- lift (queryUtxo eInMode sbe qfilter) + utxo <- lift (queryUtxo eInMode sbe queryFilter) & onLeft (left . QueryCmdUnsupportedNtcVersion) & onLeft (left . QueryCmdLocalStateQueryError . EraMismatchError) @@ -366,18 +362,21 @@ runQueryUTxOCmd socketPath (AnyConsensusModeParams cModeParams) & onLeft (left . QueryCmdAcquireFailure) & onLeft left -runQueryKesPeriodInfoCmd - :: SocketPath - -> AnyConsensusModeParams - -> NetworkId - -> File () In - -> Maybe (File () Out) +runQueryKesPeriodInfoCmd :: () + => Cmd.QueryKesPeriodInfoCmdArgs -> ExceptT QueryCmdError IO () -runQueryKesPeriodInfoCmd socketPath (AnyConsensusModeParams cModeParams) network nodeOpCertFile mOutFile = do - opCert <- lift (readFileTextEnvelope AsOperationalCertificate nodeOpCertFile) +runQueryKesPeriodInfoCmd + Cmd.QueryKesPeriodInfoCmdArgs + { Cmd.nodeSocketPath + , Cmd.consensusModeParams = AnyConsensusModeParams cModeParams + , Cmd.networkId + , Cmd.nodeOpCertFp + , Cmd.mOutFile + } = do + opCert <- lift (readFileTextEnvelope AsOperationalCertificate nodeOpCertFp) & onLeft (left . QueryCmdOpCertCounterReadError) - let localNodeConnInfo = LocalNodeConnectInfo cModeParams network socketPath + let localNodeConnInfo = LocalNodeConnectInfo cModeParams networkId nodeSocketPath let cMode = consensusModeOnly cModeParams @@ -428,8 +427,8 @@ runQueryKesPeriodInfoCmd socketPath (AnyConsensusModeParams cModeParams) network let counterInformation = opCertNodeAndOnDiskCounters onDiskC stateC -- Always render diagnostic information - liftIO . putStrLn $ renderOpCertIntervalInformation (unFile nodeOpCertFile) opCertIntervalInformation - liftIO . putStrLn $ renderOpCertNodeAndOnDiskCounterInformation (unFile nodeOpCertFile) counterInformation + liftIO . putStrLn $ renderOpCertIntervalInformation (unFile nodeOpCertFp) opCertIntervalInformation + liftIO . putStrLn $ renderOpCertNodeAndOnDiskCounterInformation (unFile nodeOpCertFp) counterInformation let qKesInfoOutput = createQueryKesPeriodInfoOutput opCertIntervalInformation counterInformation eInfo gParams kesPeriodInfoJSON = encodePretty qKesInfoOutput @@ -647,14 +646,17 @@ renderOpCertIntervalInformation opCertFile opCertInfo = case opCertInfo of -- | 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). -- -runQueryPoolStateCmd - :: SocketPath - -> AnyConsensusModeParams - -> NetworkId - -> [Hash StakePoolKey] +runQueryPoolStateCmd :: () + => Cmd.QueryPoolStateCmdArgs -> ExceptT QueryCmdError IO () -runQueryPoolStateCmd socketPath (AnyConsensusModeParams cModeParams) network poolIds = do - let localNodeConnInfo = LocalNodeConnectInfo cModeParams network socketPath +runQueryPoolStateCmd + Cmd.QueryPoolStateCmdArgs + { Cmd.nodeSocketPath + , Cmd.consensusModeParams = AnyConsensusModeParams cModeParams + , Cmd.networkId + , Cmd.poolIds + } = do + let localNodeConnInfo = LocalNodeConnectInfo cModeParams networkId nodeSocketPath join $ lift ( executeLocalStateQueryExpr localNodeConnInfo Nothing $ runExceptT $ do @@ -684,15 +686,18 @@ runQueryPoolStateCmd socketPath (AnyConsensusModeParams cModeParams) network poo & onLeft left -- | Query the local mempool state -runQueryTxMempoolCmd - :: SocketPath - -> AnyConsensusModeParams - -> NetworkId - -> TxMempoolQuery - -> Maybe (File () Out) +runQueryTxMempoolCmd :: () + => Cmd.QueryTxMempoolCmdArgs -> ExceptT QueryCmdError IO () -runQueryTxMempoolCmd socketPath (AnyConsensusModeParams cModeParams) network query mOutFile = do - let localNodeConnInfo = LocalNodeConnectInfo cModeParams network socketPath +runQueryTxMempoolCmd + Cmd.QueryTxMempoolCmdArgs + { Cmd.nodeSocketPath + , Cmd.consensusModeParams = AnyConsensusModeParams cModeParams + , Cmd.networkId + , Cmd.query + , Cmd.mOutFile + } = do + let localNodeConnInfo = LocalNodeConnectInfo cModeParams networkId nodeSocketPath localQuery <- case query of TxMempoolQueryTxExists tx -> do @@ -713,28 +718,34 @@ runQueryTxMempoolCmd socketPath (AnyConsensusModeParams cModeParams) network que Just (File oFp) -> handleIOExceptT (QueryCmdWriteFileError . FileIOError oFp) $ LBS.writeFile oFp renderedResult -runQuerySlotNumberCmd - :: SocketPath - -> AnyConsensusModeParams - -> NetworkId - -> UTCTime +runQuerySlotNumberCmd :: () + => Cmd.QuerySlotNumberCmdArgs -> ExceptT QueryCmdError IO () -runQuerySlotNumberCmd sockPath aCmp network utcTime = do - SlotNo slotNo <- utcTimeToSlotNo sockPath aCmp network utcTime +runQuerySlotNumberCmd + Cmd.QuerySlotNumberCmdArgs + { Cmd.nodeSocketPath + , Cmd.consensusModeParams + , Cmd.networkId + , Cmd.utcTime + } = do + SlotNo slotNo <- utcTimeToSlotNo nodeSocketPath consensusModeParams networkId utcTime liftIO . putStr $ show slotNo -- | 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. -runQueryStakeSnapshotCmd - :: SocketPath - -> AnyConsensusModeParams - -> NetworkId - -> AllOrOnly [Hash StakePoolKey] - -> Maybe (File () Out) +runQueryStakeSnapshotCmd :: () + => Cmd.QueryStakeSnapshotCmdArgs -> ExceptT QueryCmdError IO () -runQueryStakeSnapshotCmd socketPath (AnyConsensusModeParams cModeParams) network allOrOnlyPoolIds mOutFile = do - let localNodeConnInfo = LocalNodeConnectInfo cModeParams network socketPath +runQueryStakeSnapshotCmd + Cmd.QueryStakeSnapshotCmdArgs + { Cmd.nodeSocketPath + , Cmd.consensusModeParams = AnyConsensusModeParams cModeParams + , Cmd.networkId + , Cmd.allOrOnlyPoolIds + , Cmd.mOutFile + } = do + let localNodeConnInfo = LocalNodeConnectInfo cModeParams networkId nodeSocketPath join $ lift ( executeLocalStateQueryExpr localNodeConnInfo Nothing $ runExceptT $ do @@ -767,14 +778,17 @@ runQueryStakeSnapshotCmd socketPath (AnyConsensusModeParams cModeParams) network & onLeft (left . QueryCmdAcquireFailure) & onLeft left -runQueryLedgerStateCmd - :: SocketPath - -> AnyConsensusModeParams - -> NetworkId - -> Maybe (File () Out) +runQueryLedgerStateCmd :: () + => Cmd.QueryLedgerStateCmdArgs -> ExceptT QueryCmdError IO () -runQueryLedgerStateCmd socketPath (AnyConsensusModeParams cModeParams) network mOutFile = do - let localNodeConnInfo = LocalNodeConnectInfo cModeParams network socketPath +runQueryLedgerStateCmd + Cmd.QueryLedgerStateCmdArgs + { Cmd.nodeSocketPath + , Cmd.consensusModeParams = AnyConsensusModeParams cModeParams + , Cmd.networkId + , Cmd.mOutFile + } = do + let localNodeConnInfo = LocalNodeConnectInfo cModeParams networkId nodeSocketPath join $ lift ( executeLocalStateQueryExpr localNodeConnInfo Nothing $ runExceptT $ do @@ -803,14 +817,17 @@ runQueryLedgerStateCmd socketPath (AnyConsensusModeParams cModeParams) network m & onLeft (left . QueryCmdAcquireFailure) & onLeft left -runQueryProtocolStateCmd - :: SocketPath - -> AnyConsensusModeParams - -> NetworkId - -> Maybe (File () Out) +runQueryProtocolStateCmd :: () + => Cmd.QueryProtocolStateCmdArgs -> ExceptT QueryCmdError IO () -runQueryProtocolStateCmd socketPath (AnyConsensusModeParams cModeParams) network mOutFile = do - let localNodeConnInfo = LocalNodeConnectInfo cModeParams network socketPath +runQueryProtocolStateCmd + Cmd.QueryProtocolStateCmdArgs + { Cmd.nodeSocketPath + , Cmd.consensusModeParams = AnyConsensusModeParams cModeParams + , Cmd.networkId + , Cmd.mOutFile + } = do + let localNodeConnInfo = LocalNodeConnectInfo cModeParams networkId nodeSocketPath join $ lift ( executeLocalStateQueryExpr localNodeConnInfo Nothing $ runExceptT $ do @@ -844,15 +861,18 @@ runQueryProtocolStateCmd socketPath (AnyConsensusModeParams cModeParams) network -- | Query the current delegations and reward accounts, filtered by a given -- set of addresses, from a Shelley node via the local state query protocol. -runQueryStakeAddressInfoCmd - :: SocketPath - -> AnyConsensusModeParams - -> StakeAddress - -> NetworkId - -> Maybe (File () Out) +runQueryStakeAddressInfoCmd :: () + => Cmd.QueryStakeAddressInfoCmdArgs -> ExceptT QueryCmdError IO () -runQueryStakeAddressInfoCmd socketPath (AnyConsensusModeParams cModeParams) (StakeAddress _ addr) network mOutFile = do - let localNodeConnInfo = LocalNodeConnectInfo cModeParams network socketPath +runQueryStakeAddressInfoCmd + Cmd.QueryStakeAddressInfoCmdArgs + { Cmd.nodeSocketPath + , Cmd.consensusModeParams = AnyConsensusModeParams cModeParams + , Cmd.addr = StakeAddress _ addr + , Cmd.networkId + , Cmd.mOutFile + } = do + let localNodeConnInfo = LocalNodeConnectInfo cModeParams networkId nodeSocketPath join $ lift ( executeLocalStateQueryExpr localNodeConnInfo Nothing $ runExceptT $ do @@ -873,7 +893,7 @@ runQueryStakeAddressInfoCmd socketPath (AnyConsensusModeParams cModeParams) (Sta requireNotByronEraInByronMode eraInMode - result <- lift (queryStakeAddresses eInMode sbe stakeAddr network) + result <- lift (queryStakeAddresses eInMode sbe stakeAddr networkId) & onLeft (left . QueryCmdUnsupportedNtcVersion) & onLeft (left . QueryCmdLocalStateQueryError . EraMismatchError) @@ -1080,14 +1100,17 @@ printUtxo sbe txInOutTuple = printableValue (TxOutValue _ val) = renderValue val printableValue (TxOutAdaOnly _ (Lovelace i)) = Text.pack $ show i -runQueryStakePoolsCmd - :: SocketPath - -> AnyConsensusModeParams - -> NetworkId - -> Maybe (File () Out) +runQueryStakePoolsCmd :: () + => Cmd.QueryStakePoolsCmdArgs -> ExceptT QueryCmdError IO () -runQueryStakePoolsCmd socketPath (AnyConsensusModeParams cModeParams) network mOutFile = do - let localNodeConnInfo = LocalNodeConnectInfo cModeParams network socketPath +runQueryStakePoolsCmd + Cmd.QueryStakePoolsCmdArgs + { Cmd.nodeSocketPath + , Cmd.consensusModeParams = AnyConsensusModeParams cModeParams + , Cmd.networkId + , Cmd.mOutFile + } = do + let localNodeConnInfo = LocalNodeConnectInfo cModeParams networkId nodeSocketPath join $ lift ( executeLocalStateQueryExpr localNodeConnInfo Nothing $ runExceptT @QueryCmdError $ do @@ -1125,14 +1148,17 @@ writeStakePools Nothing stakePools = forM_ (Set.toList stakePools) $ \poolId -> liftIO . putStrLn $ Text.unpack (serialiseToBech32 poolId) -runQueryStakeDistributionCmd - :: SocketPath - -> AnyConsensusModeParams - -> NetworkId - -> Maybe (File () Out) +runQueryStakeDistributionCmd :: () + => Cmd.QueryStakeDistributionCmdArgs -> ExceptT QueryCmdError IO () -runQueryStakeDistributionCmd socketPath (AnyConsensusModeParams cModeParams) network mOutFile = do - let localNodeConnInfo = LocalNodeConnectInfo cModeParams network socketPath +runQueryStakeDistributionCmd + Cmd.QueryStakeDistributionCmdArgs + { Cmd.nodeSocketPath + , Cmd.consensusModeParams = AnyConsensusModeParams cModeParams + , Cmd.networkId + , Cmd.mOutFile + } = do + let localNodeConnInfo = LocalNodeConnectInfo cModeParams networkId nodeSocketPath join $ lift ( executeLocalStateQueryExpr localNodeConnInfo Nothing $ runExceptT $ do @@ -1197,25 +1223,25 @@ printStakeDistribution stakeDistrib = do ] runQueryLeadershipScheduleCmd - :: SocketPath - -> AnyConsensusModeParams - -> NetworkId - -> GenesisFile -- ^ Shelley genesis - -> VerificationKeyOrHashOrFile StakePoolKey - -> SigningKeyFile In -- ^ VRF signing key - -> EpochLeadershipSchedule - -> Maybe (File () Out) + :: Cmd.QueryLeadershipScheduleCmdArgs -> ExceptT QueryCmdError IO () runQueryLeadershipScheduleCmd - socketPath (AnyConsensusModeParams cModeParams) network - (GenesisFile genFile) coldVerKeyFile vrfSkeyFp - whichSchedule mJsonOutputFile = do - let localNodeConnInfo = LocalNodeConnectInfo cModeParams network socketPath - - poolid <- lift (readVerificationKeyOrHashOrFile AsStakePoolKey coldVerKeyFile) + Cmd.QueryLeadershipScheduleCmdArgs + { Cmd.nodeSocketPath + , Cmd.consensusModeParams = AnyConsensusModeParams cModeParams + , Cmd.networkId + , Cmd.genesisFp = GenesisFile genFile + , Cmd.poolColdVerKeyFile + , Cmd.vrkSkeyFp + , Cmd.whichSchedule + , Cmd.mOutFile + } = do + let localNodeConnInfo = LocalNodeConnectInfo cModeParams networkId nodeSocketPath + + poolid <- lift (readVerificationKeyOrHashOrFile AsStakePoolKey poolColdVerKeyFile) & onLeft (left . QueryCmdTextReadError) - vrkSkey <- lift (readFileTextEnvelope (AsSigningKey AsVrfKey) vrfSkeyFp) + vrkSkey <- lift (readFileTextEnvelope (AsSigningKey AsVrfKey) vrkSkeyFp) & onLeft (left . QueryCmdTextEnvelopeReadError) shelleyGenesis <- lift (readAndDecodeShelleyGenesis genFile) @@ -1277,7 +1303,7 @@ runQueryLeadershipScheduleCmd serCurrentEpochState curentEpoch - writeSchedule mJsonOutputFile eInfo shelleyGenesis schedule + writeSchedule mOutFile eInfo shelleyGenesis schedule NextEpoch -> do serCurrentEpochState <- lift (queryCurrentEpochState eInMode sbe) @@ -1293,7 +1319,7 @@ runQueryLeadershipScheduleCmd serCurrentEpochState ptclState poolid vrkSkey pparams eInfo (tip, curentEpoch) - writeSchedule mJsonOutputFile eInfo shelleyGenesis schedule + writeSchedule mOutFile eInfo shelleyGenesis schedule mode -> pure $ do left . QueryCmdUnsupportedMode $ AnyConsensusMode mode @@ -1301,8 +1327,8 @@ runQueryLeadershipScheduleCmd & onLeft (left . QueryCmdAcquireFailure) & onLeft left where - writeSchedule mOutFile eInfo shelleyGenesis schedule = - case mOutFile of + writeSchedule mOutFile' eInfo shelleyGenesis schedule = + case mOutFile' of Nothing -> liftIO $ printLeadershipScheduleAsText schedule eInfo (SystemStart $ sgSystemStart shelleyGenesis) Just (File jsonOutputFile) -> liftIO $ LBS.writeFile jsonOutputFile $ @@ -1416,8 +1442,8 @@ utcTimeToSlotNo -> NetworkId -> UTCTime -> ExceptT QueryCmdError IO SlotNo -utcTimeToSlotNo socketPath (AnyConsensusModeParams cModeParams) network utcTime = do - let localNodeConnInfo = LocalNodeConnectInfo cModeParams network socketPath +utcTimeToSlotNo nodeSocketPath (AnyConsensusModeParams cModeParams) networkId utcTime = do + let localNodeConnInfo = LocalNodeConnectInfo cModeParams networkId nodeSocketPath case consensusModeOnly cModeParams of CardanoMode -> do lift diff --git a/cardano-cli/src/Cardano/CLI/Legacy/Commands/Query.hs b/cardano-cli/src/Cardano/CLI/Legacy/Commands/Query.hs index abb24a926a..d5f43cce92 100644 --- a/cardano-cli/src/Cardano/CLI/Legacy/Commands/Query.hs +++ b/cardano-cli/src/Cardano/CLI/Legacy/Commands/Query.hs @@ -1,8 +1,25 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE LambdaCase #-} module Cardano.CLI.Legacy.Commands.Query ( LegacyQueryCmds (..) + , LegacyQueryLeadershipScheduleCmdArgs (..) + , LegacyQueryProtocolParametersCmdArgs (..) + , LegacyQueryConstitutionHashCmdArgs (..) + , LegacyQueryTipCmdArgs (..) + , LegacyQueryStakePoolsCmdArgs (..) + , LegacyQueryStakeDistributionCmdArgs (..) + , LegacyQueryStakeAddressInfoCmdArgs (..) + , LegacyQueryUTxOCmdArgs (..) + , LegacyQueryLedgerStateCmdArgs (..) + , LegacyQueryProtocolStateCmdArgs (..) + , LegacyQueryStakeSnapshotCmdArgs (..) + , LegacyQueryKesPeriodInfoCmdArgs (..) + , LegacyQueryPoolStateCmdArgs (..) + , LegacyQueryTxMempoolCmdArgs (..) + , LegacyQuerySlotNumberCmdArgs (..) , renderLegacyQueryCmds ) where @@ -13,115 +30,160 @@ import Cardano.CLI.Types.Key import Data.Text (Text) import Data.Time.Clock +import GHC.Generics -data LegacyQueryCmds = - QueryLeadershipSchedule - SocketPath - AnyConsensusModeParams - NetworkId - GenesisFile - (VerificationKeyOrHashOrFile StakePoolKey) - (SigningKeyFile In) - EpochLeadershipSchedule - (Maybe (File () Out)) - | QueryProtocolParameters' - SocketPath - AnyConsensusModeParams - NetworkId - (Maybe (File () Out)) - | QueryConstitutionHash - SocketPath - AnyConsensusModeParams - NetworkId - (Maybe (File () Out)) - | QueryTip - SocketPath - AnyConsensusModeParams - NetworkId - (Maybe (File () Out)) - | QueryStakePools' - SocketPath - AnyConsensusModeParams - NetworkId - (Maybe (File () Out)) - | QueryStakeDistribution' - SocketPath - AnyConsensusModeParams - NetworkId - (Maybe (File () Out)) - | QueryStakeAddressInfo - SocketPath - AnyConsensusModeParams - StakeAddress - NetworkId - (Maybe (File () Out)) - | QueryUTxO' - SocketPath - AnyConsensusModeParams - QueryUTxOFilter - NetworkId - (Maybe (File () Out)) - | QueryDebugLedgerState' - SocketPath - AnyConsensusModeParams - NetworkId - (Maybe (File () Out)) - | QueryProtocolState' - SocketPath - AnyConsensusModeParams - NetworkId - (Maybe (File () Out)) - | QueryStakeSnapshot' - SocketPath - AnyConsensusModeParams - NetworkId - (AllOrOnly [Hash StakePoolKey]) - (Maybe (File () Out)) - | QueryKesPeriodInfo - SocketPath - AnyConsensusModeParams - NetworkId - (File () In) - -- ^ Node operational certificate - (Maybe (File () Out)) - | QueryPoolState' - SocketPath - AnyConsensusModeParams - NetworkId - [Hash StakePoolKey] - | QueryTxMempool - SocketPath - AnyConsensusModeParams - NetworkId - TxMempoolQuery - (Maybe (File () Out)) - | QuerySlotNumber - SocketPath - AnyConsensusModeParams - NetworkId - UTCTime - deriving Show +data LegacyQueryCmds + = QueryLeadershipScheduleCmd !LegacyQueryLeadershipScheduleCmdArgs + | QueryProtocolParametersCmd !LegacyQueryProtocolParametersCmdArgs + | QueryConstitutionHashCmd !LegacyQueryConstitutionHashCmdArgs + | QueryTipCmd !LegacyQueryTipCmdArgs + | QueryStakePoolsCmd !LegacyQueryStakePoolsCmdArgs + | QueryStakeDistributionCmd !LegacyQueryStakeDistributionCmdArgs + | QueryStakeAddressInfoCmd !LegacyQueryStakeAddressInfoCmdArgs + | QueryUTxOCmd !LegacyQueryUTxOCmdArgs + | QueryLedgerStateCmd !LegacyQueryLedgerStateCmdArgs + | QueryProtocolStateCmd !LegacyQueryProtocolStateCmdArgs + | QueryStakeSnapshotCmd !LegacyQueryStakeSnapshotCmdArgs + | QueryKesPeriodInfoCmd !LegacyQueryKesPeriodInfoCmdArgs + | QueryPoolStateCmd !LegacyQueryPoolStateCmdArgs + | QueryTxMempoolCmd !LegacyQueryTxMempoolCmdArgs + | QuerySlotNumberCmd !LegacyQuerySlotNumberCmdArgs + deriving (Generic, Show) + +data LegacyQueryLeadershipScheduleCmdArgs = LegacyQueryLeadershipScheduleCmdArgs + { nodeSocketPath :: !SocketPath + , consensusModeParams :: !AnyConsensusModeParams + , networkId :: !NetworkId + , genesisFp :: !GenesisFile + , poolColdVerKeyFile :: !(VerificationKeyOrHashOrFile StakePoolKey) + , vrkSkeyFp :: !(SigningKeyFile In) + , whichSchedule :: !EpochLeadershipSchedule + , mOutFile :: !(Maybe (File () Out)) + } deriving (Generic, Show) + +data LegacyQueryProtocolParametersCmdArgs = LegacyQueryProtocolParametersCmdArgs + { nodeSocketPath :: !SocketPath + , consensusModeParams :: !AnyConsensusModeParams + , networkId :: !NetworkId + , mOutFile :: !(Maybe (File () Out)) + } deriving (Generic, Show) + +data LegacyQueryConstitutionHashCmdArgs = LegacyQueryConstitutionHashCmdArgs + { nodeSocketPath :: !SocketPath + , consensusModeParams :: !AnyConsensusModeParams + , networkId :: !NetworkId + , mOutFile :: !(Maybe (File () Out)) + } deriving (Generic, Show) + +data LegacyQueryTipCmdArgs = LegacyQueryTipCmdArgs + { nodeSocketPath :: !SocketPath + , consensusModeParams :: !AnyConsensusModeParams + , networkId :: !NetworkId + , mOutFile :: !(Maybe (File () Out)) + } deriving (Generic, Show) + +data LegacyQueryStakePoolsCmdArgs = LegacyQueryStakePoolsCmdArgs + { nodeSocketPath :: !SocketPath + , consensusModeParams :: !AnyConsensusModeParams + , networkId :: !NetworkId + , mOutFile :: !(Maybe (File () Out)) + } deriving (Generic, Show) + +data LegacyQueryStakeDistributionCmdArgs = LegacyQueryStakeDistributionCmdArgs + { nodeSocketPath :: !SocketPath + , consensusModeParams :: !AnyConsensusModeParams + , networkId :: !NetworkId + , mOutFile :: !(Maybe (File () Out)) + } deriving (Generic, Show) + +data LegacyQueryStakeAddressInfoCmdArgs = LegacyQueryStakeAddressInfoCmdArgs + { nodeSocketPath :: !SocketPath + , consensusModeParams :: !AnyConsensusModeParams + , addr :: !StakeAddress + , networkId :: !NetworkId + , mOutFile :: !(Maybe (File () Out)) + } deriving (Generic, Show) + +data LegacyQueryUTxOCmdArgs = LegacyQueryUTxOCmdArgs + { nodeSocketPath :: !SocketPath + , consensusModeParams :: !AnyConsensusModeParams + , queryFilter :: !QueryUTxOFilter + , networkId :: !NetworkId + , mOutFile :: !(Maybe (File () Out)) + } deriving (Generic, Show) + +data LegacyQueryLedgerStateCmdArgs = LegacyQueryLedgerStateCmdArgs + { nodeSocketPath :: !SocketPath + , consensusModeParams :: !AnyConsensusModeParams + , networkId :: !NetworkId + , mOutFile :: !(Maybe (File () Out)) + } deriving (Generic, Show) + +data LegacyQueryProtocolStateCmdArgs = LegacyQueryProtocolStateCmdArgs + { nodeSocketPath :: !SocketPath + , consensusModeParams :: !AnyConsensusModeParams + , networkId :: !NetworkId + , mOutFile :: !(Maybe (File () Out)) + } deriving (Generic, Show) + +data LegacyQueryStakeSnapshotCmdArgs = LegacyQueryStakeSnapshotCmdArgs + { nodeSocketPath :: !SocketPath + , consensusModeParams :: !AnyConsensusModeParams + , networkId :: !NetworkId + , allOrOnlyPoolIds :: !(AllOrOnly [Hash StakePoolKey]) + , mOutFile :: !(Maybe (File () Out)) + } deriving (Generic, Show) + +data LegacyQueryKesPeriodInfoCmdArgs = LegacyQueryKesPeriodInfoCmdArgs + { nodeSocketPath :: !SocketPath + , consensusModeParams :: !AnyConsensusModeParams + , networkId :: !NetworkId + , nodeOpCertFp :: !(File () In) -- ^ Node operational certificate + , mOutFile :: !(Maybe (File () Out)) + } deriving (Generic, Show) + +data LegacyQueryPoolStateCmdArgs = LegacyQueryPoolStateCmdArgs + { nodeSocketPath :: !SocketPath + , consensusModeParams :: !AnyConsensusModeParams + , networkId :: !NetworkId + , poolIds :: ![Hash StakePoolKey] + } deriving (Generic, Show) + +data LegacyQueryTxMempoolCmdArgs = LegacyQueryTxMempoolCmdArgs + { nodeSocketPath :: !SocketPath + , consensusModeParams :: !AnyConsensusModeParams + , networkId :: !NetworkId + , query :: !TxMempoolQuery + , mOutFile :: !(Maybe (File () Out)) + } + deriving (Generic, Show) + +data LegacyQuerySlotNumberCmdArgs = LegacyQuerySlotNumberCmdArgs + { nodeSocketPath :: !SocketPath + , consensusModeParams :: !AnyConsensusModeParams + , networkId :: !NetworkId + , utcTime :: !UTCTime + } deriving (Generic, Show) renderLegacyQueryCmds :: LegacyQueryCmds -> Text renderLegacyQueryCmds = \case - QueryLeadershipSchedule {} -> "query leadership-schedule" - QueryProtocolParameters' {} -> "query protocol-parameters " - QueryConstitutionHash {} -> "query constitution-hash " - QueryTip {} -> "query tip" - QueryStakePools' {} -> "query stake-pools" - QueryStakeDistribution' {} -> "query stake-distribution" - QueryStakeAddressInfo {} -> "query stake-address-info" - QueryUTxO' {} -> "query utxo" - QueryDebugLedgerState' {} -> "query ledger-state" - QueryProtocolState' {} -> "query protocol-state" - QueryStakeSnapshot' {} -> "query stake-snapshot" - QueryKesPeriodInfo {} -> "query kes-period-info" - QueryPoolState' {} -> "query pool-state" - QueryTxMempool _ _ _ query _ -> "query tx-mempool" <> renderTxMempoolQuery query - QuerySlotNumber {} -> "query slot-number" + QueryLeadershipScheduleCmd {} -> "query leadership-schedule" + QueryProtocolParametersCmd {} -> "query protocol-parameters " + QueryConstitutionHashCmd {} -> "query constitution-hash " + QueryTipCmd {} -> "query tip" + QueryStakePoolsCmd {} -> "query stake-pools" + QueryStakeDistributionCmd {} -> "query stake-distribution" + QueryStakeAddressInfoCmd {} -> "query stake-address-info" + QueryUTxOCmd {} -> "query utxo" + QueryLedgerStateCmd {} -> "query ledger-state" + QueryProtocolStateCmd {} -> "query protocol-state" + QueryStakeSnapshotCmd {} -> "query stake-snapshot" + QueryKesPeriodInfoCmd {} -> "query kes-period-info" + QueryPoolStateCmd {} -> "query pool-state" + QueryTxMempoolCmd (LegacyQueryTxMempoolCmdArgs _ _ _ txMempoolQuery _) -> "query tx-mempool" <> renderTxMempoolQuery txMempoolQuery + QuerySlotNumberCmd {} -> "query slot-number" where - renderTxMempoolQuery query = - case query of - TxMempoolQueryTxExists tx -> "tx-exists " <> serialiseToRawBytesHexText tx - TxMempoolQueryNextTx -> "next-tx" - TxMempoolQueryInfo -> "info" + renderTxMempoolQuery = \case + TxMempoolQueryTxExists tx -> "tx-exists " <> serialiseToRawBytesHexText tx + TxMempoolQueryNextTx -> "next-tx" + TxMempoolQueryInfo -> "info" diff --git a/cardano-cli/src/Cardano/CLI/Legacy/Options.hs b/cardano-cli/src/Cardano/CLI/Legacy/Options.hs index b222ddfe60..f27e4d78fa 100644 --- a/cardano-cli/src/Cardano/CLI/Legacy/Options.hs +++ b/cardano-cli/src/Cardano/CLI/Legacy/Options.hs @@ -844,48 +844,54 @@ pQueryCmds envCli = where pQueryProtocolParameters :: Parser LegacyQueryCmds pQueryProtocolParameters = - QueryProtocolParameters' - <$> pSocketPath envCli - <*> pConsensusModeParams - <*> pNetworkId envCli - <*> pMaybeOutputFile + fmap QueryProtocolParametersCmd $ + LegacyQueryProtocolParametersCmdArgs + <$> pSocketPath envCli + <*> pConsensusModeParams + <*> pNetworkId envCli + <*> pMaybeOutputFile pQueryConstitutionHash :: Parser LegacyQueryCmds pQueryConstitutionHash = - QueryConstitutionHash - <$> pSocketPath envCli - <*> pConsensusModeParams - <*> pNetworkId envCli - <*> pMaybeOutputFile + fmap QueryConstitutionHashCmd $ + LegacyQueryConstitutionHashCmdArgs + <$> pSocketPath envCli + <*> pConsensusModeParams + <*> pNetworkId envCli + <*> pMaybeOutputFile pQueryTip :: Parser LegacyQueryCmds pQueryTip = - QueryTip - <$> pSocketPath envCli - <*> pConsensusModeParams - <*> pNetworkId envCli - <*> pMaybeOutputFile + fmap QueryTipCmd $ + LegacyQueryTipCmdArgs + <$> pSocketPath envCli + <*> pConsensusModeParams + <*> pNetworkId envCli + <*> pMaybeOutputFile pQueryUTxO :: Parser LegacyQueryCmds pQueryUTxO = - QueryUTxO' - <$> pSocketPath envCli - <*> pConsensusModeParams - <*> pQueryUTxOFilter - <*> pNetworkId envCli - <*> pMaybeOutputFile + fmap QueryUTxOCmd $ + LegacyQueryUTxOCmdArgs + <$> pSocketPath envCli + <*> pConsensusModeParams + <*> pQueryUTxOFilter + <*> pNetworkId envCli + <*> pMaybeOutputFile pQueryStakePools :: Parser LegacyQueryCmds pQueryStakePools = - QueryStakePools' - <$> pSocketPath envCli - <*> pConsensusModeParams - <*> pNetworkId envCli - <*> pMaybeOutputFile + fmap QueryStakePoolsCmd $ + LegacyQueryStakePoolsCmdArgs + <$> pSocketPath envCli + <*> pConsensusModeParams + <*> pNetworkId envCli + <*> pMaybeOutputFile pQueryStakeDistribution :: Parser LegacyQueryCmds pQueryStakeDistribution = - QueryStakeDistribution' + fmap QueryStakeDistributionCmd $ + LegacyQueryStakeDistributionCmdArgs <$> pSocketPath envCli <*> pConsensusModeParams <*> pNetworkId envCli @@ -893,7 +899,8 @@ pQueryCmds envCli = pQueryStakeAddressInfo :: Parser LegacyQueryCmds pQueryStakeAddressInfo = - QueryStakeAddressInfo + fmap QueryStakeAddressInfoCmd $ + LegacyQueryStakeAddressInfoCmdArgs <$> pSocketPath envCli <*> pConsensusModeParams <*> pFilterByStakeAddress @@ -902,7 +909,8 @@ pQueryCmds envCli = pQueryLedgerState :: Parser LegacyQueryCmds pQueryLedgerState = - QueryDebugLedgerState' + fmap QueryLedgerStateCmd $ + LegacyQueryLedgerStateCmdArgs <$> pSocketPath envCli <*> pConsensusModeParams <*> pNetworkId envCli @@ -910,11 +918,12 @@ pQueryCmds envCli = pQueryProtocolState :: Parser LegacyQueryCmds pQueryProtocolState = - QueryProtocolState' - <$> pSocketPath envCli - <*> pConsensusModeParams - <*> pNetworkId envCli - <*> pMaybeOutputFile + fmap QueryProtocolStateCmd $ + LegacyQueryProtocolStateCmdArgs + <$> pSocketPath envCli + <*> pConsensusModeParams + <*> pNetworkId envCli + <*> pMaybeOutputFile pAllStakePoolsOrOnly :: Parser (AllOrOnly [Hash StakePoolKey]) pAllStakePoolsOrOnly = pAll <|> pOnly @@ -928,29 +937,32 @@ pQueryCmds envCli = pQueryStakeSnapshot :: Parser LegacyQueryCmds pQueryStakeSnapshot = - QueryStakeSnapshot' - <$> pSocketPath envCli - <*> pConsensusModeParams - <*> pNetworkId envCli - <*> pAllStakePoolsOrOnly - <*> pMaybeOutputFile + fmap QueryStakeSnapshotCmd $ + LegacyQueryStakeSnapshotCmdArgs + <$> pSocketPath envCli + <*> pConsensusModeParams + <*> pNetworkId envCli + <*> pAllStakePoolsOrOnly + <*> pMaybeOutputFile pQueryPoolState :: Parser LegacyQueryCmds pQueryPoolState = - QueryPoolState' - <$> pSocketPath envCli - <*> pConsensusModeParams - <*> pNetworkId envCli - <*> many (pStakePoolVerificationKeyHash Nothing) + fmap QueryPoolStateCmd $ + LegacyQueryPoolStateCmdArgs + <$> pSocketPath envCli + <*> pConsensusModeParams + <*> pNetworkId envCli + <*> many (pStakePoolVerificationKeyHash Nothing) pQueryTxMempool :: Parser LegacyQueryCmds pQueryTxMempool = - QueryTxMempool - <$> pSocketPath envCli - <*> pConsensusModeParams - <*> pNetworkId envCli - <*> pTxMempoolQuery - <*> pMaybeOutputFile + fmap QueryTxMempoolCmd $ + LegacyQueryTxMempoolCmdArgs + <$> pSocketPath envCli + <*> pConsensusModeParams + <*> pNetworkId envCli + <*> pTxMempoolQuery + <*> pMaybeOutputFile where pTxMempoolQuery :: Parser TxMempoolQuery pTxMempoolQuery = asum @@ -966,38 +978,41 @@ pQueryCmds envCli = ] pLeadershipSchedule :: Parser LegacyQueryCmds pLeadershipSchedule = - QueryLeadershipSchedule - <$> pSocketPath envCli - <*> pConsensusModeParams - <*> pNetworkId envCli - <*> pGenesisFile "Shelley genesis filepath" - <*> pStakePoolVerificationKeyOrHashOrFile Nothing - <*> pVrfSigningKeyFile - <*> pWhichLeadershipSchedule - <*> pMaybeOutputFile + fmap QueryLeadershipScheduleCmd $ + LegacyQueryLeadershipScheduleCmdArgs + <$> pSocketPath envCli + <*> pConsensusModeParams + <*> pNetworkId envCli + <*> pGenesisFile "Shelley genesis filepath" + <*> pStakePoolVerificationKeyOrHashOrFile Nothing + <*> pVrfSigningKeyFile + <*> pWhichLeadershipSchedule + <*> pMaybeOutputFile pKesPeriodInfo :: Parser LegacyQueryCmds pKesPeriodInfo = - QueryKesPeriodInfo - <$> pSocketPath envCli - <*> pConsensusModeParams - <*> pNetworkId envCli - <*> pOperationalCertificateFile - <*> pMaybeOutputFile + fmap QueryKesPeriodInfoCmd $ + LegacyQueryKesPeriodInfoCmdArgs + <$> pSocketPath envCli + <*> pConsensusModeParams + <*> pNetworkId envCli + <*> pOperationalCertificateFile + <*> pMaybeOutputFile pQuerySlotNumber :: Parser LegacyQueryCmds pQuerySlotNumber = - QuerySlotNumber - <$> pSocketPath envCli - <*> pConsensusModeParams - <*> pNetworkId envCli - <*> pUtcTimestamp - where - pUtcTimestamp = - convertTime <$> (Opt.strArgument . mconcat) - [ Opt.metavar "TIMESTAMP" - , Opt.help "UTC timestamp in YYYY-MM-DDThh:mm:ssZ format" - ] + fmap QuerySlotNumberCmd $ + LegacyQuerySlotNumberCmdArgs + <$> pSocketPath envCli + <*> pConsensusModeParams + <*> pNetworkId envCli + <*> pUtcTimestamp + where + pUtcTimestamp = + convertTime <$> (Opt.strArgument . mconcat) + [ Opt.metavar "TIMESTAMP" + , Opt.help "UTC timestamp in YYYY-MM-DDThh:mm:ssZ format" + ] -- TODO: Conway era - move to Cardano.CLI.Conway.Parsers diff --git a/cardano-cli/src/Cardano/CLI/Legacy/Run/Query.hs b/cardano-cli/src/Cardano/CLI/Legacy/Run/Query.hs index e6f5f75548..626ae01e5f 100644 --- a/cardano-cli/src/Cardano/CLI/Legacy/Run/Query.hs +++ b/cardano-cli/src/Cardano/CLI/Legacy/Run/Query.hs @@ -1,195 +1,137 @@ +{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} + {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} - -{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} +{-# LANGUAGE RecordWildCards #-} module Cardano.CLI.Legacy.Run.Query ( runLegacyQueryCmds ) where -import Cardano.Api hiding (QueryInShelleyBasedEra (..)) -import Cardano.Api.Shelley hiding (QueryInShelleyBasedEra (..)) - +import qualified Cardano.CLI.EraBased.Commands.Query as EraBased import qualified Cardano.CLI.EraBased.Run.Query as EraBased -import Cardano.CLI.Legacy.Commands.Query -import Cardano.CLI.Types.Common +import qualified Cardano.CLI.Legacy.Commands.Query as Cmd import Cardano.CLI.Types.Errors.QueryCmdError -import Cardano.CLI.Types.Key (VerificationKeyOrHashOrFile) import Control.Monad.Trans.Except -import Data.Time.Clock -runLegacyQueryCmds :: LegacyQueryCmds -> ExceptT QueryCmdError IO () +runLegacyQueryCmds :: Cmd.LegacyQueryCmds -> ExceptT QueryCmdError IO () runLegacyQueryCmds = \case - QueryLeadershipSchedule mNodeSocketPath consensusModeParams network shelleyGenFp poolid vrkSkeyFp whichSchedule outputAs -> - runLegacyQueryLeadershipScheduleCmd mNodeSocketPath consensusModeParams network shelleyGenFp poolid vrkSkeyFp whichSchedule outputAs - QueryProtocolParameters' mNodeSocketPath consensusModeParams network mOutFile -> - runLegacyQueryProtocolParametersCmd mNodeSocketPath consensusModeParams network mOutFile - QueryConstitutionHash mNodeSocketPath consensusModeParams network mOutFile -> - runLegacyQueryConstitutionHashCmd mNodeSocketPath consensusModeParams network mOutFile - QueryTip mNodeSocketPath consensusModeParams network mOutFile -> - runLegacyQueryTipCmd mNodeSocketPath consensusModeParams network mOutFile - QueryStakePools' mNodeSocketPath consensusModeParams network mOutFile -> - runLegacyQueryStakePoolsCmd mNodeSocketPath consensusModeParams network mOutFile - QueryStakeDistribution' mNodeSocketPath consensusModeParams network mOutFile -> - runLegacyQueryStakeDistributionCmd mNodeSocketPath consensusModeParams network mOutFile - QueryStakeAddressInfo mNodeSocketPath consensusModeParams addr network mOutFile -> - runLegacyQueryStakeAddressInfoCmd mNodeSocketPath consensusModeParams addr network mOutFile - QueryDebugLedgerState' mNodeSocketPath consensusModeParams network mOutFile -> - runLegacyQueryLedgerStateCmd mNodeSocketPath consensusModeParams network mOutFile - QueryStakeSnapshot' mNodeSocketPath consensusModeParams network allOrOnlyPoolIds mOutFile -> - runLegacyQueryStakeSnapshotCmd mNodeSocketPath consensusModeParams network allOrOnlyPoolIds mOutFile - QueryProtocolState' mNodeSocketPath consensusModeParams network mOutFile -> - runLegacyQueryProtocolStateCmd mNodeSocketPath consensusModeParams network mOutFile - QueryUTxO' mNodeSocketPath consensusModeParams qFilter networkId mOutFile -> - runLegacyQueryUTxOCmd mNodeSocketPath consensusModeParams qFilter networkId mOutFile - QueryKesPeriodInfo mNodeSocketPath consensusModeParams network nodeOpCert mOutFile -> - runLegacyQueryKesPeriodInfoCmd mNodeSocketPath consensusModeParams network nodeOpCert mOutFile - QueryPoolState' mNodeSocketPath consensusModeParams network poolid -> - runLegacyQueryPoolStateCmd mNodeSocketPath consensusModeParams network poolid - QueryTxMempool mNodeSocketPath consensusModeParams network op mOutFile -> - runLegacyQueryTxMempoolCmd mNodeSocketPath consensusModeParams network op mOutFile - QuerySlotNumber mNodeSocketPath consensusModeParams network utcTime -> - runLegacyQuerySlotNumberCmd mNodeSocketPath consensusModeParams network utcTime + Cmd.QueryLeadershipScheduleCmd args -> runLegacyQueryLeadershipScheduleCmd args + Cmd.QueryProtocolParametersCmd args -> runLegacyQueryProtocolParametersCmd args + Cmd.QueryConstitutionHashCmd args -> runLegacyQueryConstitutionHashCmd args + Cmd.QueryTipCmd args -> runLegacyQueryTipCmd args + Cmd.QueryStakePoolsCmd args -> runLegacyQueryStakePoolsCmd args + Cmd.QueryStakeDistributionCmd args -> runLegacyQueryStakeDistributionCmd args + Cmd.QueryStakeAddressInfoCmd args -> runLegacyQueryStakeAddressInfoCmd args + Cmd.QueryLedgerStateCmd args -> runLegacyQueryLedgerStateCmd args + Cmd.QueryStakeSnapshotCmd args -> runLegacyQueryStakeSnapshotCmd args + Cmd.QueryProtocolStateCmd args -> runLegacyQueryProtocolStateCmd args + Cmd.QueryUTxOCmd args -> runLegacyQueryUTxOCmd args + Cmd.QueryKesPeriodInfoCmd args -> runLegacyQueryKesPeriodInfoCmd args + Cmd.QueryPoolStateCmd args -> runLegacyQueryPoolStateCmd args + Cmd.QueryTxMempoolCmd args -> runLegacyQueryTxMempoolCmd args + Cmd.QuerySlotNumberCmd args -> runLegacyQuerySlotNumberCmd args runLegacyQueryConstitutionHashCmd :: () - => SocketPath - -> AnyConsensusModeParams - -> NetworkId - -> Maybe (File () Out) + => Cmd.LegacyQueryConstitutionHashCmdArgs -> ExceptT QueryCmdError IO () -runLegacyQueryConstitutionHashCmd = EraBased.runQueryConstitutionHashCmd +runLegacyQueryConstitutionHashCmd Cmd.LegacyQueryConstitutionHashCmdArgs {..} = + EraBased.runQueryConstitutionHashCmd EraBased.QueryConstitutionHashCmdArgs {..} runLegacyQueryProtocolParametersCmd :: () - => SocketPath - -> AnyConsensusModeParams - -> NetworkId - -> Maybe (File () Out) + => Cmd.LegacyQueryProtocolParametersCmdArgs -> ExceptT QueryCmdError IO () -runLegacyQueryProtocolParametersCmd = EraBased.runQueryProtocolParametersCmd +runLegacyQueryProtocolParametersCmd Cmd.LegacyQueryProtocolParametersCmdArgs {..} = + EraBased.runQueryProtocolParametersCmd EraBased.QueryProtocolParametersCmdArgs {..} runLegacyQueryTipCmd :: () - => SocketPath - -> AnyConsensusModeParams - -> NetworkId - -> Maybe (File () Out) + => Cmd.LegacyQueryTipCmdArgs -> ExceptT QueryCmdError IO () -runLegacyQueryTipCmd = EraBased.runQueryTipCmd +runLegacyQueryTipCmd Cmd.LegacyQueryTipCmdArgs {..} = + EraBased.runQueryTipCmd EraBased.QueryTipCmdArgs {..} -- | Query the UTxO, filtered by a given set of addresses, from a Shelley node -- via the local state query protocol. runLegacyQueryUTxOCmd :: () - => SocketPath - -> AnyConsensusModeParams - -> QueryUTxOFilter - -> NetworkId - -> Maybe (File () Out) + => Cmd.LegacyQueryUTxOCmdArgs -> ExceptT QueryCmdError IO () -runLegacyQueryUTxOCmd = EraBased.runQueryUTxOCmd +runLegacyQueryUTxOCmd Cmd.LegacyQueryUTxOCmdArgs {..} = + EraBased.runQueryUTxOCmd EraBased.QueryUTxOCmdArgs {..} runLegacyQueryKesPeriodInfoCmd :: () - => SocketPath - -> AnyConsensusModeParams - -> NetworkId - -> File () In - -> Maybe (File () Out) + => Cmd.LegacyQueryKesPeriodInfoCmdArgs -> ExceptT QueryCmdError IO () -runLegacyQueryKesPeriodInfoCmd = EraBased.runQueryKesPeriodInfoCmd +runLegacyQueryKesPeriodInfoCmd Cmd.LegacyQueryKesPeriodInfoCmdArgs {..} = + EraBased.runQueryKesPeriodInfoCmd EraBased.QueryKesPeriodInfoCmdArgs {..} -- | 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). -- runLegacyQueryPoolStateCmd :: () - => SocketPath - -> AnyConsensusModeParams - -> NetworkId - -> [Hash StakePoolKey] + => Cmd.LegacyQueryPoolStateCmdArgs -> ExceptT QueryCmdError IO () -runLegacyQueryPoolStateCmd = EraBased.runQueryPoolStateCmd +runLegacyQueryPoolStateCmd Cmd.LegacyQueryPoolStateCmdArgs {..} = + EraBased.runQueryPoolStateCmd EraBased.QueryPoolStateCmdArgs {..} -- | Query the local mempool state runLegacyQueryTxMempoolCmd :: () - => SocketPath - -> AnyConsensusModeParams - -> NetworkId - -> TxMempoolQuery - -> Maybe (File () Out) + => Cmd.LegacyQueryTxMempoolCmdArgs -> ExceptT QueryCmdError IO () -runLegacyQueryTxMempoolCmd = EraBased.runQueryTxMempoolCmd +runLegacyQueryTxMempoolCmd Cmd.LegacyQueryTxMempoolCmdArgs {..} = + EraBased.runQueryTxMempoolCmd EraBased.QueryTxMempoolCmdArgs {..} runLegacyQuerySlotNumberCmd :: () - => SocketPath - -> AnyConsensusModeParams - -> NetworkId - -> UTCTime + => Cmd.LegacyQuerySlotNumberCmdArgs -> ExceptT QueryCmdError IO () -runLegacyQuerySlotNumberCmd = EraBased.runQuerySlotNumberCmd +runLegacyQuerySlotNumberCmd Cmd.LegacyQuerySlotNumberCmdArgs {..} = + EraBased.runQuerySlotNumberCmd EraBased.QuerySlotNumberCmdArgs {..} -- | 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. runLegacyQueryStakeSnapshotCmd :: () - => SocketPath - -> AnyConsensusModeParams - -> NetworkId - -> AllOrOnly [Hash StakePoolKey] - -> Maybe (File () Out) + => Cmd.LegacyQueryStakeSnapshotCmdArgs -> ExceptT QueryCmdError IO () -runLegacyQueryStakeSnapshotCmd = EraBased.runQueryStakeSnapshotCmd +runLegacyQueryStakeSnapshotCmd Cmd.LegacyQueryStakeSnapshotCmdArgs {..} = + EraBased.runQueryStakeSnapshotCmd EraBased.QueryStakeSnapshotCmdArgs {..} runLegacyQueryLedgerStateCmd :: () - => SocketPath - -> AnyConsensusModeParams - -> NetworkId - -> Maybe (File () Out) + => Cmd.LegacyQueryLedgerStateCmdArgs -> ExceptT QueryCmdError IO () -runLegacyQueryLedgerStateCmd = EraBased.runQueryLedgerStateCmd +runLegacyQueryLedgerStateCmd Cmd.LegacyQueryLedgerStateCmdArgs {..} = + EraBased.runQueryLedgerStateCmd EraBased.QueryLedgerStateCmdArgs {..} runLegacyQueryProtocolStateCmd :: () - => SocketPath - -> AnyConsensusModeParams - -> NetworkId - -> Maybe (File () Out) + => Cmd.LegacyQueryProtocolStateCmdArgs -> ExceptT QueryCmdError IO () -runLegacyQueryProtocolStateCmd = EraBased.runQueryProtocolStateCmd +runLegacyQueryProtocolStateCmd Cmd.LegacyQueryProtocolStateCmdArgs {..} = + EraBased.runQueryProtocolStateCmd EraBased.QueryProtocolStateCmdArgs {..} -- | Query the current delegations and reward accounts, filtered by a given -- set of addresses, from a Shelley node via the local state query protocol. runLegacyQueryStakeAddressInfoCmd :: () - => SocketPath - -> AnyConsensusModeParams - -> StakeAddress - -> NetworkId - -> Maybe (File () Out) + => Cmd.LegacyQueryStakeAddressInfoCmdArgs -> ExceptT QueryCmdError IO () -runLegacyQueryStakeAddressInfoCmd = EraBased.runQueryStakeAddressInfoCmd +runLegacyQueryStakeAddressInfoCmd Cmd.LegacyQueryStakeAddressInfoCmdArgs {..} = + EraBased.runQueryStakeAddressInfoCmd EraBased.QueryStakeAddressInfoCmdArgs {..} runLegacyQueryStakePoolsCmd :: () - => SocketPath - -> AnyConsensusModeParams - -> NetworkId - -> Maybe (File () Out) + => Cmd.LegacyQueryStakePoolsCmdArgs -> ExceptT QueryCmdError IO () -runLegacyQueryStakePoolsCmd = EraBased.runQueryStakePoolsCmd +runLegacyQueryStakePoolsCmd Cmd.LegacyQueryStakePoolsCmdArgs {..} = + EraBased.runQueryStakePoolsCmd EraBased.QueryStakePoolsCmdArgs {..} runLegacyQueryStakeDistributionCmd :: () - => SocketPath - -> AnyConsensusModeParams - -> NetworkId - -> Maybe (File () Out) + => Cmd.LegacyQueryStakeDistributionCmdArgs -> ExceptT QueryCmdError IO () -runLegacyQueryStakeDistributionCmd = EraBased.runQueryStakeDistributionCmd +runLegacyQueryStakeDistributionCmd Cmd.LegacyQueryStakeDistributionCmdArgs {..} = + EraBased.runQueryStakeDistributionCmd EraBased.QueryStakeDistributionCmdArgs {..} runLegacyQueryLeadershipScheduleCmd :: () - => SocketPath - -> AnyConsensusModeParams - -> NetworkId - -> GenesisFile -- ^ Shelley genesis - -> VerificationKeyOrHashOrFile StakePoolKey - -> SigningKeyFile In -- ^ VRF signing key - -> EpochLeadershipSchedule - -> Maybe (File () Out) + => Cmd.LegacyQueryLeadershipScheduleCmdArgs -> ExceptT QueryCmdError IO () -runLegacyQueryLeadershipScheduleCmd = EraBased.runQueryLeadershipScheduleCmd +runLegacyQueryLeadershipScheduleCmd Cmd.LegacyQueryLeadershipScheduleCmdArgs {..} = + EraBased.runQueryLeadershipScheduleCmd EraBased.QueryLeadershipScheduleCmdArgs {..}