Merge pull request #4788 from input-output-hk/newhoggy/better-error-message-for-query-utxo-without-oops

Better error message for query utxo without oops

Author: newhoggy

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:

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

cardano-api/src/Cardano/Api.hs

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

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

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

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

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