diff --git a/cabal.project b/cabal.project index 49ea2723920..c02af6226fd 100644 --- a/cabal.project +++ b/cabal.project @@ -12,10 +12,10 @@ repository cardano-haskell-packages -- See CONTRIBUTING for information about these, including some Nix commands -- you need to run if you change them -index-state: 2022-12-11T00:00:00Z +index-state: 2023-01-20T05:50:56Z index-state: - , hackage.haskell.org 2022-12-11T00:00:00Z + , hackage.haskell.org 2023-01-20T05:50:56Z , cardano-haskell-packages 2022-12-14T00:40:15Z packages: 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..3fca88e373e 100644 --- a/cardano-api/src/Cardano/Api/IPC/Monad.hs +++ b/cardano-api/src/Cardano/Api/IPC/Monad.hs @@ -9,17 +9,15 @@ module Cardano.Api.IPC.Monad , determineEraExpr ) where -import Control.Applicative +import Prelude + import Control.Concurrent.STM import Control.Monad import Control.Monad.IO.Class import Control.Monad.Reader import Control.Monad.Trans.Cont +import Control.Monad.Trans.Except (ExceptT (..), runExceptT) import Data.Bifunctor (first) -import Data.Either -import Data.Function -import Data.Maybe -import System.IO import Cardano.Ledger.Shelley.Scripts () import qualified Ouroboros.Network.Protocol.LocalStateQuery.Client as Net.Query @@ -28,6 +26,7 @@ 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 @@ -97,21 +96,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/cardano-cli.cabal b/cardano-cli/cardano-cli.cabal index c4a07dc8155..3bac5ac4097 100644 --- a/cardano-cli/cardano-cli.cabal +++ b/cardano-cli/cardano-cli.cabal @@ -147,7 +147,7 @@ library , text , time , transformers - , transformers-except + , transformers-except ^>= 0.1.3 , unliftio-core , utf8-string , vector diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Run/Query.hs b/cardano-cli/src/Cardano/CLI/Shelley/Run/Query.hs index a09595f2923..b351fd620be 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 (left . 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 (left . ShelleyQueryCmdUnsupportedNtcVersion) + & onLeft (left . 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 (left . 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 (left . ShelleyQueryCmdUnsupportedNtcVersion) + eraHistory <- lift (queryExpr (QueryEraHistory CardanoModeIsMultiEra)) & onLeft (left . ShelleyQueryCmdUnsupportedNtcVersion) + mChainBlockNo <- lift (queryExpr QueryChainBlockNo) & onLeft (left . ShelleyQueryCmdUnsupportedNtcVersion) & fmap Just + mChainPoint <- lift (queryExpr (QueryChainPoint CardanoMode)) & onLeft (left . ShelleyQueryCmdUnsupportedNtcVersion) & fmap Just + mSystemStart <- lift (queryExpr QuerySystemStart) & onLeft (left . 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 (left . 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 (left . 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 (left . ShelleyQueryCmdUnsupportedNtcVersion) + & onLeft (left . ShelleyQueryCmdEraMismatch) + ) & onLeft (left . ShelleyQueryCmdAcquireFailure) + & onLeft left - writeStakePools mOutFile result + writeStakePools mOutFile poolIds writeStakePools :: Maybe OutputFile