Skip to content

Commit 095d372

Browse files
newhoggynewhoggy
committed
Modify queryExpr to check node to client version of the query it runs.
1 parent 9665b3d commit 095d372

File tree

6 files changed

+79
-62
lines changed

6 files changed

+79
-62
lines changed

Diff for: ‎cabal.project

+2-2
Original file line numberDiff line numberDiff line change
@@ -12,10 +12,10 @@ repository cardano-haskell-packages
1212

1313
-- See CONTRIBUTING for information about these, including some Nix commands
1414
-- you need to run if you change them
15-
index-state: 2022-12-11T00:00:00Z
15+
index-state: 2023-01-20T05:50:56Z
1616

1717
index-state:
18-
, hackage.haskell.org 2022-12-11T00:00:00Z
18+
, hackage.haskell.org 2023-01-20T05:50:56Z
1919
, cardano-haskell-packages 2022-12-14T00:40:15Z
2020

2121
packages:

Diff for: ‎cardano-api/cardano-api.cabal

+1-1
Original file line numberDiff line numberDiff line change
@@ -166,7 +166,7 @@ library
166166
, text
167167
, time
168168
, transformers
169-
, transformers-except
169+
, transformers-except ^>= 0.1.3
170170
, typed-protocols ^>= 0.1
171171
, unordered-containers >= 0.2.11
172172
, vector

Diff for: ‎cardano-api/src/Cardano/Api.hs

+1
Original file line numberDiff line numberDiff line change
@@ -620,6 +620,7 @@ module Cardano.Api (
620620
UTxO(..),
621621
queryNodeLocalState,
622622
executeQueryCardanoMode,
623+
UnsupportedNtcVersionError(..),
623624

624625
-- *** Local tx monitoring
625626
LocalTxMonitorClient(..),

Diff for: ‎cardano-api/src/Cardano/Api/IPC.hs

+4-1
Original file line numberDiff line numberDiff line change
@@ -77,7 +77,9 @@ module Cardano.Api.IPC (
7777
consensusModeOnly,
7878
toAcquiringFailure,
7979

80-
NodeToClientVersion(..)
80+
NodeToClientVersion(..),
81+
82+
UnsupportedNtcVersionError(..),
8183
) where
8284

8385
import Prelude
@@ -130,6 +132,7 @@ import qualified Ouroboros.Consensus.Shelley.Ledger.Block as Consensus
130132
import Cardano.Api.Block
131133
import Cardano.Api.HasTypeProxy
132134
import Cardano.Api.InMode
135+
import Cardano.Api.IPC.Version
133136
import Cardano.Api.Modes
134137
import Cardano.Api.NetworkId
135138
import Cardano.Api.Protocol

Diff for: ‎cardano-api/src/Cardano/Api/IPC/Monad.hs

+22-10
Original file line numberDiff line numberDiff line change
@@ -19,6 +19,7 @@ import Data.Bifunctor (first)
1919
import Data.Either
2020
import Data.Function
2121
import Data.Maybe
22+
import Data.Ord (Ord (..))
2223
import System.IO
2324

2425
import Cardano.Ledger.Shelley.Scripts ()
@@ -28,7 +29,9 @@ import qualified Ouroboros.Network.Protocol.LocalStateQuery.Type as Net.Query
2829
import Cardano.Api.Block
2930
import Cardano.Api.Eras
3031
import Cardano.Api.IPC
32+
import Cardano.Api.IPC.Version
3133
import Cardano.Api.Modes
34+
import Control.Monad.Trans.Except (ExceptT (..), runExceptT)
3235

3336

3437
{- HLINT ignore "Use const" -}
@@ -97,21 +100,30 @@ setupLocalStateQueryExpr waitDone mPointVar' resultVar' ntcVersion f =
97100
pure $ Net.Query.SendMsgDone ()
98101
}
99102

103+
-- | Get the node server's Node-to-Client version.
104+
getNtcVersion :: LocalStateQueryExpr block point (QueryInMode mode) r IO NodeToClientVersion
105+
getNtcVersion = LocalStateQueryExpr ask
106+
100107
-- | Use 'queryExpr' in a do block to construct monadic local state queries.
101-
queryExpr :: QueryInMode mode a -> LocalStateQueryExpr block point (QueryInMode mode) r IO a
102-
queryExpr q =
103-
LocalStateQueryExpr . ReaderT $ \_ -> ContT $ \f -> pure $
104-
Net.Query.SendMsgQuery q $
105-
Net.Query.ClientStQuerying
106-
{ Net.Query.recvMsgResult = f
107-
}
108+
queryExpr :: QueryInMode mode a -> LocalStateQueryExpr block point (QueryInMode mode) r IO (Either UnsupportedNtcVersionError a)
109+
queryExpr q = do
110+
let minNtcVersion = nodeToClientVersionOf q
111+
ntcVersion <- getNtcVersion
112+
if ntcVersion >= minNtcVersion
113+
then
114+
fmap Right . LocalStateQueryExpr . ReaderT $ \_ -> ContT $ \f -> pure $
115+
Net.Query.SendMsgQuery q $
116+
Net.Query.ClientStQuerying
117+
{ Net.Query.recvMsgResult = f
118+
}
119+
else pure (Left (UnsupportedNtcVersionError minNtcVersion ntcVersion))
108120

109121
-- | A monad expression that determines what era the node is in.
110122
determineEraExpr ::
111123
ConsensusModeParams mode
112-
-> LocalStateQueryExpr block point (QueryInMode mode) r IO AnyCardanoEra
113-
determineEraExpr cModeParams =
124+
-> LocalStateQueryExpr block point (QueryInMode mode) r IO (Either UnsupportedNtcVersionError AnyCardanoEra)
125+
determineEraExpr cModeParams = runExceptT $
114126
case consensusModeOnly cModeParams of
115127
ByronMode -> return $ AnyCardanoEra ByronEra
116128
ShelleyMode -> return $ AnyCardanoEra ShelleyEra
117-
CardanoMode -> queryExpr $ QueryCurrentEra CardanoModeIsMultiEra
129+
CardanoMode -> ExceptT $ queryExpr $ QueryCurrentEra CardanoModeIsMultiEra

Diff for: ‎cardano-cli/src/Cardano/CLI/Shelley/Run/Query.hs

+49-48
Original file line numberDiff line numberDiff line change
@@ -36,7 +36,7 @@ import Cardano.Api.Shelley
3636

3737
import Control.Monad.Trans.Except (except)
3838
import Control.Monad.Trans.Except.Extra (firstExceptT, handleIOExceptT, hoistEither,
39-
hoistMaybe, left, newExceptT)
39+
hoistMaybe, left, newExceptT, onLeft, onNothing)
4040
import Data.Aeson as Aeson
4141
import Data.Aeson.Encode.Pretty (encodePretty)
4242
import Data.Aeson.Types as Aeson
@@ -89,7 +89,7 @@ import Cardano.Slotting.EpochInfo (EpochInfo (..), epochInfoSlotToUTCT
8989
import Ouroboros.Consensus.BlockchainTime.WallClock.Types (RelativeTime (..),
9090
toRelativeTime)
9191
import Ouroboros.Consensus.Cardano.Block as Consensus (EraMismatch (..))
92-
import Ouroboros.Consensus.Protocol.TPraos ( StandardCrypto )
92+
import Ouroboros.Consensus.Protocol.TPraos (StandardCrypto)
9393
import Ouroboros.Network.Block (Serialised (..))
9494

9595
import qualified Ouroboros.Consensus.HardFork.History as Consensus
@@ -129,6 +129,7 @@ data ShelleyQueryCmdError
129129
-- ^ Operational certificate of the unknown stake pool.
130130
| ShelleyQueryCmdPoolStateDecodeError DecoderError
131131
| ShelleyQueryCmdStakeSnapshotDecodeError DecoderError
132+
| ShelleyQueryCmdUnsupportedNtcVersion !UnsupportedNtcVersionError
132133

133134
deriving Show
134135

@@ -168,6 +169,10 @@ renderShelleyQueryCmdError err =
168169
"Failed to decode PoolState. Error: " <> Text.pack (show decoderError)
169170
ShelleyQueryCmdStakeSnapshotDecodeError decoderError ->
170171
"Failed to decode StakeSnapshot. Error: " <> Text.pack (show decoderError)
172+
ShelleyQueryCmdUnsupportedNtcVersion (UnsupportedNtcVersionError minNtcVersion ntcVersion) ->
173+
"Unsupported feature for the node-to-client protocol version.\n" <>
174+
"This query requires at least " <> show minNtcVersion <> " but the node negotiated " <> show ntcVersion <> ".\n" <>
175+
"Later node versions support later protocol versions (but development protocol versions are not enabled in the node by default)."
171176

172177
runQueryCmd :: QueryCmd -> ExceptT ShelleyQueryCmdError IO ()
173178
runQueryCmd cmd =
@@ -210,7 +215,8 @@ runQueryProtocolParameters (AnyConsensusModeParams cModeParams) network mOutFile
210215
let localNodeConnInfo = LocalNodeConnectInfo cModeParams network sockPath
211216

212217
result <- liftIO $ executeLocalStateQueryExpr localNodeConnInfo Nothing $ runExceptT $ do
213-
anyE@(AnyCardanoEra era) <- lift $ determineEraExpr cModeParams
218+
anyE@(AnyCardanoEra era) <- lift (determineEraExpr cModeParams)
219+
& onLeft (throwE . ShelleyQueryCmdUnsupportedNtcVersion)
214220

215221
case cardanoEraStyle era of
216222
LegacyByronEra -> left ShelleyQueryCmdByronEra
@@ -220,11 +226,12 @@ runQueryProtocolParameters (AnyConsensusModeParams cModeParams) network mOutFile
220226
eInMode <- toEraInMode era cMode
221227
& hoistMaybe (ShelleyQueryCmdEraConsensusModeMismatch (AnyConsensusMode cMode) anyE)
222228

223-
ppResult <- lift . queryExpr $ QueryInEra eInMode $ QueryInShelleyBasedEra sbe QueryProtocolParameters
224-
225-
except ppResult & firstExceptT ShelleyQueryCmdEraMismatch
229+
lift (queryExpr $ QueryInEra eInMode $ QueryInShelleyBasedEra sbe QueryProtocolParameters)
230+
& onLeft (throwE . ShelleyQueryCmdUnsupportedNtcVersion)
231+
& onLeft (throwE . ShelleyQueryCmdEraMismatch)
226232

227233
writeProtocolParameters mOutFile =<< except (join (first ShelleyQueryCmdAcquireFailure result))
234+
228235
where
229236
writeProtocolParameters
230237
:: Maybe OutputFile
@@ -277,45 +284,36 @@ runQueryTip
277284
-> Maybe OutputFile
278285
-> ExceptT ShelleyQueryCmdError IO ()
279286
runQueryTip (AnyConsensusModeParams cModeParams) network mOutFile = do
280-
SocketPath sockPath <- firstExceptT ShelleyQueryCmdEnvVarSocketErr
281-
$ newExceptT readEnvSocketPath
287+
SocketPath sockPath <- lift readEnvSocketPath & onLeft (throwE . ShelleyQueryCmdEnvVarSocketErr)
282288

283289
case consensusModeOnly cModeParams of
284290
CardanoMode -> do
285291
let localNodeConnInfo = LocalNodeConnectInfo cModeParams network sockPath
286292

287-
eLocalState <- liftIO $ executeLocalStateQueryExpr localNodeConnInfo Nothing $ do
288-
ntcVersion <- ask
289-
era <- queryExpr (QueryCurrentEra CardanoModeIsMultiEra)
290-
eraHistory <- queryExpr (QueryEraHistory CardanoModeIsMultiEra)
291-
mChainBlockNo <- if ntcVersion >= NodeToClientV_10
292-
then Just <$> queryExpr QueryChainBlockNo
293-
else return Nothing
294-
mChainPoint <- if ntcVersion >= NodeToClientV_10
295-
then Just <$> queryExpr (QueryChainPoint CardanoMode)
296-
else return Nothing
297-
mSystemStart <- if ntcVersion >= NodeToClientV_9
298-
then Just <$> queryExpr QuerySystemStart
299-
else return Nothing
300-
301-
return O.QueryTipLocalState
302-
{ O.era = era
303-
, O.eraHistory = eraHistory
304-
, O.mSystemStart = mSystemStart
305-
, O.mChainTip = makeChainTip <$> mChainBlockNo <*> mChainPoint
306-
}
293+
eLocalState <- ExceptT $ fmap sequence $
294+
executeLocalStateQueryExpr localNodeConnInfo Nothing $ runExceptT $ do
295+
era <- lift (queryExpr (QueryCurrentEra CardanoModeIsMultiEra)) & onLeft (throwE . ShelleyQueryCmdUnsupportedNtcVersion)
296+
eraHistory <- lift (queryExpr (QueryEraHistory CardanoModeIsMultiEra)) & onLeft (throwE . ShelleyQueryCmdUnsupportedNtcVersion)
297+
mChainBlockNo <- lift (queryExpr QueryChainBlockNo ) & onLeft (throwE . ShelleyQueryCmdUnsupportedNtcVersion) & fmap Just
298+
mChainPoint <- lift (queryExpr (QueryChainPoint CardanoMode )) & onLeft (throwE . ShelleyQueryCmdUnsupportedNtcVersion) & fmap Just
299+
mSystemStart <- lift (queryExpr QuerySystemStart ) & onLeft (throwE . ShelleyQueryCmdUnsupportedNtcVersion) & fmap Just
300+
301+
return O.QueryTipLocalState
302+
{ O.era = era
303+
, O.eraHistory = eraHistory
304+
, O.mSystemStart = mSystemStart
305+
, O.mChainTip = makeChainTip <$> mChainBlockNo <*> mChainPoint
306+
}
307307

308308
mLocalState <- hushM (first ShelleyQueryCmdAcquireFailure eLocalState) $ \e ->
309309
liftIO . T.hPutStrLn IO.stderr $ "Warning: Local state unavailable: " <> renderShelleyQueryCmdError e
310310

311-
chainTip <- case mLocalState >>= O.mChainTip of
312-
Just chainTip -> return chainTip
313-
311+
chainTip <- pure (mLocalState >>= O.mChainTip)
314312
-- The chain tip is unavailable via local state query because we are connecting with an older
315313
-- node to client protocol so we use chain sync instead which necessitates another connection.
316314
-- At some point when we can stop supporting the older node to client protocols, this fallback
317315
-- can be removed.
318-
Nothing -> queryChainTipViaChainSync localNodeConnInfo
316+
& onNothing (queryChainTipViaChainSync localNodeConnInfo)
319317

320318
let tipSlotNo :: SlotNo = case chainTip of
321319
ChainTipAtGenesis -> 0
@@ -1018,30 +1016,33 @@ runQueryStakePools
10181016
-> ExceptT ShelleyQueryCmdError IO ()
10191017
runQueryStakePools (AnyConsensusModeParams cModeParams)
10201018
network mOutFile = do
1021-
SocketPath sockPath <- firstExceptT ShelleyQueryCmdEnvVarSocketErr
1022-
$ newExceptT readEnvSocketPath
1019+
SocketPath sockPath <- lift readEnvSocketPath & onLeft (throwE . ShelleyQueryCmdEnvVarSocketErr)
10231020

10241021
let localNodeConnInfo = LocalNodeConnectInfo cModeParams network sockPath
10251022

1026-
result <- ExceptT . fmap (join . first ShelleyQueryCmdAcquireFailure) $
1027-
executeLocalStateQueryExpr localNodeConnInfo Nothing $ runExceptT @ShelleyQueryCmdError $ do
1028-
anyE@(AnyCardanoEra era) <- case consensusModeOnly cModeParams of
1029-
ByronMode -> return $ AnyCardanoEra ByronEra
1030-
ShelleyMode -> return $ AnyCardanoEra ShelleyEra
1031-
CardanoMode -> lift . queryExpr $ QueryCurrentEra CardanoModeIsMultiEra
1023+
poolIds <-
1024+
( lift $ executeLocalStateQueryExpr localNodeConnInfo Nothing $ runExceptT @ShelleyQueryCmdError $ do
1025+
anyE@(AnyCardanoEra era) <- case consensusModeOnly cModeParams of
1026+
ByronMode -> return $ AnyCardanoEra ByronEra
1027+
ShelleyMode -> return $ AnyCardanoEra ShelleyEra
1028+
CardanoMode ->
1029+
lift (queryExpr $ QueryCurrentEra CardanoModeIsMultiEra)
1030+
& onLeft (throwE . ShelleyQueryCmdUnsupportedNtcVersion)
10321031

1033-
let cMode = consensusModeOnly cModeParams
1032+
let cMode = consensusModeOnly cModeParams
10341033

1035-
case toEraInMode era cMode of
1036-
Just eInMode -> do
1037-
sbe <- getSbe $ cardanoEraStyle era
1034+
eInMode <- toEraInMode era cMode
1035+
& hoistMaybe (ShelleyQueryCmdEraConsensusModeMismatch (AnyConsensusMode cMode) anyE)
10381036

1039-
firstExceptT ShelleyQueryCmdEraMismatch . ExceptT $
1040-
queryExpr . QueryInEra eInMode . QueryInShelleyBasedEra sbe $ QueryStakePools
1037+
sbe <- getSbe $ cardanoEraStyle era
10411038

1042-
Nothing -> left $ ShelleyQueryCmdEraConsensusModeMismatch (AnyConsensusMode cMode) anyE
1039+
lift (queryExpr (QueryInEra eInMode $ QueryInShelleyBasedEra sbe $ QueryStakePools))
1040+
& onLeft (throwE . ShelleyQueryCmdUnsupportedNtcVersion)
1041+
& onLeft (throwE . ShelleyQueryCmdEraMismatch)
1042+
) & onLeft (throwE . ShelleyQueryCmdAcquireFailure)
1043+
& onLeft throwE
10431044

1044-
writeStakePools mOutFile result
1045+
writeStakePools mOutFile poolIds
10451046

10461047
writeStakePools
10471048
:: Maybe OutputFile

0 commit comments

Comments
 (0)