Without oops

Author: newhoggy

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

@@ -620,6 +620,7 @@ module Cardano.Api (
     UTxO(..),
     queryNodeLocalState,
     executeQueryCardanoMode,
+    UnsupportedNtcVersionError(..),
 
     -- *** Local tx monitoring
     LocalTxMonitorClient(..),

Diff for: 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 for: 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,6 +29,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 +99,32 @@ 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 $ do
+  v <- ask
+  pure v
+
 -- | 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
+  -> LocalStateQueryExpr block point (QueryInMode mode) r IO (Either UnsupportedNtcVersionError AnyCardanoEra)
 determineEraExpr cModeParams =
   case consensusModeOnly cModeParams of
-    ByronMode -> return $ AnyCardanoEra ByronEra
-    ShelleyMode -> return $ AnyCardanoEra ShelleyEra
+    ByronMode -> return $ Right $ AnyCardanoEra ByronEra
+    ShelleyMode -> return $ Right $ AnyCardanoEra ShelleyEra
     CardanoMode -> queryExpr $ QueryCurrentEra CardanoModeIsMultiEra

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

@@ -4,6 +4,7 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
@@ -130,6 +131,7 @@ data ShelleyQueryCmdError
       -- ^ Operational certificate of the unknown stake pool.
   | ShelleyQueryCmdPoolStateDecodeError DecoderError
   | ShelleyQueryCmdStakeSnapshotDecodeError DecoderError
+  | ShelleyQueryCmdUnsupportedNtcVersion !UnsupportedNtcVersionError
 
   deriving Show
 
@@ -169,6 +171,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 =
@@ -211,7 +217,11 @@ runQueryProtocolParameters (AnyConsensusModeParams cModeParams) network mOutFile
   let localNodeConnInfo = LocalNodeConnectInfo cModeParams network sockPath
 
   result <- liftIO $ executeLocalStateQueryExpr localNodeConnInfo Nothing $ runExceptT $ do
-    anyE@(AnyCardanoEra era) <- lift $ determineEraExpr cModeParams
+    eraResult <- lift $ determineEraExpr cModeParams
+
+    anyE@(AnyCardanoEra era) <- case eraResult of
+      Right a -> pure a
+      Left e -> throwE $ ShelleyQueryCmdUnsupportedNtcVersion e
 
     case cardanoEraStyle era of
       LegacyByronEra -> left ShelleyQueryCmdByronEra
@@ -223,7 +233,10 @@ runQueryProtocolParameters (AnyConsensusModeParams cModeParams) network mOutFile
 
         ppResult <- lift . queryExpr $ QueryInEra eInMode $ QueryInShelleyBasedEra sbe QueryProtocolParameters
 
-        except ppResult & firstExceptT ShelleyQueryCmdEraMismatch
+        case ppResult of
+          Right (Right a) -> pure a
+          Right (Left e) -> throwE $ ShelleyQueryCmdEraMismatch e
+          Left e -> throwE $ ShelleyQueryCmdUnsupportedNtcVersion e
 
   writeProtocolParameters mOutFile =<< except (join (first ShelleyQueryCmdAcquireFailure result))
  where
@@ -285,26 +298,24 @@ runQueryTip (AnyConsensusModeParams cModeParams) network mOutFile = do
     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 <- ExceptT $ fmap (first ShelleyQueryCmdUnsupportedNtcVersion) $
+            queryExpr (QueryCurrentEra CardanoModeIsMultiEra)
+
+          eraHistory <- ExceptT $ fmap (first ShelleyQueryCmdUnsupportedNtcVersion) $
+            queryExpr (QueryEraHistory CardanoModeIsMultiEra)
+
+          mChainBlockNo <- fmap Just $ ExceptT $ fmap (first ShelleyQueryCmdUnsupportedNtcVersion) $ queryExpr QueryChainBlockNo
+          mChainPoint <- fmap Just $ ExceptT $ fmap (first ShelleyQueryCmdUnsupportedNtcVersion) $ queryExpr (QueryChainPoint CardanoMode)
+          mSystemStart <- fmap Just $ ExceptT $ fmap (first ShelleyQueryCmdUnsupportedNtcVersion) $ queryExpr QuerySystemStart
+
+          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
@@ -1036,16 +1047,20 @@ runQueryStakePools (AnyConsensusModeParams cModeParams)
       anyE@(AnyCardanoEra era) <- case consensusModeOnly cModeParams of
         ByronMode -> return $ AnyCardanoEra ByronEra
         ShelleyMode -> return $ AnyCardanoEra ShelleyEra
-        CardanoMode -> lift . queryExpr $ QueryCurrentEra CardanoModeIsMultiEra
+        CardanoMode -> ExceptT $ fmap (first ShelleyQueryCmdUnsupportedNtcVersion) $ queryExpr $ QueryCurrentEra CardanoModeIsMultiEra
 
       let cMode = consensusModeOnly cModeParams
 
       case toEraInMode era cMode of
         Just eInMode -> do
           sbe <- getSbe $ cardanoEraStyle era
 
-          firstExceptT ShelleyQueryCmdEraMismatch . ExceptT $
-            queryExpr . QueryInEra eInMode . QueryInShelleyBasedEra sbe $ QueryStakePools
+          r <- ExceptT $ fmap (first ShelleyQueryCmdUnsupportedNtcVersion) $ queryExpr $
+            QueryInEra eInMode $ QueryInShelleyBasedEra sbe $ QueryStakePools
+
+          case r of
+            Right a -> pure a
+            Left e -> throwE (ShelleyQueryCmdEraMismatch e)
 
         Nothing -> left $ ShelleyQueryCmdEraConsensusModeMismatch (AnyConsensusMode cMode) anyE