diff --git a/cardano-cli/cardano-cli.cabal b/cardano-cli/cardano-cli.cabal index f576f41feb..79406db539 100644 --- a/cardano-cli/cardano-cli.cabal +++ b/cardano-cli/cardano-cli.cabal @@ -176,7 +176,6 @@ library Cardano.CLI.Types.Errors.PlutusScriptDecodeError Cardano.CLI.Types.Errors.ProtocolParamsError Cardano.CLI.Types.Errors.QueryCmdError - Cardano.CLI.Types.Errors.QueryCmdLocalStateQueryError Cardano.CLI.Types.Errors.RegistrationError Cardano.CLI.Types.Errors.ScriptDataError Cardano.CLI.Types.Errors.ScriptDecodeError diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Run/Query.hs b/cardano-cli/src/Cardano/CLI/EraBased/Run/Query.hs index e72f5ecbd5..818719c46f 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Run/Query.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Run/Query.hs @@ -52,7 +52,6 @@ import Cardano.CLI.Helpers import Cardano.CLI.Types.Common import Cardano.CLI.Types.Errors.NodeEraMismatchError import Cardano.CLI.Types.Errors.QueryCmdError -import Cardano.CLI.Types.Errors.QueryCmdLocalStateQueryError import Cardano.CLI.Types.Key import Cardano.CLI.Types.Output (QueryDRepStateOutput (..)) import qualified Cardano.CLI.Types.Output as O @@ -310,18 +309,13 @@ runQueryUTxOCmd join $ lift ( executeLocalStateQueryExpr localNodeConnInfo target $ runExceptT $ do - AnyCardanoEra era <- - lift queryCurrentEra - & onLeft (left . QueryCmdUnsupportedNtcVersion) + AnyCardanoEra era <- easyRunQueryCurrentEra sbe <- requireShelleyBasedEra era & onNothing (left QueryCmdByronEra) - utxo <- - lift (queryUtxo sbe queryFilter) - & onLeft (left . QueryCmdUnsupportedNtcVersion) - & onLeft (left . QueryCmdLocalStateQueryError . EraMismatchError) + utxo <- easyRunQuery (queryUtxo sbe queryFilter) pure $ do writeFilteredUTxOs sbe format mOutFile utxo @@ -354,9 +348,7 @@ runQueryKesPeriodInfoCmd join $ lift ( executeLocalStateQueryExpr localNodeConnInfo target $ runExceptT $ do - AnyCardanoEra era <- - lift queryCurrentEra - & onLeft (left . QueryCmdUnsupportedNtcVersion) + AnyCardanoEra era <- easyRunQueryCurrentEra sbe <- requireShelleyBasedEra era @@ -364,23 +356,15 @@ runQueryKesPeriodInfoCmd -- We check that the KES period specified in the operational certificate is correct -- based on the KES period defined in the genesis parameters and the current slot number - gParams <- - lift (queryGenesisParameters sbe) - & onLeft (left . QueryCmdUnsupportedNtcVersion) - & onLeft (left . QueryCmdLocalStateQueryError . EraMismatchError) + gParams <- easyRunQuery (queryGenesisParameters sbe) - eraHistory <- - lift queryEraHistory - & onLeft (left . QueryCmdUnsupportedNtcVersion) + eraHistory <- easyRunQueryEraHistory let eInfo = toTentativeEpochInfo eraHistory -- We get the operational certificate counter from the protocol state and check that -- it is equivalent to what we have on disk. - ptclState <- - lift (queryProtocolState sbe) - & onLeft (left . QueryCmdUnsupportedNtcVersion) - & onLeft (left . QueryCmdLocalStateQueryError . EraMismatchError) + ptclState <- easyRunQuery (queryProtocolState sbe) pure $ do chainTip <- liftIO $ getLocalChainTip localNodeConnInfo @@ -659,9 +643,7 @@ runQueryPoolStateCmd join $ lift ( executeLocalStateQueryExpr localNodeConnInfo target $ runExceptT $ do - AnyCardanoEra era <- - lift queryCurrentEra - & onLeft (left . QueryCmdUnsupportedNtcVersion) + AnyCardanoEra era <- easyRunQueryCurrentEra sbe <- requireShelleyBasedEra era @@ -673,13 +655,9 @@ runQueryPoolStateCmd All -> Nothing Only poolIds -> Just $ fromList poolIds - result <- - lift (queryPoolState beo poolFilter) - & onLeft (left . QueryCmdUnsupportedNtcVersion) - & onLeft (left . QueryCmdLocalStateQueryError . EraMismatchError) + result <- easyRunQuery (queryPoolState beo poolFilter) - pure $ do - shelleyBasedEraConstraints sbe (writePoolState mOutFile) result + pure $ shelleyBasedEraConstraints sbe (writePoolState mOutFile) result ) & onLeft (left . QueryCmdAcquireFailure) & onLeft left @@ -753,9 +731,7 @@ runQueryRefScriptSizeCmd join $ lift ( executeLocalStateQueryExpr localNodeConnInfo target $ runExceptT $ do - AnyCardanoEra era <- - lift queryCurrentEra - & onLeft (left . QueryCmdUnsupportedNtcVersion) + AnyCardanoEra era <- easyRunQueryCurrentEra sbe <- requireShelleyBasedEra era @@ -763,10 +739,7 @@ runQueryRefScriptSizeCmd beo <- requireEon BabbageEra era - utxo <- - lift (queryUtxo sbe $ QueryUTxOByTxIn transactionInputs) - & onLeft (left . QueryCmdUnsupportedNtcVersion) - & onLeft (left . QueryCmdLocalStateQueryError . EraMismatchError) + utxo <- easyRunQuery (queryUtxo sbe $ QueryUTxOByTxIn transactionInputs) pure $ writeFormattedOutput format mOutFile $ @@ -807,9 +780,7 @@ runQueryStakeSnapshotCmd join $ lift ( executeLocalStateQueryExpr localNodeConnInfo target $ runExceptT $ do - AnyCardanoEra era <- - lift queryCurrentEra - & onLeft (left . QueryCmdUnsupportedNtcVersion) + AnyCardanoEra era <- easyRunQueryCurrentEra sbe <- requireShelleyBasedEra era @@ -821,13 +792,9 @@ runQueryStakeSnapshotCmd beo <- requireEon BabbageEra era - result <- - lift (queryStakeSnapshot beo poolFilter) - & onLeft (left . QueryCmdUnsupportedNtcVersion) - & onLeft (left . QueryCmdLocalStateQueryError . EraMismatchError) + result <- easyRunQuery (queryStakeSnapshot beo poolFilter) - pure $ do - shelleyBasedEraConstraints sbe (writeStakeSnapshots mOutFile) result + pure $ shelleyBasedEraConstraints sbe (writeStakeSnapshots mOutFile) result ) & onLeft (left . QueryCmdAcquireFailure) & onLeft left @@ -853,21 +820,15 @@ runQueryLedgerStateCmd join $ lift ( executeLocalStateQueryExpr localNodeConnInfo target $ runExceptT $ do - AnyCardanoEra era <- - lift queryCurrentEra - & onLeft (left . QueryCmdUnsupportedNtcVersion) + AnyCardanoEra era <- easyRunQueryCurrentEra sbe <- requireShelleyBasedEra era & onNothing (left QueryCmdByronEra) - result <- - lift (queryDebugLedgerState sbe) - & onLeft (left . QueryCmdUnsupportedNtcVersion) - & onLeft (left . QueryCmdLocalStateQueryError . EraMismatchError) + result <- easyRunQuery (queryDebugLedgerState sbe) - pure $ do - shelleyBasedEraConstraints sbe (writeLedgerState mOutFile) result + pure $ shelleyBasedEraConstraints sbe (writeLedgerState mOutFile) result ) & onLeft (left . QueryCmdAcquireFailure) & onLeft left @@ -893,18 +854,13 @@ runQueryProtocolStateCmd join $ lift ( executeLocalStateQueryExpr localNodeConnInfo target $ runExceptT $ do - AnyCardanoEra era <- - lift queryCurrentEra - & onLeft (left . QueryCmdUnsupportedNtcVersion) + AnyCardanoEra era <- easyRunQueryCurrentEra sbe <- requireShelleyBasedEra era & onNothing (left QueryCmdByronEra) - result <- - lift (queryProtocolState sbe) - & onLeft (left . QueryCmdUnsupportedNtcVersion) - & onLeft (left . QueryCmdLocalStateQueryError . EraMismatchError) + result <- easyRunQuery (queryProtocolState sbe) pure $ shelleyBasedEraConstraints sbe $ writeProtocolState sbe mOutFile result ) @@ -934,9 +890,7 @@ runQueryStakeAddressInfoCmd join $ lift ( executeLocalStateQueryExpr localNodeConnInfo target $ runExceptT $ do - AnyCardanoEra era <- - lift queryCurrentEra - & onLeft (left . QueryCmdUnsupportedNtcVersion) + AnyCardanoEra era <- easyRunQueryCurrentEra sbe <- requireShelleyBasedEra era @@ -945,21 +899,14 @@ runQueryStakeAddressInfoCmd let stakeAddr = Set.singleton $ fromShelleyStakeCredential addr (stakeRewardAccountBalances, stakePools) <- - lift (queryStakeAddresses sbe stakeAddr networkId) - & onLeft (left . QueryCmdUnsupportedNtcVersion) - & onLeft (left . QueryCmdLocalStateQueryError . EraMismatchError) + easyRunQuery (queryStakeAddresses sbe stakeAddr networkId) beo <- requireEon BabbageEra era - stakeDelegDeposits <- - lift (queryStakeDelegDeposits beo stakeAddr) - & onLeft (left . QueryCmdUnsupportedNtcVersion) - & onLeft (left . QueryCmdLocalStateQueryError . EraMismatchError) + stakeDelegDeposits <- easyRunQuery (queryStakeDelegDeposits beo stakeAddr) stakeVoteDelegatees <- monoidForEraInEonA era $ \ceo -> - lift (queryStakeVoteDelegatees ceo stakeAddr) - & onLeft (left . QueryCmdUnsupportedNtcVersion) - & onLeft (left . QueryCmdLocalStateQueryError . EraMismatchError) + easyRunQuery (queryStakeVoteDelegatees ceo stakeAddr) return $ do writeStakeAddressInfo @@ -1281,16 +1228,13 @@ runQueryStakePoolsCmd join $ lift ( executeLocalStateQueryExpr localNodeConnInfo target $ runExceptT @QueryCmdError $ do - AnyCardanoEra era <- lift queryCurrentEra & onLeft (left . QueryCmdUnsupportedNtcVersion) + AnyCardanoEra era <- easyRunQueryCurrentEra sbe <- requireShelleyBasedEra era & onNothing (left QueryCmdByronEra) - poolIds <- - lift (queryStakePools sbe) - & onLeft (left . QueryCmdUnsupportedNtcVersion) - & onLeft (left . QueryCmdEraMismatch) + poolIds <- easyRunQuery (queryStakePools sbe) pure $ writeStakePools (newOutputFormat format mOutFile) mOutFile poolIds ) @@ -1354,18 +1298,13 @@ runQueryStakeDistributionCmd join $ lift ( executeLocalStateQueryExpr localNodeConnInfo target $ runExceptT $ do - AnyCardanoEra era <- - lift queryCurrentEra - & onLeft (left . QueryCmdUnsupportedNtcVersion) + AnyCardanoEra era <- easyRunQueryCurrentEra sbe <- requireShelleyBasedEra era & onNothing (left QueryCmdByronEra) - result <- - lift (queryStakeDistribution sbe) - & onLeft (left . QueryCmdUnsupportedNtcVersion) - & onLeft (left . QueryCmdLocalStateQueryError . EraMismatchError) + result <- easyRunQuery (queryStakeDistribution sbe) pure $ do writeStakeDistribution (newOutputFormat format mOutFile) mOutFile result @@ -1440,43 +1379,25 @@ runQueryLeadershipScheduleCmd join $ lift ( executeLocalStateQueryExpr localNodeConnInfo target $ runExceptT $ do - AnyCardanoEra era <- - lift queryCurrentEra - & onLeft (left . QueryCmdUnsupportedNtcVersion) + AnyCardanoEra era <- easyRunQueryCurrentEra sbe <- requireShelleyBasedEra era & onNothing (left QueryCmdByronEra) - pparams <- - lift (queryProtocolParameters sbe) - & onLeft (left . QueryCmdUnsupportedNtcVersion) - & onLeft (left . QueryCmdLocalStateQueryError . EraMismatchError) - - ptclState <- - lift (queryProtocolState sbe) - & onLeft (left . QueryCmdUnsupportedNtcVersion) - & onLeft (left . QueryCmdLocalStateQueryError . EraMismatchError) - - eraHistory <- - lift queryEraHistory - & onLeft (left . QueryCmdUnsupportedNtcVersion) + pparams <- easyRunQuery (queryProtocolParameters sbe) + ptclState <- easyRunQuery (queryProtocolState sbe) + eraHistory <- easyRunQueryEraHistory let eInfo = toEpochInfo eraHistory - curentEpoch <- - lift (queryEpoch sbe) - & onLeft (left . QueryCmdUnsupportedNtcVersion) - & onLeft (left . QueryCmdLocalStateQueryError . EraMismatchError) + curentEpoch <- easyRunQuery (queryEpoch sbe) case whichSchedule of CurrentEpoch -> do beo <- requireEon BabbageEra era - serCurrentEpochState <- - lift (queryPoolDistribution beo (Just (Set.singleton poolid))) - & onLeft (left . QueryCmdUnsupportedNtcVersion) - & onLeft (left . QueryCmdLocalStateQueryError . EraMismatchError) + serCurrentEpochState <- easyRunQuery (queryPoolDistribution beo (Just (Set.singleton poolid))) pure $ do schedule <- @@ -1496,10 +1417,7 @@ runQueryLeadershipScheduleCmd writeSchedule mOutFile eInfo shelleyGenesis schedule NextEpoch -> do - serCurrentEpochState <- - lift (queryCurrentEpochState sbe) - & onLeft (left . QueryCmdUnsupportedNtcVersion) - & onLeft (left . QueryCmdLocalStateQueryError . EraMismatchError) + serCurrentEpochState <- easyRunQuery (queryCurrentEpochState sbe) pure $ do tip <- liftIO $ getLocalChainTip localNodeConnInfo @@ -1899,13 +1817,8 @@ utcTimeToSlotNo nodeSocketPath consensusModeParams networkId target utcTime = do lift ( executeLocalStateQueryExpr localNodeConnInfo target $ runExceptT $ do - systemStart <- - lift querySystemStart - & onLeft (left . QueryCmdUnsupportedNtcVersion) - - eraHistory <- - lift queryEraHistory - & onLeft (left . QueryCmdUnsupportedNtcVersion) + systemStart <- easyRunQuerySystemStart + eraHistory <- easyRunQueryEraHistory let relTime = toRelativeTime systemStart utcTime @@ -1926,9 +1839,7 @@ requireEon -- TODO: implement 'Bounded' for `Some eon` and remove 'minEra' requireEon minEra era = hoistMaybe - ( QueryCmdLocalStateQueryError $ - mkEraMismatchError NodeEraMismatchError{nodeEra = era, era = minEra} - ) + (mkEraMismatchError NodeEraMismatchError{nodeEra = era, era = minEra}) (forEraMaybeEon era) -- | The output format to use, for commands with a recently introduced --output-[json,text] flag @@ -1943,3 +1854,24 @@ newOutputFormat format mOutFile = strictTextToLazyBytestring :: Text -> LBS.ByteString strictTextToLazyBytestring t = BS.fromChunks [Text.encodeUtf8 t] + +easyRunQueryCurrentEra + :: ExceptT QueryCmdError (LocalStateQueryExpr block point QueryInMode r IO) AnyCardanoEra +easyRunQueryCurrentEra = lift queryCurrentEra & onLeft (left . QueryCmdUnsupportedNtcVersion) + +easyRunQueryEraHistory + :: ExceptT QueryCmdError (LocalStateQueryExpr block point QueryInMode r IO) EraHistory +easyRunQueryEraHistory = lift queryEraHistory & onLeft (left . QueryCmdUnsupportedNtcVersion) + +easyRunQuerySystemStart + :: ExceptT QueryCmdError (LocalStateQueryExpr block point QueryInMode r IO) SystemStart +easyRunQuerySystemStart = lift querySystemStart & onLeft (left . QueryCmdUnsupportedNtcVersion) + +easyRunQuery + :: () + => Monad m + => m (Either UnsupportedNtcVersionError (Either Consensus.EraMismatch a)) -> ExceptT QueryCmdError m a +easyRunQuery q = + lift q + & onLeft (left . QueryCmdUnsupportedNtcVersion) + & onLeft (left . QueryCmdEraMismatch) diff --git a/cardano-cli/src/Cardano/CLI/Types/Errors/QueryCmdError.hs b/cardano-cli/src/Cardano/CLI/Types/Errors/QueryCmdError.hs index c271d53858..1589963411 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Errors/QueryCmdError.hs +++ b/cardano-cli/src/Cardano/CLI/Types/Errors/QueryCmdError.hs @@ -5,12 +5,14 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} module Cardano.CLI.Types.Errors.QueryCmdError ( QueryCmdError (..) , renderQueryCmdError + , mkEraMismatchError ) where @@ -21,7 +23,7 @@ import Cardano.Api.Shelley hiding (QueryInShelleyBasedEra (..)) import Cardano.Binary (DecoderError) import Cardano.CLI.Helpers (HelpersError (..), renderHelpersError) import Cardano.CLI.Types.Errors.GenesisCmdError -import Cardano.CLI.Types.Errors.QueryCmdLocalStateQueryError +import Cardano.CLI.Types.Errors.NodeEraMismatchError (NodeEraMismatchError (..)) import qualified Data.ByteString.Lazy.Char8 as LBS import Data.Text.Lazy.Builder (toLazyText) @@ -31,8 +33,7 @@ import Formatting.Buildable (build) {- HLINT ignore "Redundant flip" -} data QueryCmdError - = QueryCmdLocalStateQueryError !QueryCmdLocalStateQueryError - | QueryCmdConvenienceError !QueryConvenienceError + = QueryCmdConvenienceError !QueryConvenienceError | QueryCmdWriteFileError !(FileError ()) | QueryCmdHelpersError !HelpersError | QueryCmdAcquireFailure !AcquiringFailure @@ -56,10 +57,16 @@ data QueryCmdError | QueryCmdCommitteeHotKeyError !(FileError InputDecodeError) deriving Show +mkEraMismatchError :: NodeEraMismatchError -> QueryCmdError +mkEraMismatchError NodeEraMismatchError{nodeEra, era} = + QueryCmdEraMismatch $ + EraMismatch + { ledgerEraName = docToText $ pretty nodeEra + , otherEraName = docToText $ pretty era + } + renderQueryCmdError :: QueryCmdError -> Doc ann renderQueryCmdError = \case - QueryCmdLocalStateQueryError lsqErr -> - prettyError lsqErr QueryCmdWriteFileError fileErr -> prettyError fileErr QueryCmdHelpersError helpersErr -> diff --git a/cardano-cli/src/Cardano/CLI/Types/Errors/QueryCmdLocalStateQueryError.hs b/cardano-cli/src/Cardano/CLI/Types/Errors/QueryCmdLocalStateQueryError.hs deleted file mode 100644 index f9f7005773..0000000000 --- a/cardano-cli/src/Cardano/CLI/Types/Errors/QueryCmdLocalStateQueryError.hs +++ /dev/null @@ -1,35 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} - -module Cardano.CLI.Types.Errors.QueryCmdLocalStateQueryError - ( QueryCmdLocalStateQueryError (..) - , mkEraMismatchError - ) -where - -import Cardano.Api -import Cardano.Api.Consensus (EraMismatch (..)) - -import Cardano.CLI.Types.Errors.NodeEraMismatchError - --- | An error that can occur while querying a node's local state. -newtype QueryCmdLocalStateQueryError - = -- | A query from a certain era was applied to a ledger from a different era. - EraMismatchError EraMismatch - deriving (Eq, Show) - -mkEraMismatchError :: NodeEraMismatchError -> QueryCmdLocalStateQueryError -mkEraMismatchError NodeEraMismatchError{nodeEra, era} = - EraMismatchError - EraMismatch - { ledgerEraName = docToText $ pretty nodeEra - , otherEraName = docToText $ pretty era - } - -instance Error QueryCmdLocalStateQueryError where - prettyError = \case - EraMismatchError EraMismatch{ledgerEraName, otherEraName} -> - "A query from" - <+> pretty otherEraName - <+> "era was applied to a ledger from a different era:" - <+> pretty ledgerEraName