De-parameterise QueryError type

bench/tx-generator/src/Cardano/Benchmarking/Script/Core.hs

@@ -249,7 +249,7 @@ queryEra :: ActionM AnyCardanoEra
 queryEra = do
   localNodeConnectInfo <- getLocalConnectInfo
   chainTip  <- liftIO $ getLocalChainTip localNodeConnectInfo
-  ret <- liftIO $ executeLocalStateQueryExpr @() localNodeConnectInfo (Just $ chainTipToChainPoint chainTip)
+  ret <- liftIO $ executeLocalStateQueryExpr localNodeConnectInfo (Just $ chainTipToChainPoint chainTip) id
     $ queryExpr $ QueryCurrentEra CardanoModeIsMultiEra
   case ret of
     Right era -> return era
@@ -259,7 +259,7 @@ queryProtocolParameters :: ActionM ProtocolParameters
 queryProtocolParameters = do
   localNodeConnectInfo <- getLocalConnectInfo
   chainTip  <- liftIO $ getLocalChainTip localNodeConnectInfo
-  ret <- liftIO $ executeLocalStateQueryExpr @() localNodeConnectInfo (Just $ chainTipToChainPoint chainTip)
+  ret <- liftIO $ executeLocalStateQueryExpr  localNodeConnectInfo (Just $ chainTipToChainPoint chainTip) id
     $ queryExpr $ QueryInEra AlonzoEraInCardanoMode $ QueryInShelleyBasedEra ShelleyBasedEraAlonzo QueryProtocolParameters
   case ret of
     Right (Right pp) -> return pp

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

@@ -75,6 +75,7 @@ module Cardano.Api.IPC (
 
 import           Prelude
 
+import           Data.Bifunctor (first)
 import           Data.Void (Void)
 
 import qualified Data.ByteString.Lazy as LBS
@@ -165,10 +166,9 @@ data LocalNodeConnectInfo mode =
 
 type MinNodeToClientVersion = NodeToClientVersion
 
-data QueryError a
+data QueryError
   = QueryErrorAcquireFailure !Net.Query.AcquireFailure
   | QueryErrorUnsupportedVersion !MinNodeToClientVersion !NodeToClientVersion
-  | QueryErrorOf a
   deriving (Eq, Show)
 
 localConsensusMode :: LocalNodeConnectInfo mode -> ConsensusMode mode
@@ -489,9 +489,10 @@ convLocalStateQueryClient mode =
 queryNodeLocalState :: forall e mode result.
                        LocalNodeConnectInfo mode
                     -> Maybe ChainPoint
+                    -> (QueryError -> e)
                     -> QueryInMode mode result
-                    -> IO (Either (QueryError e) result)
-queryNodeLocalState connctInfo mpoint query = do
+                    -> IO (Either e result)
+queryNodeLocalState connctInfo mpoint mapQueryError query = do
     resultVar <- newEmptyTMVarIO
     connectToLocalNode
       connctInfo
@@ -500,11 +501,11 @@ queryNodeLocalState connctInfo mpoint query = do
       , localStateQueryClient   = Just (singleQuery mpoint resultVar)
       , localTxSubmissionClient = Nothing
       }
-    atomically (takeTMVar resultVar)
+    atomically (first mapQueryError <$> takeTMVar resultVar)
   where
     singleQuery
       :: Maybe ChainPoint
-      -> TMVar (Either (QueryError e) result)
+      -> TMVar (Either QueryError result)
       -> Net.Query.LocalStateQueryClient (BlockInMode mode) ChainPoint
                                          (QueryInMode mode) IO ()
     singleQuery mPointVar' resultVar' =

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

@@ -59,9 +59,10 @@ executeLocalStateQueryExpr
   :: forall e mode a .
      LocalNodeConnectInfo mode
   -> Maybe ChainPoint
-  -> LocalStateQueryExpr (BlockInMode mode) ChainPoint (QueryInMode mode) () IO (Either (QueryError e) a)
-  -> IO (Either (QueryError e) a)
-executeLocalStateQueryExpr connectInfo mpoint f = do
+  -> (QueryError -> e)
+  -> LocalStateQueryExpr (BlockInMode mode) ChainPoint (QueryInMode mode) () IO (Either e a)
+  -> IO (Either e a)
+executeLocalStateQueryExpr connectInfo mpoint mapQueryError f = do
   tmvResultLocalState <- newEmptyTMVarIO
   let waitResult = readTMVar tmvResultLocalState
 
@@ -70,7 +71,7 @@ executeLocalStateQueryExpr connectInfo mpoint f = do
     (\ntcVersion ->
       LocalNodeClientProtocols
       { localChainSyncClient    = NoLocalChainSyncClient
-      , localStateQueryClient   = Just $ setupLocalStateQueryExpr waitResult mpoint tmvResultLocalState ntcVersion f
+      , localStateQueryClient   = Just $ setupLocalStateQueryExpr waitResult mpoint tmvResultLocalState ntcVersion mapQueryError f
       , localTxSubmissionClient = Nothing
       }
     )
@@ -84,11 +85,12 @@ setupLocalStateQueryExpr ::
      -- Protocols must wait until 'waitDone' returns because premature exit will
      -- cause other incomplete protocols to abort which may lead to deadlock.
   -> Maybe ChainPoint
-  -> TMVar (Either (QueryError e) a)
+  -> TMVar (Either e a)
   -> NodeToClientVersion
-  -> LocalStateQueryExpr (BlockInMode mode) ChainPoint (QueryInMode mode) () IO (Either (QueryError e) a)
+  -> (QueryError -> e)
+  -> LocalStateQueryExpr (BlockInMode mode) ChainPoint (QueryInMode mode) () IO (Either e a)
   -> Net.Query.LocalStateQueryClient (BlockInMode mode) ChainPoint (QueryInMode mode) IO ()
-setupLocalStateQueryExpr waitDone mPointVar' resultVar' ntcVersion f =
+setupLocalStateQueryExpr waitDone mPointVar' resultVar' ntcVersion mapQueryError f =
   LocalStateQueryClient . pure . Net.Query.SendMsgAcquire mPointVar' $
     Net.Query.ClientStAcquiring
     { Net.Query.recvMsgAcquired = runContT (runReaderT (runLocalStateQueryExpr f) ntcVersion) $ \result -> do
@@ -97,18 +99,20 @@ setupLocalStateQueryExpr waitDone mPointVar' resultVar' ntcVersion f =
         pure $ Net.Query.SendMsgRelease $ pure $ Net.Query.SendMsgDone ()
 
     , Net.Query.recvMsgFailure = \failure -> do
-        atomically $ putTMVar resultVar' (Left (QueryErrorAcquireFailure failure))
+        atomically $ putTMVar resultVar' (Left (mapQueryError (QueryErrorAcquireFailure failure)))
         void $ atomically waitDone -- Wait for all protocols to complete before exiting.
         pure $ Net.Query.SendMsgDone ()
     }
 
 -- | Get the node server's Node-to-Client version.
-getNtcVersion :: LocalStateQueryExpr block point (QueryInMode mode) r IO (Either (QueryError e) NodeToClientVersion)
-getNtcVersion =  LocalStateQueryExpr . ReaderT $ pure . Right
+getNtcVersion :: LocalStateQueryExpr block point (QueryInMode mode) r IO (Either QueryError NodeToClientVersion)
+getNtcVersion =  LocalStateQueryExpr $ do
+  v <- ask
+  pure $ Right v
 
 -- | Lift a query value into a monadic query expression.
 -- Use 'queryExpr' in a do block to construct monadic local state queries.
-queryExpr :: QueryInMode mode a -> LocalStateQueryExpr block point (QueryInMode mode) r IO (Either (QueryError e) a)
+queryExpr :: QueryInMode mode a -> LocalStateQueryExpr block point (QueryInMode mode) r IO (Either QueryError a)
 queryExpr q = runExceptT $ do
   let minNtcVersion = ntcVersionOf q
   ntcVersion <- ExceptT getNtcVersion
@@ -124,7 +128,7 @@ queryExpr q = runExceptT $ do
 -- | Lift a query value into a monadic query expression returning Maybe of a result.
 -- This is the same as 'queryExpr' except if the query is not supported by the server, will return Nothing instead
 -- of throwing an error.
-maybeQueryExpr :: QueryInMode mode a -> LocalStateQueryExpr block point (QueryInMode mode) r IO (Either (QueryError e) (Maybe a))
+maybeQueryExpr :: QueryInMode mode a -> LocalStateQueryExpr block point (QueryInMode mode) r IO (Either QueryError (Maybe a))
 maybeQueryExpr q = runExceptT $ catchE (Just <$> ExceptT (queryExpr q)) $ \e ->
   case e of
     QueryErrorUnsupportedVersion _ _ -> return Nothing
@@ -133,7 +137,7 @@ maybeQueryExpr q = runExceptT $ catchE (Just <$> ExceptT (queryExpr q)) $ \e ->
 -- | A monadic expresion that determines what era the node is in.
 determineEraExpr ::
      ConsensusModeParams mode
-  -> LocalStateQueryExpr block point (QueryInMode mode) r IO (Either (QueryError a) AnyCardanoEra)
+  -> LocalStateQueryExpr block point (QueryInMode mode) r IO (Either QueryError AnyCardanoEra)
 determineEraExpr cModeParams = runExceptT $
   case consensusModeOnly cModeParams of
     ByronMode -> return $ AnyCardanoEra ByronEra

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

@@ -45,7 +45,7 @@ import           Cardano.Ledger.Shelley.LedgerState hiding (_delegations)
 import           Cardano.Ledger.Shelley.Scripts ()
 import           Cardano.Prelude hiding (atomically)
 import           Control.Monad.Trans.Except (except)
-import           Control.Monad.Trans.Except.Extra (firstExceptT, handleIOExceptT, hoistMaybe, left)
+import           Control.Monad.Trans.Except.Extra (firstExceptT, handleIOExceptT, hoistMaybe, left, hoistEither)
 import           Data.Aeson (ToJSON (..), (.=))
 import qualified Data.Aeson as Aeson
 import           Data.Aeson.Encode.Pretty (encodePretty)
@@ -93,12 +93,6 @@ data ShelleyQueryCmdError
   | ShelleyQueryCmdSystemStartUnavailable
   deriving Show
 
-renderQueryError :: QueryError ShelleyQueryCmdError -> Text
-renderQueryError (QueryErrorAcquireFailure acquireFail) = Text.pack $ show acquireFail
-renderQueryError (QueryErrorUnsupportedVersion minNtcVersion ntcVersion) =
-  "Minimum NtcVersion of " <> Text.pack (show minNtcVersion) <> " needed, but got " <> Text.pack (show ntcVersion)
-renderQueryError (QueryErrorOf e) = renderShelleyQueryCmdError e
-
 renderShelleyQueryCmdError :: ShelleyQueryCmdError -> Text
 renderShelleyQueryCmdError err =
   case err of
@@ -147,10 +141,9 @@ runQueryCmd cmd =
     QueryUTxO' consensusModeParams qFilter networkId mOutFile ->
       runQueryUTxO consensusModeParams qFilter networkId mOutFile
 
-queryErrorToShelleyQueryCmdError :: QueryError ShelleyQueryCmdError -> ShelleyQueryCmdError
-queryErrorToShelleyQueryCmdError (QueryErrorOf e) = e
-queryErrorToShelleyQueryCmdError (QueryErrorAcquireFailure a) = ShelleyQueryCmdAcquireFailure a
-queryErrorToShelleyQueryCmdError (QueryErrorUnsupportedVersion minNtcVersion mtcVersion) = ShelleyQueryCmdUnsupportedVersion minNtcVersion mtcVersion
+mapQueryError :: QueryError -> ShelleyQueryCmdError
+mapQueryError (QueryErrorAcquireFailure a) = ShelleyQueryCmdAcquireFailure a
+mapQueryError (QueryErrorUnsupportedVersion minNtcVersion mtcVersion) = ShelleyQueryCmdUnsupportedVersion minNtcVersion mtcVersion
 
 runQueryProtocolParameters
   :: AnyConsensusModeParams
@@ -162,22 +155,22 @@ runQueryProtocolParameters (AnyConsensusModeParams cModeParams) network mOutFile
                            readEnvSocketPath
   let localNodeConnInfo = LocalNodeConnectInfo cModeParams network sockPath
 
-  result <- liftIO $ executeLocalStateQueryExpr localNodeConnInfo Nothing $ runExceptT $ do
-    anyE@(AnyCardanoEra era) <- ExceptT $ determineEraExpr cModeParams
+  result <- liftIO $ executeLocalStateQueryExpr localNodeConnInfo Nothing mapQueryError $ runExceptT $ do
+    anyE@(AnyCardanoEra era) <- ExceptT $ determineEraExpr cModeParams <&> first mapQueryError
 
     case cardanoEraStyle era of
-      LegacyByronEra -> left (QueryErrorOf ShelleyQueryCmdByronEra)
+      LegacyByronEra -> left ShelleyQueryCmdByronEra
       ShelleyBasedEra sbe -> do
         let cMode = consensusModeOnly cModeParams
 
         eInMode <- toEraInMode era cMode
-          & hoistMaybe (QueryErrorOf (ShelleyQueryCmdEraConsensusModeMismatch (AnyConsensusMode cMode) anyE))
+          & hoistMaybe (ShelleyQueryCmdEraConsensusModeMismatch (AnyConsensusMode cMode) anyE)
 
-        ppResult <- ExceptT . queryExpr $ QueryInEra eInMode $ QueryInShelleyBasedEra sbe QueryProtocolParameters
+        ppResult <- ExceptT . fmap (first mapQueryError) $ queryExpr $ QueryInEra eInMode $ QueryInShelleyBasedEra sbe QueryProtocolParameters
 
-        except ppResult & firstExceptT (QueryErrorOf . ShelleyQueryCmdEraMismatch)
+        except ppResult & firstExceptT ShelleyQueryCmdEraMismatch
 
-  writeProtocolParameters mOutFile =<< except (first queryErrorToShelleyQueryCmdError result)
+  writeProtocolParameters mOutFile =<< except result
  where
   writeProtocolParameters
     :: Maybe OutputFile
@@ -236,12 +229,12 @@ runQueryTip (AnyConsensusModeParams cModeParams) network mOutFile = do
     CardanoMode -> do
       let localNodeConnInfo = LocalNodeConnectInfo cModeParams network sockPath
 
-      eLocalState <- liftIO $ executeLocalStateQueryExpr localNodeConnInfo Nothing $ runExceptT $ do
-        era <-  ExceptT $ queryExpr (QueryCurrentEra CardanoModeIsMultiEra)
-        eraHistory <- ExceptT $ queryExpr (QueryEraHistory CardanoModeIsMultiEra)
-        mChainBlockNo <- ExceptT $ maybeQueryExpr QueryChainBlockNo
-        mChainPoint <- ExceptT $ maybeQueryExpr (QueryChainPoint CardanoMode)
-        mSystemStart <- ExceptT $ maybeQueryExpr QuerySystemStart
+      eLocalState <- liftIO $ executeLocalStateQueryExpr localNodeConnInfo Nothing mapQueryError $ runExceptT $ do
+        era <-  firstExceptT mapQueryError . ExceptT $ queryExpr (QueryCurrentEra CardanoModeIsMultiEra)
+        eraHistory <- firstExceptT mapQueryError . ExceptT $ queryExpr (QueryEraHistory CardanoModeIsMultiEra)
+        mChainBlockNo <- firstExceptT mapQueryError .  ExceptT $ maybeQueryExpr QueryChainBlockNo
+        mChainPoint <- firstExceptT mapQueryError .  ExceptT $ maybeQueryExpr (QueryChainPoint CardanoMode)
+        mSystemStart <- firstExceptT mapQueryError .  ExceptT $ maybeQueryExpr QuerySystemStart
 
         return O.QueryTipLocalState
           { O.era = era
@@ -251,7 +244,7 @@ runQueryTip (AnyConsensusModeParams cModeParams) network mOutFile = do
           }
 
       mLocalState <- hushM eLocalState $ \e ->
-        liftIO . T.hPutStrLn IO.stderr $ "Warning: Local state unavailable: " <> renderQueryError e
+        liftIO . T.hPutStrLn IO.stderr $ "Warning: Local state unavailable: " <> renderShelleyQueryCmdError e
 
       chainTip <- case mLocalState >>= O.mChainTip of
         Just chainTip -> return chainTip
@@ -715,23 +708,21 @@ runQueryStakePools (AnyConsensusModeParams cModeParams)
 
   let localNodeConnInfo = LocalNodeConnectInfo cModeParams network sockPath
 
-  result <- ExceptT . fmap (join . first queryErrorToShelleyQueryCmdError) $
-    executeLocalStateQueryExpr localNodeConnInfo Nothing $ runExceptT $ do
+  result <- ExceptT $ executeLocalStateQueryExpr localNodeConnInfo Nothing mapQueryError $ runExceptT $ do
       anyE@(AnyCardanoEra era) <- case consensusModeOnly cModeParams of
         ByronMode -> return $ AnyCardanoEra ByronEra
         ShelleyMode -> return $ AnyCardanoEra ShelleyEra
-        CardanoMode -> ExceptT $ queryExpr $ QueryCurrentEra CardanoModeIsMultiEra
+        CardanoMode -> firstExceptT mapQueryError . ExceptT $ queryExpr $ QueryCurrentEra CardanoModeIsMultiEra
 
       let cMode = consensusModeOnly cModeParams
 
       case toEraInMode era cMode of
         Just eInMode -> do
           sbe <- ExceptT $ getSbeInQuery $ cardanoEraStyle era
+          result <- firstExceptT mapQueryError . ExceptT $ queryExpr . QueryInEra eInMode . QueryInShelleyBasedEra sbe $ QueryStakePools
+          hoistEither (first ShelleyQueryCmdEraMismatch result)
 
-          fmap (first ShelleyQueryCmdEraMismatch) $
-            ExceptT $ queryExpr . QueryInEra eInMode . QueryInShelleyBasedEra sbe $ QueryStakePools
-
-        Nothing -> left $ QueryErrorOf $ ShelleyQueryCmdEraConsensusModeMismatch (AnyConsensusMode cMode) anyE
+        Nothing -> left $ ShelleyQueryCmdEraConsensusModeMismatch (AnyConsensusMode cMode) anyE
 
   writeStakePools mOutFile result
 
@@ -850,14 +841,8 @@ determineEra cModeParams localNodeConnInfo =
   case consensusModeOnly cModeParams of
     ByronMode -> return $ AnyCardanoEra ByronEra
     ShelleyMode -> return $ AnyCardanoEra ShelleyEra
-    CardanoMode -> do
-      eraQ <- liftIO . executeLocalStateQueryExpr localNodeConnInfo Nothing
-        $ queryExpr $ QueryCurrentEra CardanoModeIsMultiEra
-      case eraQ of
-        Left (QueryErrorAcquireFailure acqFail) -> left $ ShelleyQueryCmdAcquireFailure acqFail
-        Left (QueryErrorUnsupportedVersion minNtcVersion ntcVersion) -> left $ ShelleyQueryCmdUnsupportedVersion minNtcVersion ntcVersion
-        Left (QueryErrorOf e) -> left e
-        Right anyCarEra -> return anyCarEra
+    CardanoMode -> ExceptT . liftIO . executeLocalStateQueryExpr localNodeConnInfo Nothing mapQueryError $ runExceptT $ do
+      firstExceptT mapQueryError . ExceptT $ queryExpr $ QueryCurrentEra CardanoModeIsMultiEra
 
 executeQuery
   :: forall result era mode. CardanoEra era
@@ -871,27 +856,24 @@ executeQuery era cModeP localNodeConnInfo q = do
     ByronEraInByronMode -> left ShelleyQueryCmdByronEra
     _ -> liftIO execQuery >>= queryResult
  where
-   execQuery :: IO (Either (QueryError ShelleyQueryCmdError) (Either EraMismatch result))
-   execQuery = executeLocalStateQueryExpr localNodeConnInfo Nothing $ queryExpr q
+   execQuery :: IO (Either ShelleyQueryCmdError (Either EraMismatch result))
+   execQuery = executeLocalStateQueryExpr localNodeConnInfo Nothing mapQueryError $ first mapQueryError <$> queryExpr q
 
 getSbe :: Monad m => CardanoEraStyle era -> ExceptT ShelleyQueryCmdError m (ShelleyBasedEra era)
 getSbe LegacyByronEra = left ShelleyQueryCmdByronEra
 getSbe (ShelleyBasedEra sbe) = return sbe
 
 
-getSbeInQuery :: Monad m => CardanoEraStyle era -> m (Either (QueryError ShelleyQueryCmdError) (ShelleyBasedEra era))
-getSbeInQuery LegacyByronEra = return (Left (QueryErrorOf ShelleyQueryCmdByronEra))
+getSbeInQuery :: Monad m => CardanoEraStyle era -> m (Either ShelleyQueryCmdError (ShelleyBasedEra era))
+getSbeInQuery LegacyByronEra = return (Left ShelleyQueryCmdByronEra)
 getSbeInQuery (ShelleyBasedEra sbe) = return (Right sbe)
 
 queryResult
-  :: Either (QueryError ShelleyQueryCmdError) (Either EraMismatch a)
+  :: Either ShelleyQueryCmdError (Either EraMismatch a)
   -> ExceptT ShelleyQueryCmdError IO a
 queryResult eAcq =
   case eAcq of
-    Left queryError -> case queryError of
-      QueryErrorAcquireFailure acquireFailure -> left $ ShelleyQueryCmdAcquireFailure acquireFailure
-      QueryErrorUnsupportedVersion minNtcVersion ntcVersion -> left (ShelleyQueryCmdUnsupportedVersion minNtcVersion ntcVersion)
-      QueryErrorOf e -> left e
+    Left e -> left e
     Right eResult ->
       case eResult of
         Left err -> left . ShelleyQueryCmdLocalStateQueryError $ EraMismatchError err