diff --git a/cardano-api/internal/Cardano/Api/Convenience/Query.hs b/cardano-api/internal/Cardano/Api/Convenience/Query.hs index 6d87015b82..e88d19cd03 100644 --- a/cardano-api/internal/Cardano/Api/Convenience/Query.hs +++ b/cardano-api/internal/Cardano/Api/Convenience/Query.hs @@ -45,7 +45,7 @@ import qualified Data.Map as Map import Data.Maybe (mapMaybe) import Data.Set (Set) import qualified Data.Set as Set -import Data.Text (Text) +import Data.Text (Text, pack) data QueryConvenienceError = AcqFailure AcquiringFailure @@ -67,6 +67,8 @@ renderQueryConvenienceError (QceUnsupportedNtcVersion (UnsupportedNtcVersionErro "Unsupported feature for the node-to-client protocol version.\n" <> "This query requires at least " <> textShow minNtcVersion <> " but the node negotiated " <> textShow ntcVersion <> ".\n" <> "Later node versions support later protocol versions (but development protocol versions are not enabled in the node by default)." +renderQueryConvenienceError (QceUnsupportedNtcVersion (UnsupportedBlockQuery queryStr)) = + "Unsupported query: " <> pack queryStr <> "\n" -- | A convenience function to query the relevant information, from -- the local node, for Cardano.Api.Convenience.Construction.constructBalancedTx diff --git a/cardano-api/internal/Cardano/Api/IPC/Monad.hs b/cardano-api/internal/Cardano/Api/IPC/Monad.hs index dfe2c71151..9169538bb9 100644 --- a/cardano-api/internal/Cardano/Api/IPC/Monad.hs +++ b/cardano-api/internal/Cardano/Api/IPC/Monad.hs @@ -1,6 +1,13 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralisedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -Wno-redundant-constraints #-} module Cardano.Api.IPC.Monad ( LocalStateQueryExpr @@ -9,17 +16,36 @@ module Cardano.Api.IPC.Monad ) where import Cardano.Api.Block +import Cardano.Api.Eon.ShelleyBasedEra +import Cardano.Api.Eras.Core import Cardano.Api.IPC import Cardano.Api.IPC.Version +import Cardano.Api.Modes +import Cardano.Api.Query (toConsensusQuery) +import qualified Cardano.Api.ReexposeLedger as L import Cardano.Ledger.Shelley.Scripts () +import qualified Ouroboros.Consensus.Byron.Ledger.Block as Consensus +import qualified Ouroboros.Consensus.Cardano as Consensus +import qualified Ouroboros.Consensus.Cardano.Block as Consensus +import qualified Ouroboros.Consensus.HardFork.Combinator as Consensus +import qualified Ouroboros.Consensus.HardFork.Combinator.Serialisation as Consensus +import qualified Ouroboros.Consensus.Ledger.Query as Consensus +import qualified Ouroboros.Consensus.Node.NetworkProtocolVersion as Consensus +import Ouroboros.Consensus.Shelley.Ledger (ShelleyNodeToClientVersion) +import qualified Ouroboros.Consensus.Shelley.Ledger as Consensus import qualified Ouroboros.Network.Protocol.LocalStateQuery.Client as Net.Query +import qualified Ouroboros.Network.Protocol.LocalStateQuery.Codec as Consensus import Control.Concurrent.STM import Control.Monad import Control.Monad.IO.Class import Control.Monad.Reader import Control.Monad.Trans.Cont +import qualified Data.Map.Strict as M +import Data.Maybe +import Data.Proxy +import Data.SOP.Strict (NP (..)) {- HLINT ignore "Use const" -} {- HLINT ignore "Use let" -} @@ -35,9 +61,16 @@ import Control.Monad.Trans.Cont -- -- In order to make pipelining still possible we can explore the use of Selective Functors -- which would allow us to straddle both worlds. + newtype LocalStateQueryExpr block point query r m a = LocalStateQueryExpr - { runLocalStateQueryExpr :: ReaderT NodeToClientVersion (ContT (Net.Query.ClientStAcquired block point query m r) m) a - } deriving (Functor, Applicative, Monad, MonadReader NodeToClientVersion, MonadIO) + { runLocalStateQueryExpr :: ReaderT QueryConnectionVersions (ContT (Net.Query.ClientStAcquired block point query m r) m) a + } deriving (Functor, Applicative, Monad, MonadReader QueryConnectionVersions, MonadIO) + +data QueryConnectionVersions = QueryConnectionVersions + { ntcVersion :: NodeToClientVersion + , shelleyNtcVersion :: ShelleyNodeToClientVersion + , nodeEra :: AnyShelleyBasedEra + } -- | Execute a local state query expression. executeLocalStateQueryExpr :: () @@ -73,10 +106,12 @@ setupLocalStateQueryExpr :: -> NodeToClientVersion -> LocalStateQueryExpr BlockInMode ChainPoint QueryInMode () IO a -> Net.Query.LocalStateQueryClient BlockInMode ChainPoint QueryInMode IO () -setupLocalStateQueryExpr waitDone mPointVar' resultVar' ntcVersion f = +setupLocalStateQueryExpr waitDone mPointVar' resultVar' ntcVersion f = do + -- stub the version and era before we query the node for the correct values + let queryConnectionVersions = QueryConnectionVersions ntcVersion maxBound maxBound LocalStateQueryClient . pure . Net.Query.SendMsgAcquire mPointVar' $ Net.Query.ClientStAcquiring - { Net.Query.recvMsgAcquired = runContT (runReaderT (runLocalStateQueryExpr f) ntcVersion) $ \result -> do + { Net.Query.recvMsgAcquired = runContT (runReaderT (runLocalStateQueryExpr queryWrapped) queryConnectionVersions) $ \result -> do atomically $ putTMVar resultVar' (Right result) void $ atomically waitDone -- Wait for all protocols to complete before exiting. pure $ Net.Query.SendMsgRelease $ pure $ Net.Query.SendMsgDone () @@ -86,21 +121,121 @@ setupLocalStateQueryExpr waitDone mPointVar' resultVar' ntcVersion f = void $ atomically waitDone -- Wait for all protocols to complete before exiting. pure $ Net.Query.SendMsgDone () } + where + -- retrieve era from the node and set correct versions in reader for the query + queryWrapped = do + nodeEra@(AnyShelleyBasedEra currentEra) <- queryExpr QueryCurrentEra >>= \case + Right (AnyCardanoEra e) -> inEonForEra (error "byron not supported") (pure . AnyShelleyBasedEra) e + Left _ -> error "Impossible! QueryCurrentEra is always supported." + + let shelleyNtcVersion = getSupportedShelleyNtcVersion currentEra ntcVersion supportedNodeToClientVersions + + -- run the queries with the correct version and era + local (\r -> r {shelleyNtcVersion, nodeEra}) f -- | Get the node server's Node-to-Client version. -getNtcVersion :: LocalStateQueryExpr block point QueryInMode r IO NodeToClientVersion -getNtcVersion = LocalStateQueryExpr ask +getNtcVersion :: LocalStateQueryExpr block point QueryInMode r m NodeToClientVersion +getNtcVersion = asks ntcVersion + +getShelleyNtcVersion :: LocalStateQueryExpr block point QueryInMode r m ShelleyNodeToClientVersion +getShelleyNtcVersion = asks shelleyNtcVersion + +supportedNodeToClientVersions + :: M.Map + NodeToClientVersion + (Consensus.HardForkNodeToClientVersion + (Consensus.ByronBlock : Consensus.CardanoShelleyEras Consensus.StandardCrypto)) +supportedNodeToClientVersions = Consensus.supportedNodeToClientVersions @(Consensus.CardanoBlock L.StandardCrypto) Proxy + -- | Use 'queryExpr' in a do block to construct monadic local state queries. queryExpr :: QueryInMode a -> LocalStateQueryExpr block point QueryInMode r IO (Either UnsupportedNtcVersionError a) +queryExpr QueryCurrentEra = do + -- Assuming an era cannot change during the single connection, use memoized value + AnyShelleyBasedEra sbe <- asks nodeEra + pure . pure $ AnyCardanoEra (shelleyBasedToCardanoEra sbe) + 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)) + shelleyNtcVersion <- getShelleyNtcVersion + + case isQuerySupprted shelleyNtcVersion q of + Left e -> pure $ Left e + Right isShelleyNtcSupported + | ntcVersion >= minNtcVersion && isShelleyNtcSupported -> + fmap Right . LocalStateQueryExpr . ReaderT $ \_ -> ContT $ \f -> pure $ + Net.Query.SendMsgQuery q $ + Net.Query.ClientStQuerying + { Net.Query.recvMsgResult = f + } + | otherwise -> pure . Left $ UnsupportedNtcVersionError minNtcVersion ntcVersion + +-- | Check if query is supported in the current Shelley NTC +isQuerySupprted :: Consensus.ShelleyNodeToClientVersion + -> QueryInMode a + -> Either UnsupportedNtcVersionError Bool +isQuerySupprted shelleyVersion query = + case toConsensusQuery query of + Consensus.Some Consensus.GetSystemStart -> pure $ shelleyVersion >= Consensus.ShelleyNodeToClientVersion3 + Consensus.Some Consensus.GetChainBlockNo -> pure $ shelleyVersion >= Consensus.ShelleyNodeToClientVersion4 + Consensus.Some Consensus.GetChainPoint -> pure $ shelleyVersion >= Consensus.ShelleyNodeToClientVersion4 + Consensus.Some (Consensus.BlockQuery bq) -> + case bq of + Consensus.QueryHardFork Consensus.GetInterpreter -> pure True + Consensus.QueryHardFork Consensus.GetCurrentEra -> pure True + Consensus.QueryIfCurrentByron _ -> pure True + Consensus.QueryIfCurrentShelley bsq -> pure $ Consensus.querySupportedVersion bsq shelleyVersion + Consensus.QueryIfCurrentAllegra bsq -> pure $ Consensus.querySupportedVersion bsq shelleyVersion + Consensus.QueryIfCurrentMary bsq -> pure $ Consensus.querySupportedVersion bsq shelleyVersion + Consensus.QueryIfCurrentAlonzo bsq -> pure $ Consensus.querySupportedVersion bsq shelleyVersion + Consensus.QueryIfCurrentBabbage bsq -> pure $ Consensus.querySupportedVersion bsq shelleyVersion + Consensus.QueryIfCurrentConway bsq -> pure $ Consensus.querySupportedVersion bsq shelleyVersion + -- this error will happen when a new era or a new type of block query is added + -- in that case add a similar case to the ones above + otherQuery -> Left $ UnsupportedBlockQuery (show otherQuery) + +-- | Retrieve the supported shelley node-to-client version from the mapping +-- A node-to-client (NTC) version can be mapped to multiple values of Shelley NTC. It is +-- Shelley NTC which is used to check if the query can be used in the current era. +-- +-- If the hard fork combinator is disabled, fall back to using 'maxBound' to allow all queries. +getSupportedShelleyNtcVersion + :: ShelleyBasedEra era -- ^ node era + -> NodeToClientVersion -- ^ protocol version + -> M.Map + NodeToClientVersion + (Consensus.HardForkNodeToClientVersion + (Consensus.ByronBlock + : Consensus.CardanoShelleyEras Consensus.StandardCrypto)) + -- ^ mapping of NTC to Shelley NTC by era + -> Consensus.ShelleyNodeToClientVersion +getSupportedShelleyNtcVersion sbe ntcVersion supportedVersions = fromMaybe maxBound $ do + M.lookup ntcVersion supportedVersions >>= \case + Consensus.HardForkNodeToClientDisabled _ -> Nothing + Consensus.HardForkNodeToClientEnabled _ np -> getEraShelleyNtcVersion sbe np + +-- | Get Shelley NTC version for an era +getEraShelleyNtcVersion + :: ShelleyBasedEra era + -> NP Consensus.EraNodeToClientVersion (Consensus.CardanoEras Consensus.StandardCrypto) + -- ^ a product of all Shelley NTC versions for all eras + -> Maybe Consensus.ShelleyNodeToClientVersion +getEraShelleyNtcVersion sbe (_byronV :* shelleyV :* allegraV :* maryV :* alonzoV :* babbageV :* conwayV :* Nil) = + case sbe of + ShelleyBasedEraShelley -> conv sbe shelleyV + ShelleyBasedEraAllegra -> conv sbe allegraV + ShelleyBasedEraMary -> conv sbe maryV + ShelleyBasedEraAlonzo -> conv sbe alonzoV + ShelleyBasedEraBabbage -> conv sbe babbageV + ShelleyBasedEraConway -> conv sbe conwayV + where + conv :: ( Consensus.BlockNodeToClientVersion blk ~ Consensus.ShelleyNodeToClientVersion + , blk ~ ConsensusBlockForEra era ) + => ShelleyBasedEra era + -> Consensus.EraNodeToClientVersion blk + -> Maybe Consensus.ShelleyNodeToClientVersion + conv _ = \case + Consensus.EraNodeToClientDisabled -> Nothing + Consensus.EraNodeToClientEnabled x -> Just x + diff --git a/cardano-api/internal/Cardano/Api/IPC/Version.hs b/cardano-api/internal/Cardano/Api/IPC/Version.hs index e04fc34546..758ef7c0c6 100644 --- a/cardano-api/internal/Cardano/Api/IPC/Version.hs +++ b/cardano-api/internal/Cardano/Api/IPC/Version.hs @@ -30,5 +30,10 @@ class NodeToClientVersionOf a where type MinNodeToClientVersion = NodeToClientVersion -data UnsupportedNtcVersionError = UnsupportedNtcVersionError !MinNodeToClientVersion !NodeToClientVersion +-- | Show-ed query +type QueryStr = String + +data UnsupportedNtcVersionError + = UnsupportedNtcVersionError !MinNodeToClientVersion !NodeToClientVersion + | UnsupportedBlockQuery !QueryStr deriving (Eq, Show)