diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs index bca8dc75a7a..c30fddf9e9b 100644 --- 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 index ed64f74dd4f..9bfffd1112f 100644 --- 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 index 645a849c2a0..f2dd83f8514 100644 --- 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,7 +422,6 @@ runTxBuildCmd pparams <- pure mTxProtocolParams & onNothing (left ShelleyTxCmdProtocolParametersNotPresentInTxBody) - executionUnitPrices <- pure (protocolParamPrices pparams) & onNothing (left ShelleyTxCmdPParamExecutionUnitsNotAvailable) let consensusMode = consensusModeOnly cModeParams @@ -428,9 +429,11 @@ runTxBuildCmd 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)