Skip to content

Commit 7216a81

Browse files
newhoggynewhoggy
committed
Without oops
1 parent bb1ab4b commit 7216a81

File tree

4 files changed

+81
-36
lines changed

4 files changed

+81
-36
lines changed

‎cardano-api/src/Cardano/Api.hs

Lines changed: 1 addition & 0 deletions
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(..),

‎cardano-api/src/Cardano/Api/IPC.hs

Lines changed: 4 additions & 1 deletion
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.NtcVersionOf
133136
import Cardano.Api.Modes
134137
import Cardano.Api.NetworkId
135138
import Cardano.Api.Protocol

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

Lines changed: 24 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -14,11 +14,12 @@ import Control.Concurrent.STM
1414
import Control.Monad
1515
import Control.Monad.IO.Class
1616
import Control.Monad.Trans.Cont
17-
import Control.Monad.Trans.Reader (ReaderT(..), runReaderT)
17+
import Control.Monad.Trans.Reader (ReaderT(..), runReaderT, ask)
1818
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,6 +29,7 @@ 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.NtcVersionOf (ntcVersionOf)
3133
import Cardano.Api.Modes
3234

3335

@@ -97,21 +99,32 @@ setupLocalStateQueryExpr waitDone mPointVar' resultVar' ntcVersion f =
9799
pure $ Net.Query.SendMsgDone ()
98100
}
99101

102+
-- | Get the node server's Node-to-Client version.
103+
getNtcVersion :: LocalStateQueryExpr block point (QueryInMode mode) r IO NodeToClientVersion
104+
getNtcVersion = LocalStateQueryExpr $ do
105+
v <- ask
106+
pure v
107+
100108
-- | 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-
}
109+
queryExpr :: QueryInMode mode a -> LocalStateQueryExpr block point (QueryInMode mode) r IO (Either UnsupportedNtcVersionError a)
110+
queryExpr q = do
111+
let minNtcVersion = ntcVersionOf q
112+
ntcVersion <- getNtcVersion
113+
if ntcVersion >= minNtcVersion
114+
then
115+
fmap Right . LocalStateQueryExpr . ReaderT $ \_ -> ContT $ \f -> pure $
116+
Net.Query.SendMsgQuery q $
117+
Net.Query.ClientStQuerying
118+
{ Net.Query.recvMsgResult = f
119+
}
120+
else pure (Left (UnsupportedNtcVersionError minNtcVersion ntcVersion))
108121

109122
-- | A monad expression that determines what era the node is in.
110123
determineEraExpr ::
111124
ConsensusModeParams mode
112-
-> LocalStateQueryExpr block point (QueryInMode mode) r IO AnyCardanoEra
125+
-> LocalStateQueryExpr block point (QueryInMode mode) r IO (Either UnsupportedNtcVersionError AnyCardanoEra)
113126
determineEraExpr cModeParams =
114127
case consensusModeOnly cModeParams of
115-
ByronMode -> return $ AnyCardanoEra ByronEra
116-
ShelleyMode -> return $ AnyCardanoEra ShelleyEra
128+
ByronMode -> return $ Right $ AnyCardanoEra ByronEra
129+
ShelleyMode -> return $ Right $ AnyCardanoEra ShelleyEra
117130
CardanoMode -> queryExpr $ QueryCurrentEra CardanoModeIsMultiEra

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

Lines changed: 52 additions & 24 deletions
Original file line numberDiff line numberDiff line change
@@ -4,6 +4,7 @@
44
{-# LANGUAGE FlexibleContexts #-}
55
{-# LANGUAGE FlexibleInstances #-}
66
{-# LANGUAGE GADTs #-}
7+
{-# LANGUAGE LambdaCase #-}
78
{-# LANGUAGE RankNTypes #-}
89
{-# LANGUAGE ScopedTypeVariables #-}
910
{-# LANGUAGE TypeApplications #-}
@@ -130,6 +131,7 @@ data ShelleyQueryCmdError
130131
-- ^ Operational certificate of the unknown stake pool.
131132
| ShelleyQueryCmdPoolStateDecodeError DecoderError
132133
| ShelleyQueryCmdStakeSnapshotDecodeError DecoderError
134+
| ShelleyQueryCmdUnsupportedNtcVersion !UnsupportedNtcVersionError
133135

134136
deriving Show
135137

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

173179
runQueryCmd :: QueryCmd -> ExceptT ShelleyQueryCmdError IO ()
174180
runQueryCmd cmd =
@@ -211,7 +217,11 @@ runQueryProtocolParameters (AnyConsensusModeParams cModeParams) network mOutFile
211217
let localNodeConnInfo = LocalNodeConnectInfo cModeParams network sockPath
212218

213219
result <- liftIO $ executeLocalStateQueryExpr localNodeConnInfo Nothing $ \_ntcVersion -> runExceptT $ do
214-
anyE@(AnyCardanoEra era) <- lift $ determineEraExpr cModeParams
220+
eraResult <- lift $ determineEraExpr cModeParams
221+
222+
anyE@(AnyCardanoEra era) <- case eraResult of
223+
Right a -> pure a
224+
Left e -> throwE $ ShelleyQueryCmdUnsupportedNtcVersion e
215225

216226
case cardanoEraStyle era of
217227
LegacyByronEra -> left ShelleyQueryCmdByronEra
@@ -223,7 +233,10 @@ runQueryProtocolParameters (AnyConsensusModeParams cModeParams) network mOutFile
223233

224234
ppResult <- lift . queryExpr $ QueryInEra eInMode $ QueryInShelleyBasedEra sbe QueryProtocolParameters
225235

226-
except ppResult & firstExceptT ShelleyQueryCmdEraMismatch
236+
case ppResult of
237+
Right (Right a) -> pure a
238+
Right (Left e) -> throwE $ ShelleyQueryCmdEraMismatch e
239+
Left e -> throwE $ ShelleyQueryCmdUnsupportedNtcVersion e
227240

228241
writeProtocolParameters mOutFile =<< except (join (first ShelleyQueryCmdAcquireFailure result))
229242
where
@@ -263,6 +276,12 @@ percentage tolerance a b = Text.pack (printf "%.2f" pc)
263276
relativeTimeSeconds :: RelativeTime -> Integer
264277
relativeTimeSeconds (RelativeTime dt) = floor (nominalDiffTimeToSeconds dt)
265278

279+
swapEither :: Either e (Either x a) -> Either x (Either e a)
280+
swapEither = \case
281+
Left e -> Right (Left e)
282+
Right (Left e) -> Left e
283+
Right (Right a) -> Right (Right a)
284+
266285
-- | Query the chain tip via the chain sync protocol.
267286
--
268287
-- This is a fallback query to support older versions of node to client protocol.
@@ -285,25 +304,30 @@ runQueryTip (AnyConsensusModeParams cModeParams) network mOutFile = do
285304
CardanoMode -> do
286305
let localNodeConnInfo = LocalNodeConnectInfo cModeParams network sockPath
287306

288-
eLocalState <- liftIO $ executeLocalStateQueryExpr localNodeConnInfo Nothing $ \ntcVersion -> do
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-
}
307+
eLocalState <- ExceptT $ fmap swapEither $
308+
executeLocalStateQueryExpr localNodeConnInfo Nothing $ \ntcVersion -> runExceptT $ do
309+
era <- ExceptT $ fmap (first ShelleyQueryCmdUnsupportedNtcVersion) $
310+
queryExpr (QueryCurrentEra CardanoModeIsMultiEra)
311+
312+
eraHistory <- ExceptT $ fmap (first ShelleyQueryCmdUnsupportedNtcVersion) $
313+
queryExpr (QueryEraHistory CardanoModeIsMultiEra)
314+
315+
mChainBlockNo <- if ntcVersion >= NodeToClientV_10
316+
then fmap Just $ ExceptT $ fmap (first ShelleyQueryCmdUnsupportedNtcVersion) $ queryExpr QueryChainBlockNo
317+
else return Nothing
318+
mChainPoint <- if ntcVersion >= NodeToClientV_10
319+
then fmap Just $ ExceptT $ fmap (first ShelleyQueryCmdUnsupportedNtcVersion) $ queryExpr (QueryChainPoint CardanoMode)
320+
else return Nothing
321+
mSystemStart <- if ntcVersion >= NodeToClientV_9
322+
then fmap Just $ ExceptT $ fmap (first ShelleyQueryCmdUnsupportedNtcVersion) $ queryExpr QuerySystemStart
323+
else return Nothing
324+
325+
return O.QueryTipLocalState
326+
{ O.era = era
327+
, O.eraHistory = eraHistory
328+
, O.mSystemStart = mSystemStart
329+
, O.mChainTip = makeChainTip <$> mChainBlockNo <*> mChainPoint
330+
}
307331

308332
mLocalState <- hushM (first ShelleyQueryCmdAcquireFailure eLocalState) $ \e ->
309333
liftIO . T.hPutStrLn IO.stderr $ "Warning: Local state unavailable: " <> renderShelleyQueryCmdError e
@@ -1035,16 +1059,20 @@ runQueryStakePools (AnyConsensusModeParams cModeParams)
10351059
anyE@(AnyCardanoEra era) <- case consensusModeOnly cModeParams of
10361060
ByronMode -> return $ AnyCardanoEra ByronEra
10371061
ShelleyMode -> return $ AnyCardanoEra ShelleyEra
1038-
CardanoMode -> lift . queryExpr $ QueryCurrentEra CardanoModeIsMultiEra
1062+
CardanoMode -> ExceptT $ fmap (first ShelleyQueryCmdUnsupportedNtcVersion) $ queryExpr $ QueryCurrentEra CardanoModeIsMultiEra
10391063

10401064
let cMode = consensusModeOnly cModeParams
10411065

10421066
case toEraInMode era cMode of
10431067
Just eInMode -> do
10441068
sbe <- getSbe $ cardanoEraStyle era
10451069

1046-
firstExceptT ShelleyQueryCmdEraMismatch . ExceptT $
1047-
queryExpr . QueryInEra eInMode . QueryInShelleyBasedEra sbe $ QueryStakePools
1070+
r <- ExceptT $ fmap (first ShelleyQueryCmdUnsupportedNtcVersion) $ queryExpr $
1071+
QueryInEra eInMode $ QueryInShelleyBasedEra sbe $ QueryStakePools
1072+
1073+
case r of
1074+
Right a -> pure a
1075+
Left e -> throwE (ShelleyQueryCmdEraMismatch e)
10481076

10491077
Nothing -> left $ ShelleyQueryCmdEraConsensusModeMismatch (AnyConsensusMode cMode) anyE
10501078

0 commit comments

Comments
 (0)