Make queryStateForBalancedTx fully oops enabled

IntersectMBO · Mar 30, 2023 · a5f12ee · a5f12ee
1 parent 1c7ce89
commit a5f12ee
Show file tree

Hide file tree

Showing 3 changed files with 52 additions and 18 deletions.
diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs
@@ -781,11 +781,13 @@ module Cardano.Api (
     getNtcVersion_,
 
     -- ** Oops-enabled queries
+    queryStateForBalancedTx_,
     queryUtxo_,
     queryProtocolParams_,
     queryEraHistory_,
     queryStakePools_,
     querySystemStart_,
+    handleQueryConvenienceErrors_,
 
     -- ** Constraint satisfaction functions
     getIsCardanoEraConstraint,

diff --git a/cardano-api/src/Cardano/Api/Convenience/Query.hs b/cardano-api/src/Cardano/Api/Convenience/Query.hs
@@ -16,12 +16,15 @@ module Cardano.Api.Convenience.Query (
 
     queryStateForBalancedTx,
 
+    queryStateForBalancedTx_,
     queryUtxo_,
     queryProtocolParams_,
     queryEraHistory_,
     queryStakePools_,
     querySystemStart_,
 
+    handleQueryConvenienceErrors_,
+
     renderQueryConvenienceError,
   ) where
 
@@ -79,6 +82,16 @@ renderQueryConvenienceError (QueryConvenienceUnsupportedNodeToClientVersion
   (UnsupportedNtcVersionError minNodeToClientVersion nodeToClientVersion)) =
   "Unsupported Node to Client version: " <> textShow minNodeToClientVersion <> " " <> textShow nodeToClientVersion
 
+handleQueryConvenienceErrors_ :: ()
+  => Monad m
+  => OO.CouldBeF e QueryConvenienceError
+  => ExceptT (OO.Variant (EraMismatch : AcquireFailure : UnsupportedNtcVersionError : e)) m a
+  -> ExceptT (OO.Variant e) m a
+handleQueryConvenienceErrors_ f = f
+  & OO.catch @EraMismatch (OO.throw . QueryEraMismatch)
+  & OO.catch @AcquireFailure (OO.throw . AcqFailure . toAcquiringFailure)
+  & OO.catch @UnsupportedNtcVersionError (OO.throw . QueryConvenienceUnsupportedNodeToClientVersion)
+
 queryUtxo_ :: ()
   => OO.CouldBeF e UnsupportedNtcVersionError
   => OO.CouldBeF e EraMismatch
@@ -134,7 +147,24 @@ queryStateForBalancedTx
   -> NetworkId
   -> [TxIn]
   -> IO (Either QueryConvenienceError (UTxO era, ProtocolParameters, EraHistory CardanoMode, SystemStart, Set PoolId))
-queryStateForBalancedTx era networkId allTxIns = runExceptT $ OO.runOopsInExceptT @QueryConvenienceError $ do
+queryStateForBalancedTx era networkId allTxIns = OO.runOopsInEither @QueryConvenienceError $ do
+  queryStateForBalancedTx_ era networkId allTxIns
+    & OO.catch @EraMismatch (OO.throw . QueryEraMismatch)
+    & OO.catch @AcquireFailure (OO.throw . AcqFailure . toAcquiringFailure)
+    & OO.catch @UnsupportedNtcVersionError (OO.throw . QueryConvenienceUnsupportedNodeToClientVersion)
+
+-- | A convenience function to query the relevant information, from
+-- the local node, for Cardano.Api.Convenience.Construction.constructBalancedTx
+queryStateForBalancedTx_ :: ()
+  => OO.CouldBeF es QueryConvenienceError
+  => OO.CouldBeF es AcquireFailure
+  => OO.CouldBeF es UnsupportedNtcVersionError
+  => OO.CouldBeF es EraMismatch
+  => CardanoEra era
+  -> NetworkId
+  -> [TxIn]
+  -> ExceptT (OO.Variant es) IO (UTxO era, ProtocolParameters, EraHistory CardanoMode, SystemStart, Set PoolId)
+queryStateForBalancedTx_ era networkId allTxIns = do
   SocketPath sockPath <- lift readEnvSocketPath & OO.onLeft (OO.throw . SockErr)
 
   let cModeParams = CardanoModeParams $ EpochSlots 21600
@@ -147,17 +177,14 @@ queryStateForBalancedTx era networkId allTxIns = runExceptT $ OO.runOopsInExcept
     & OO.hoistMaybe (EraConsensusModeMismatch (AnyConsensusMode CardanoMode) (getIsCardanoEraConstraint era $ AnyCardanoEra era))
 
   -- Query execution
-  executeLocalStateQueryExpr_ localNodeConnInfo Nothing
-    ( do  utxo <- queryUtxo_ qeInMode qSbe allTxIns
-          pparams <- queryProtocolParams_ qeInMode qSbe
-          eraHistory <- queryEraHistory_
-          systemStart <- querySystemStart_
-          stakePools <- queryStakePools_ qeInMode qSbe
-
-          pure (utxo, pparams, eraHistory, systemStart, stakePools)
-    ) & OO.catch @EraMismatch (OO.throw . QueryEraMismatch)
-      & OO.catch @AcquireFailure (OO.throw . AcqFailure . toAcquiringFailure)
-      & OO.catch @UnsupportedNtcVersionError (OO.throw . QueryConvenienceUnsupportedNodeToClientVersion)
+  executeLocalStateQueryExpr_ localNodeConnInfo Nothing $ do
+    utxo <- queryUtxo_ qeInMode qSbe allTxIns
+    pparams <- queryProtocolParams_ qeInMode qSbe
+    eraHistory <- queryEraHistory_
+    systemStart <- querySystemStart_
+    stakePools <- queryStakePools_ qeInMode qSbe
+
+    pure (utxo, pparams, eraHistory, systemStart, stakePools)
 
 -- | Query the node to determine which era it is in.
 determineEra

diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Run/Transaction.hs b/cardano-cli/src/Cardano/CLI/Shelley/Run/Transaction.hs
@@ -6,6 +6,7 @@
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeApplications #-}
 
 {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
 
@@ -56,6 +57,7 @@ import           Cardano.CLI.Shelley.Run.Read
 import           Cardano.CLI.Shelley.Run.Validate
 import           Cardano.CLI.Types
 
+import qualified Control.Monad.Oops as OO
 import           Ouroboros.Consensus.Cardano.Block (EraMismatch (..))
 import qualified Ouroboros.Network.Protocol.LocalTxSubmission.Client as Net.Tx
 
@@ -420,17 +422,18 @@ runTxBuildCmd
 
       pparams <- pure mTxProtocolParams & onNothing (left ShelleyTxCmdProtocolParametersNotPresentInTxBody)
 
-
       executionUnitPrices <- pure (protocolParamPrices pparams) & onNothing (left ShelleyTxCmdPParamExecutionUnitsNotAvailable)
 
       let consensusMode = consensusModeOnly cModeParams
           bpp = bundleProtocolParams cEra pparams
 
       case consensusMode of
         CardanoMode -> do
-          (nodeEraUTxO, _, eraHistory, systemStart, _) <-
-            lift (queryStateForBalancedTx nodeEra nid allTxInputs)
-              & onLeft (left . ShelleyTxCmdQueryConvenienceError)
+          (nodeEraUTxO, _, eraHistory, systemStart, _)
+            <- queryStateForBalancedTx_ nodeEra nid allTxInputs
+                & handleQueryConvenienceErrors_
+                & OO.runOopsInExceptT @QueryConvenienceError
+                & firstExceptT ShelleyTxCmdQueryConvenienceError
 
           -- Why do we cast the era? The user can specify an era prior to the era that the node is currently in.
           -- We cannot use the user specified era to construct a query against a node because it may differ
@@ -715,8 +718,10 @@ runTxBuild era (AnyConsensusModeParams cModeParams) networkId mScriptValidity
         & onLeft (left . ShelleyTxCmdQueryConvenienceError . AcqFailure)
 
       (nodeEraUTxO, pparams, eraHistory, systemStart, stakePools) <-
-        firstExceptT ShelleyTxCmdQueryConvenienceError . newExceptT
-          $ queryStateForBalancedTx nodeEra networkId allTxInputs
+        queryStateForBalancedTx_ nodeEra networkId allTxInputs
+          & handleQueryConvenienceErrors_
+          & OO.runOopsInExceptT @QueryConvenienceError
+          & firstExceptT ShelleyTxCmdQueryConvenienceError
 
       validatedPParams <- hoistEither $ first ShelleyTxCmdProtocolParametersValidationError
                                       $ validateProtocolParameters era (Just pparams)