From 295ddcf655faea233d21d84c04f5d4d1da185260 Mon Sep 17 00:00:00 2001 From: John Ky Date: Fri, 20 Jan 2023 10:51:24 +1100 Subject: [PATCH] Modify queryExpr to check node to client version of the query it runs. --- cardano-api/cardano-api.cabal | 2 +- cardano-api/src/Cardano/Api.hs | 1 + cardano-api/src/Cardano/Api/IPC.hs | 5 +- cardano-api/src/Cardano/Api/IPC/Monad.hs | 32 ++++-- .../src/Cardano/CLI/Shelley/Run/Query.hs | 97 ++++++++++--------- 5 files changed, 77 insertions(+), 60 deletions(-) diff --git a/cardano-api/cardano-api.cabal b/cardano-api/cardano-api.cabal index e1432c3ce7e..f8de81c439a 100644 --- a/cardano-api/cardano-api.cabal +++ b/cardano-api/cardano-api.cabal @@ -166,7 +166,7 @@ library , text , time , transformers - , transformers-except + , transformers-except ^>= 0.1.3 , typed-protocols ^>= 0.1 , unordered-containers >= 0.2.11 , vector diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs index c1fe3793007..1a63a388f96 100644 --- a/cardano-api/src/Cardano/Api.hs +++ b/cardano-api/src/Cardano/Api.hs @@ -620,6 +620,7 @@ module Cardano.Api ( UTxO(..), queryNodeLocalState, executeQueryCardanoMode, + UnsupportedNtcVersionError(..), -- *** Local tx monitoring LocalTxMonitorClient(..), diff --git a/cardano-api/src/Cardano/Api/IPC.hs b/cardano-api/src/Cardano/Api/IPC.hs index 9db78aa34d3..4d4f926707c 100644 --- a/cardano-api/src/Cardano/Api/IPC.hs +++ b/cardano-api/src/Cardano/Api/IPC.hs @@ -77,7 +77,9 @@ module Cardano.Api.IPC ( consensusModeOnly, toAcquiringFailure, - NodeToClientVersion(..) + NodeToClientVersion(..), + + UnsupportedNtcVersionError(..), ) where import Prelude @@ -130,6 +132,7 @@ import qualified Ouroboros.Consensus.Shelley.Ledger.Block as Consensus import Cardano.Api.Block import Cardano.Api.HasTypeProxy import Cardano.Api.InMode +import Cardano.Api.IPC.Version import Cardano.Api.Modes import Cardano.Api.NetworkId import Cardano.Api.Protocol diff --git a/cardano-api/src/Cardano/Api/IPC/Monad.hs b/cardano-api/src/Cardano/Api/IPC/Monad.hs index df222298200..63cf096fe4b 100644 --- a/cardano-api/src/Cardano/Api/IPC/Monad.hs +++ b/cardano-api/src/Cardano/Api/IPC/Monad.hs @@ -19,6 +19,7 @@ import Data.Bifunctor (first) import Data.Either import Data.Function import Data.Maybe +import Data.Ord (Ord (..)) import System.IO import Cardano.Ledger.Shelley.Scripts () @@ -28,7 +29,9 @@ import qualified Ouroboros.Network.Protocol.LocalStateQuery.Type as Net.Query import Cardano.Api.Block import Cardano.Api.Eras import Cardano.Api.IPC +import Cardano.Api.IPC.Version import Cardano.Api.Modes +import Control.Monad.Trans.Except (ExceptT (..), runExceptT) {- HLINT ignore "Use const" -} @@ -97,21 +100,30 @@ setupLocalStateQueryExpr waitDone mPointVar' resultVar' ntcVersion f = pure $ Net.Query.SendMsgDone () } +-- | Get the node server's Node-to-Client version. +getNtcVersion :: LocalStateQueryExpr block point (QueryInMode mode) r IO NodeToClientVersion +getNtcVersion = LocalStateQueryExpr ask + -- | Use 'queryExpr' in a do block to construct monadic local state queries. -queryExpr :: QueryInMode mode a -> LocalStateQueryExpr block point (QueryInMode mode) r IO a -queryExpr q = - LocalStateQueryExpr . ReaderT $ \_ -> ContT $ \f -> pure $ - Net.Query.SendMsgQuery q $ - Net.Query.ClientStQuerying - { Net.Query.recvMsgResult = f - } +queryExpr :: QueryInMode mode a -> LocalStateQueryExpr block point (QueryInMode mode) r IO (Either UnsupportedNtcVersionError a) +queryExpr q = do + let minNtcVersion = nodeToClientVersionOf q + ntcVersion <- getNtcVersion + if ntcVersion >= minNtcVersion + then + fmap Right . LocalStateQueryExpr . ReaderT $ \_ -> ContT $ \f -> pure $ + Net.Query.SendMsgQuery q $ + Net.Query.ClientStQuerying + { Net.Query.recvMsgResult = f + } + else pure (Left (UnsupportedNtcVersionError minNtcVersion ntcVersion)) -- | A monad expression that determines what era the node is in. determineEraExpr :: ConsensusModeParams mode - -> LocalStateQueryExpr block point (QueryInMode mode) r IO AnyCardanoEra -determineEraExpr cModeParams = + -> LocalStateQueryExpr block point (QueryInMode mode) r IO (Either UnsupportedNtcVersionError AnyCardanoEra) +determineEraExpr cModeParams = runExceptT $ case consensusModeOnly cModeParams of ByronMode -> return $ AnyCardanoEra ByronEra ShelleyMode -> return $ AnyCardanoEra ShelleyEra - CardanoMode -> queryExpr $ QueryCurrentEra CardanoModeIsMultiEra + CardanoMode -> ExceptT $ queryExpr $ QueryCurrentEra CardanoModeIsMultiEra diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Run/Query.hs b/cardano-cli/src/Cardano/CLI/Shelley/Run/Query.hs index a09595f2923..51f7275b1b4 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Run/Query.hs +++ b/cardano-cli/src/Cardano/CLI/Shelley/Run/Query.hs @@ -36,7 +36,7 @@ import Cardano.Api.Shelley import Control.Monad.Trans.Except (except) import Control.Monad.Trans.Except.Extra (firstExceptT, handleIOExceptT, hoistEither, - hoistMaybe, left, newExceptT) + hoistMaybe, left, newExceptT, onLeft, onNothing) import Data.Aeson as Aeson import Data.Aeson.Encode.Pretty (encodePretty) import Data.Aeson.Types as Aeson @@ -89,7 +89,7 @@ import Cardano.Slotting.EpochInfo (EpochInfo (..), epochInfoSlotToUTCT import Ouroboros.Consensus.BlockchainTime.WallClock.Types (RelativeTime (..), toRelativeTime) import Ouroboros.Consensus.Cardano.Block as Consensus (EraMismatch (..)) -import Ouroboros.Consensus.Protocol.TPraos ( StandardCrypto ) +import Ouroboros.Consensus.Protocol.TPraos (StandardCrypto) import Ouroboros.Network.Block (Serialised (..)) import qualified Ouroboros.Consensus.HardFork.History as Consensus @@ -129,6 +129,7 @@ data ShelleyQueryCmdError -- ^ Operational certificate of the unknown stake pool. | ShelleyQueryCmdPoolStateDecodeError DecoderError | ShelleyQueryCmdStakeSnapshotDecodeError DecoderError + | ShelleyQueryCmdUnsupportedNtcVersion !UnsupportedNtcVersionError deriving Show @@ -168,6 +169,10 @@ renderShelleyQueryCmdError err = "Failed to decode PoolState. Error: " <> Text.pack (show decoderError) ShelleyQueryCmdStakeSnapshotDecodeError decoderError -> "Failed to decode StakeSnapshot. Error: " <> Text.pack (show decoderError) + ShelleyQueryCmdUnsupportedNtcVersion (UnsupportedNtcVersionError minNtcVersion ntcVersion) -> + "Unsupported feature for the node-to-client protocol version.\n" <> + "This query requires at least " <> show minNtcVersion <> " but the node negotiated " <> show ntcVersion <> ".\n" <> + "Later node versions support later protocol versions (but development protocol versions are not enabled in the node by default)." runQueryCmd :: QueryCmd -> ExceptT ShelleyQueryCmdError IO () runQueryCmd cmd = @@ -210,7 +215,8 @@ runQueryProtocolParameters (AnyConsensusModeParams cModeParams) network mOutFile let localNodeConnInfo = LocalNodeConnectInfo cModeParams network sockPath result <- liftIO $ executeLocalStateQueryExpr localNodeConnInfo Nothing $ runExceptT $ do - anyE@(AnyCardanoEra era) <- lift $ determineEraExpr cModeParams + anyE@(AnyCardanoEra era) <- lift (determineEraExpr cModeParams) + & onLeft (throwE . ShelleyQueryCmdUnsupportedNtcVersion) case cardanoEraStyle era of LegacyByronEra -> left ShelleyQueryCmdByronEra @@ -220,11 +226,12 @@ runQueryProtocolParameters (AnyConsensusModeParams cModeParams) network mOutFile eInMode <- toEraInMode era cMode & hoistMaybe (ShelleyQueryCmdEraConsensusModeMismatch (AnyConsensusMode cMode) anyE) - ppResult <- lift . queryExpr $ QueryInEra eInMode $ QueryInShelleyBasedEra sbe QueryProtocolParameters - - except ppResult & firstExceptT ShelleyQueryCmdEraMismatch + lift (queryExpr $ QueryInEra eInMode $ QueryInShelleyBasedEra sbe QueryProtocolParameters) + & onLeft (throwE . ShelleyQueryCmdUnsupportedNtcVersion) + & onLeft (throwE . ShelleyQueryCmdEraMismatch) writeProtocolParameters mOutFile =<< except (join (first ShelleyQueryCmdAcquireFailure result)) + where writeProtocolParameters :: Maybe OutputFile @@ -277,45 +284,36 @@ runQueryTip -> Maybe OutputFile -> ExceptT ShelleyQueryCmdError IO () runQueryTip (AnyConsensusModeParams cModeParams) network mOutFile = do - SocketPath sockPath <- firstExceptT ShelleyQueryCmdEnvVarSocketErr - $ newExceptT readEnvSocketPath + SocketPath sockPath <- lift readEnvSocketPath & onLeft (throwE . ShelleyQueryCmdEnvVarSocketErr) case consensusModeOnly cModeParams of CardanoMode -> do let localNodeConnInfo = LocalNodeConnectInfo cModeParams network sockPath - eLocalState <- liftIO $ executeLocalStateQueryExpr localNodeConnInfo Nothing $ do - ntcVersion <- ask - era <- queryExpr (QueryCurrentEra CardanoModeIsMultiEra) - eraHistory <- queryExpr (QueryEraHistory CardanoModeIsMultiEra) - mChainBlockNo <- if ntcVersion >= NodeToClientV_10 - then Just <$> queryExpr QueryChainBlockNo - else return Nothing - mChainPoint <- if ntcVersion >= NodeToClientV_10 - then Just <$> queryExpr (QueryChainPoint CardanoMode) - else return Nothing - mSystemStart <- if ntcVersion >= NodeToClientV_9 - then Just <$> queryExpr QuerySystemStart - else return Nothing - - return O.QueryTipLocalState - { O.era = era - , O.eraHistory = eraHistory - , O.mSystemStart = mSystemStart - , O.mChainTip = makeChainTip <$> mChainBlockNo <*> mChainPoint - } + eLocalState <- ExceptT $ fmap sequence $ + executeLocalStateQueryExpr localNodeConnInfo Nothing $ runExceptT $ do + era <- lift (queryExpr (QueryCurrentEra CardanoModeIsMultiEra)) & onLeft (throwE . ShelleyQueryCmdUnsupportedNtcVersion) + eraHistory <- lift (queryExpr (QueryEraHistory CardanoModeIsMultiEra)) & onLeft (throwE . ShelleyQueryCmdUnsupportedNtcVersion) + mChainBlockNo <- lift (queryExpr QueryChainBlockNo ) & onLeft (throwE . ShelleyQueryCmdUnsupportedNtcVersion) & fmap Just + mChainPoint <- lift (queryExpr (QueryChainPoint CardanoMode )) & onLeft (throwE . ShelleyQueryCmdUnsupportedNtcVersion) & fmap Just + mSystemStart <- lift (queryExpr QuerySystemStart ) & onLeft (throwE . ShelleyQueryCmdUnsupportedNtcVersion) & fmap Just + + return O.QueryTipLocalState + { O.era = era + , O.eraHistory = eraHistory + , O.mSystemStart = mSystemStart + , O.mChainTip = makeChainTip <$> mChainBlockNo <*> mChainPoint + } mLocalState <- hushM (first ShelleyQueryCmdAcquireFailure eLocalState) $ \e -> liftIO . T.hPutStrLn IO.stderr $ "Warning: Local state unavailable: " <> renderShelleyQueryCmdError e - chainTip <- case mLocalState >>= O.mChainTip of - Just chainTip -> return chainTip - + chainTip <- pure (mLocalState >>= O.mChainTip) -- The chain tip is unavailable via local state query because we are connecting with an older -- node to client protocol so we use chain sync instead which necessitates another connection. -- At some point when we can stop supporting the older node to client protocols, this fallback -- can be removed. - Nothing -> queryChainTipViaChainSync localNodeConnInfo + & onNothing (queryChainTipViaChainSync localNodeConnInfo) let tipSlotNo :: SlotNo = case chainTip of ChainTipAtGenesis -> 0 @@ -1018,30 +1016,33 @@ runQueryStakePools -> ExceptT ShelleyQueryCmdError IO () runQueryStakePools (AnyConsensusModeParams cModeParams) network mOutFile = do - SocketPath sockPath <- firstExceptT ShelleyQueryCmdEnvVarSocketErr - $ newExceptT readEnvSocketPath + SocketPath sockPath <- lift readEnvSocketPath & onLeft (throwE . ShelleyQueryCmdEnvVarSocketErr) let localNodeConnInfo = LocalNodeConnectInfo cModeParams network sockPath - result <- ExceptT . fmap (join . first ShelleyQueryCmdAcquireFailure) $ - executeLocalStateQueryExpr localNodeConnInfo Nothing $ runExceptT @ShelleyQueryCmdError $ do - anyE@(AnyCardanoEra era) <- case consensusModeOnly cModeParams of - ByronMode -> return $ AnyCardanoEra ByronEra - ShelleyMode -> return $ AnyCardanoEra ShelleyEra - CardanoMode -> lift . queryExpr $ QueryCurrentEra CardanoModeIsMultiEra + poolIds <- + ( lift $ executeLocalStateQueryExpr localNodeConnInfo Nothing $ runExceptT @ShelleyQueryCmdError $ do + anyE@(AnyCardanoEra era) <- case consensusModeOnly cModeParams of + ByronMode -> return $ AnyCardanoEra ByronEra + ShelleyMode -> return $ AnyCardanoEra ShelleyEra + CardanoMode -> + lift (queryExpr $ QueryCurrentEra CardanoModeIsMultiEra) + & onLeft (throwE . ShelleyQueryCmdUnsupportedNtcVersion) - let cMode = consensusModeOnly cModeParams + let cMode = consensusModeOnly cModeParams - case toEraInMode era cMode of - Just eInMode -> do - sbe <- getSbe $ cardanoEraStyle era + eInMode <- toEraInMode era cMode + & hoistMaybe (ShelleyQueryCmdEraConsensusModeMismatch (AnyConsensusMode cMode) anyE) - firstExceptT ShelleyQueryCmdEraMismatch . ExceptT $ - queryExpr . QueryInEra eInMode . QueryInShelleyBasedEra sbe $ QueryStakePools + sbe <- getSbe $ cardanoEraStyle era - Nothing -> left $ ShelleyQueryCmdEraConsensusModeMismatch (AnyConsensusMode cMode) anyE + lift (queryExpr (QueryInEra eInMode $ QueryInShelleyBasedEra sbe $ QueryStakePools)) + & onLeft (throwE . ShelleyQueryCmdUnsupportedNtcVersion) + & onLeft (throwE . ShelleyQueryCmdEraMismatch) + ) & onLeft (throwE . ShelleyQueryCmdAcquireFailure) + & onLeft throwE - writeStakePools mOutFile result + writeStakePools mOutFile poolIds writeStakePools :: Maybe OutputFile