From 0f27cc7a6f723b8c9e65e2b281eba1800ba9634f Mon Sep 17 00:00:00 2001 From: Mateusz Galazyn Date: Fri, 28 Jun 2024 12:07:19 +0200 Subject: [PATCH] Refactor. * Remove redundant era conversion functions. * Add IO Exception handling to consensus query execution. * Refactor Cardano.Api.Convenience.Query to return `ExceptT e IO a` instead of `IO (Either e a)` --- cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs | 4 +- .../internal/Cardano/Api/Convenience/Query.hs | 30 +++++++----- .../Cardano/Api/Eon/AllegraEraOnwards.hs | 4 -- .../Cardano/Api/Eon/AlonzoEraOnwards.hs | 4 -- .../Cardano/Api/Eon/BabbageEraOnwards.hs | 4 -- .../Cardano/Api/Eon/ByronToAlonzoEra.hs | 9 ---- .../Cardano/Api/Eon/ConwayEraOnwards.hs | 4 -- .../Cardano/Api/Eon/MaryEraOnwards.hs | 4 -- .../Cardano/Api/Eon/ShelleyBasedEra.hs | 18 ++----- .../Cardano/Api/Eon/ShelleyEraOnly.hs | 4 -- .../Cardano/Api/Eon/ShelleyToAllegraEra.hs | 4 -- .../Cardano/Api/Eon/ShelleyToAlonzoEra.hs | 4 -- .../Cardano/Api/Eon/ShelleyToBabbageEra.hs | 4 -- .../Cardano/Api/Eon/ShelleyToMaryEra.hs | 4 -- cardano-api/internal/Cardano/Api/Feature.hs | 2 +- cardano-api/internal/Cardano/Api/Fees.hs | 6 +-- cardano-api/internal/Cardano/Api/IPC.hs | 47 +++++++++++-------- .../internal/Cardano/Api/Monad/Error.hs | 8 ++++ .../Cardano/Api/ProtocolParameters.hs | 2 +- cardano-api/internal/Cardano/Api/Query.hs | 2 +- cardano-api/internal/Cardano/Api/Tx/Body.hs | 4 +- cardano-api/src/Cardano/Api.hs | 11 ----- .../cardano-api-test/Test/Cardano/Api/Eras.hs | 4 +- 23 files changed, 69 insertions(+), 118 deletions(-) diff --git a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs index 7c92c7a062..980d4e89f5 100644 --- a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs +++ b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs @@ -634,7 +634,7 @@ genTxMintValue = genTxBodyContent :: ShelleyBasedEra era -> Gen (TxBodyContent BuildTx era) genTxBodyContent sbe = do - let era = shelleyBasedToCardanoEra sbe + let era = toCardanoEra sbe txIns <- map (, BuildTxWith (KeyWitness KeyWitnessForSpending)) <$> Gen.list (Range.constant 1 10) genTxIn txInsCollateral <- genTxInsCollateral era txInsReference <- genTxInsReference era @@ -1111,4 +1111,4 @@ genCurrentTreasuryValue :: ConwayEraOnwards era -> Gen L.Coin genCurrentTreasuryValue _era = Q.arbitrary genTreasuryDonation :: ConwayEraOnwards era -> Gen L.Coin -genTreasuryDonation _era = Q.arbitrary \ No newline at end of file +genTreasuryDonation _era = Q.arbitrary diff --git a/cardano-api/internal/Cardano/Api/Convenience/Query.hs b/cardano-api/internal/Cardano/Api/Convenience/Query.hs index c6699a6c52..dbdcb657e7 100644 --- a/cardano-api/internal/Cardano/Api/Convenience/Query.hs +++ b/cardano-api/internal/Cardano/Api/Convenience/Query.hs @@ -29,6 +29,7 @@ import Cardano.Api.Feature (Featured (..)) import Cardano.Api.IO import Cardano.Api.IPC import Cardano.Api.IPC.Monad +import Cardano.Api.Monad.Error import Cardano.Api.NetworkId import Cardano.Api.ProtocolParameters import Cardano.Api.Query @@ -45,9 +46,9 @@ import qualified Cardano.Ledger.Shelley.LedgerState as L import Ouroboros.Consensus.HardFork.Combinator.AcrossEras (EraMismatch (..)) import Ouroboros.Network.Protocol.LocalStateQuery.Type (Target (..)) -import Control.Monad.Trans (MonadTrans (..)) -import Control.Monad.Trans.Except (ExceptT (..), runExceptT) -import Control.Monad.Trans.Except.Extra (left, onLeft, onNothing) +import Control.Exception.Safe (SomeException, displayException) +import Control.Monad +import Data.Bifunctor (first) import Data.Function ((&)) import Data.Map (Map) import qualified Data.Map as Map @@ -55,12 +56,14 @@ import Data.Maybe (mapMaybe) import Data.Set (Set) import qualified Data.Set as Set import Data.Text (Text) +import GHC.Exts (IsString (..)) data QueryConvenienceError = AcqFailure AcquiringFailure | QueryEraMismatch EraMismatch | ByronEraNotSupported | QceUnsupportedNtcVersion !UnsupportedNtcVersionError + | QceUnexpectedException !SomeException deriving Show renderQueryConvenienceError :: QueryConvenienceError -> Text @@ -76,6 +79,8 @@ renderQueryConvenienceError (QceUnsupportedNtcVersion (UnsupportedNtcVersionErro "Unsupported feature for the node-to-client protocol version.\n" <> "This query requires at least " <> textShow minNtcVersion <> " but the node negotiated " <> textShow ntcVersion <> ".\n" <> "Later node versions support later protocol versions (but development protocol versions are not enabled in the node by default)." +renderQueryConvenienceError (QceUnexpectedException e) = + "Unexpected exception while processing query:\n" <> fromString (displayException e) newtype TxCurrentTreasuryValue = TxCurrentTreasuryValue { unTxCurrentTreasuryValue :: L.Coin } deriving newtype Show @@ -153,7 +158,7 @@ queryStateForBalancedTx era allTxIns certs = runExceptT $ do -- | Query the node to determine which era it is in. determineEra :: () => LocalNodeConnectInfo - -> IO (Either AcquiringFailure AnyCardanoEra) + -> ExceptT AcquiringFailure IO AnyCardanoEra determineEra localNodeConnInfo = queryNodeLocalState localNodeConnInfo VolatileTip QueryCurrentEra @@ -163,8 +168,8 @@ executeQueryCardanoMode :: () => SocketPath -> NetworkId -> QueryInMode (Either EraMismatch result) - -> IO (Either QueryConvenienceError result) -executeQueryCardanoMode socketPath nid q = runExceptT $ do + -> ExceptT QueryConvenienceError IO result +executeQueryCardanoMode socketPath nid q = do let localNodeConnInfo = LocalNodeConnectInfo { localConsensusModeParams = CardanoModeParams (EpochSlots 21600) @@ -172,14 +177,15 @@ executeQueryCardanoMode socketPath nid q = runExceptT $ do , localNodeSocketPath = socketPath } - ExceptT $ executeQueryAnyMode localNodeConnInfo q + executeQueryAnyMode localNodeConnInfo q -- | Execute a query against the local node in any mode. executeQueryAnyMode :: forall result. () => LocalNodeConnectInfo -> QueryInMode (Either EraMismatch result) - -> IO (Either QueryConvenienceError result) -executeQueryAnyMode localNodeConnInfo q = runExceptT $ do - lift (queryNodeLocalState localNodeConnInfo VolatileTip q) - & onLeft (left . AcqFailure) - & onLeft (left . QueryEraMismatch) + -> ExceptT QueryConvenienceError IO result +executeQueryAnyMode localNodeConnInfo q = + liftEither <=< fmap (first QueryEraMismatch) + . handleIOExceptionsWith QceUnexpectedException + . modifyError AcqFailure + $ queryNodeLocalState localNodeConnInfo VolatileTip q diff --git a/cardano-api/internal/Cardano/Api/Eon/AllegraEraOnwards.hs b/cardano-api/internal/Cardano/Api/Eon/AllegraEraOnwards.hs index 07be578303..e4bc2964fa 100644 --- a/cardano-api/internal/Cardano/Api/Eon/AllegraEraOnwards.hs +++ b/cardano-api/internal/Cardano/Api/Eon/AllegraEraOnwards.hs @@ -11,7 +11,6 @@ module Cardano.Api.Eon.AllegraEraOnwards ( AllegraEraOnwards(..) , allegraEraOnwardsConstraints - , allegraEraOnwardsToCardanoEra , allegraEraOnwardsToShelleyBasedEra , AllegraEraOnwardsConstraints @@ -102,9 +101,6 @@ allegraEraOnwardsConstraints = \case AllegraEraOnwardsBabbage -> id AllegraEraOnwardsConway -> id -allegraEraOnwardsToCardanoEra :: AllegraEraOnwards era -> CardanoEra era -allegraEraOnwardsToCardanoEra = shelleyBasedToCardanoEra . allegraEraOnwardsToShelleyBasedEra - allegraEraOnwardsToShelleyBasedEra :: AllegraEraOnwards era -> ShelleyBasedEra era allegraEraOnwardsToShelleyBasedEra = \case AllegraEraOnwardsAllegra -> ShelleyBasedEraAllegra diff --git a/cardano-api/internal/Cardano/Api/Eon/AlonzoEraOnwards.hs b/cardano-api/internal/Cardano/Api/Eon/AlonzoEraOnwards.hs index 446def6217..6b63d37703 100644 --- a/cardano-api/internal/Cardano/Api/Eon/AlonzoEraOnwards.hs +++ b/cardano-api/internal/Cardano/Api/Eon/AlonzoEraOnwards.hs @@ -11,7 +11,6 @@ module Cardano.Api.Eon.AlonzoEraOnwards ( AlonzoEraOnwards(..) , alonzoEraOnwardsConstraints - , alonzoEraOnwardsToCardanoEra , alonzoEraOnwardsToShelleyBasedEra , AlonzoEraOnwardsConstraints @@ -113,9 +112,6 @@ alonzoEraOnwardsConstraints = \case AlonzoEraOnwardsBabbage -> id AlonzoEraOnwardsConway -> id -alonzoEraOnwardsToCardanoEra :: AlonzoEraOnwards era -> CardanoEra era -alonzoEraOnwardsToCardanoEra = shelleyBasedToCardanoEra . alonzoEraOnwardsToShelleyBasedEra - alonzoEraOnwardsToShelleyBasedEra :: AlonzoEraOnwards era -> ShelleyBasedEra era alonzoEraOnwardsToShelleyBasedEra = \case AlonzoEraOnwardsAlonzo -> ShelleyBasedEraAlonzo diff --git a/cardano-api/internal/Cardano/Api/Eon/BabbageEraOnwards.hs b/cardano-api/internal/Cardano/Api/Eon/BabbageEraOnwards.hs index 3ad528f18d..be41a5f30d 100644 --- a/cardano-api/internal/Cardano/Api/Eon/BabbageEraOnwards.hs +++ b/cardano-api/internal/Cardano/Api/Eon/BabbageEraOnwards.hs @@ -11,7 +11,6 @@ module Cardano.Api.Eon.BabbageEraOnwards ( BabbageEraOnwards(..) , babbageEraOnwardsConstraints - , babbageEraOnwardsToCardanoEra , babbageEraOnwardsToShelleyBasedEra , BabbageEraOnwardsConstraints @@ -107,9 +106,6 @@ babbageEraOnwardsConstraints = \case BabbageEraOnwardsBabbage -> id BabbageEraOnwardsConway -> id -babbageEraOnwardsToCardanoEra :: BabbageEraOnwards era -> CardanoEra era -babbageEraOnwardsToCardanoEra = shelleyBasedToCardanoEra . babbageEraOnwardsToShelleyBasedEra - babbageEraOnwardsToShelleyBasedEra :: BabbageEraOnwards era -> ShelleyBasedEra era babbageEraOnwardsToShelleyBasedEra = \case BabbageEraOnwardsBabbage -> ShelleyBasedEraBabbage diff --git a/cardano-api/internal/Cardano/Api/Eon/ByronToAlonzoEra.hs b/cardano-api/internal/Cardano/Api/Eon/ByronToAlonzoEra.hs index 936998ba93..e837d1d78f 100644 --- a/cardano-api/internal/Cardano/Api/Eon/ByronToAlonzoEra.hs +++ b/cardano-api/internal/Cardano/Api/Eon/ByronToAlonzoEra.hs @@ -10,7 +10,6 @@ module Cardano.Api.Eon.ByronToAlonzoEra ( ByronToAlonzoEra(..) , byronToAlonzoEraConstraints - , byronToAlonzoEraToCardanoEra , ByronToAlonzoEraConstraints ) where @@ -62,11 +61,3 @@ byronToAlonzoEraConstraints = \case ByronToAlonzoEraAllegra -> id ByronToAlonzoEraMary -> id ByronToAlonzoEraAlonzo -> id - -byronToAlonzoEraToCardanoEra :: ByronToAlonzoEra era -> CardanoEra era -byronToAlonzoEraToCardanoEra = \case - ByronToAlonzoEraByron -> ByronEra - ByronToAlonzoEraShelley -> ShelleyEra - ByronToAlonzoEraAllegra -> AllegraEra - ByronToAlonzoEraMary -> MaryEra - ByronToAlonzoEraAlonzo -> AlonzoEra diff --git a/cardano-api/internal/Cardano/Api/Eon/ConwayEraOnwards.hs b/cardano-api/internal/Cardano/Api/Eon/ConwayEraOnwards.hs index 8dfe5147f1..a38ef5867c 100644 --- a/cardano-api/internal/Cardano/Api/Eon/ConwayEraOnwards.hs +++ b/cardano-api/internal/Cardano/Api/Eon/ConwayEraOnwards.hs @@ -11,7 +11,6 @@ module Cardano.Api.Eon.ConwayEraOnwards ( ConwayEraOnwards(..) , conwayEraOnwardsConstraints - , conwayEraOnwardsToCardanoEra , conwayEraOnwardsToShelleyBasedEra , ConwayEraOnwardsConstraints @@ -109,9 +108,6 @@ conwayEraOnwardsConstraints :: () conwayEraOnwardsConstraints = \case ConwayEraOnwardsConway -> id -conwayEraOnwardsToCardanoEra :: ConwayEraOnwards era -> CardanoEra era -conwayEraOnwardsToCardanoEra = shelleyBasedToCardanoEra . conwayEraOnwardsToShelleyBasedEra - conwayEraOnwardsToShelleyBasedEra :: ConwayEraOnwards era -> ShelleyBasedEra era conwayEraOnwardsToShelleyBasedEra = \case ConwayEraOnwardsConway -> ShelleyBasedEraConway diff --git a/cardano-api/internal/Cardano/Api/Eon/MaryEraOnwards.hs b/cardano-api/internal/Cardano/Api/Eon/MaryEraOnwards.hs index ca789b157e..9247e1245d 100644 --- a/cardano-api/internal/Cardano/Api/Eon/MaryEraOnwards.hs +++ b/cardano-api/internal/Cardano/Api/Eon/MaryEraOnwards.hs @@ -11,7 +11,6 @@ module Cardano.Api.Eon.MaryEraOnwards ( MaryEraOnwards(..) , maryEraOnwardsConstraints - , maryEraOnwardsToCardanoEra , maryEraOnwardsToShelleyBasedEra , MaryEraOnwardsConstraints @@ -103,9 +102,6 @@ maryEraOnwardsConstraints = \case MaryEraOnwardsBabbage -> id MaryEraOnwardsConway -> id -maryEraOnwardsToCardanoEra :: MaryEraOnwards era -> CardanoEra era -maryEraOnwardsToCardanoEra = shelleyBasedToCardanoEra . maryEraOnwardsToShelleyBasedEra - maryEraOnwardsToShelleyBasedEra :: MaryEraOnwards era -> ShelleyBasedEra era maryEraOnwardsToShelleyBasedEra = \case MaryEraOnwardsMary -> ShelleyBasedEraMary diff --git a/cardano-api/internal/Cardano/Api/Eon/ShelleyBasedEra.hs b/cardano-api/internal/Cardano/Api/Eon/ShelleyBasedEra.hs index 7a163cb847..c7fe9d96f5 100644 --- a/cardano-api/internal/Cardano/Api/Eon/ShelleyBasedEra.hs +++ b/cardano-api/internal/Cardano/Api/Eon/ShelleyBasedEra.hs @@ -17,7 +17,6 @@ module Cardano.Api.Eon.ShelleyBasedEra , AnyShelleyBasedEra(..) , InAnyShelleyBasedEra(..) , inAnyShelleyBasedEra - , shelleyBasedToCardanoEra , inEonForShelleyBasedEra , inEonForShelleyBasedEraMaybe , forShelleyBasedEraInEon @@ -71,7 +70,7 @@ inEonForShelleyBasedEra :: () -> ShelleyBasedEra era -> a inEonForShelleyBasedEra no yes = - inEonForEra no yes . shelleyBasedToCardanoEra + inEonForEra no yes . toCardanoEra inEonForShelleyBasedEraMaybe :: () => Eon eon @@ -86,7 +85,7 @@ forShelleyBasedEraMaybeEon :: () => ShelleyBasedEra era -> Maybe (eon era) forShelleyBasedEraMaybeEon = - inEonForEra Nothing Just . shelleyBasedToCardanoEra + inEonForEra Nothing Just . toCardanoEra forShelleyBasedEraInEon :: () => Eon eon @@ -139,10 +138,10 @@ deriving instance Ord (ShelleyBasedEra era) deriving instance Show (ShelleyBasedEra era) instance Pretty (ShelleyBasedEra era) where - pretty = pretty . shelleyBasedToCardanoEra + pretty = pretty . toCardanoEra instance ToJSON (ShelleyBasedEra era) where - toJSON = toJSON . shelleyBasedToCardanoEra + toJSON = toJSON . toCardanoEra instance TestEquality ShelleyBasedEra where testEquality ShelleyBasedEraShelley ShelleyBasedEraShelley = Just Refl @@ -306,15 +305,6 @@ inAnyShelleyBasedEra :: () inAnyShelleyBasedEra sbe a = shelleyBasedEraConstraints sbe $ InAnyShelleyBasedEra sbe a --- | Converts a 'ShelleyBasedEra' to the broader 'CardanoEra'. -shelleyBasedToCardanoEra :: ShelleyBasedEra era -> CardanoEra era -shelleyBasedToCardanoEra ShelleyBasedEraShelley = ShelleyEra -shelleyBasedToCardanoEra ShelleyBasedEraAllegra = AllegraEra -shelleyBasedToCardanoEra ShelleyBasedEraMary = MaryEra -shelleyBasedToCardanoEra ShelleyBasedEraAlonzo = AlonzoEra -shelleyBasedToCardanoEra ShelleyBasedEraBabbage = BabbageEra -shelleyBasedToCardanoEra ShelleyBasedEraConway = ConwayEra - -- ---------------------------------------------------------------------------- -- Conversion to Shelley ledger library types -- diff --git a/cardano-api/internal/Cardano/Api/Eon/ShelleyEraOnly.hs b/cardano-api/internal/Cardano/Api/Eon/ShelleyEraOnly.hs index 4bee0227fe..43555a6893 100644 --- a/cardano-api/internal/Cardano/Api/Eon/ShelleyEraOnly.hs +++ b/cardano-api/internal/Cardano/Api/Eon/ShelleyEraOnly.hs @@ -11,7 +11,6 @@ module Cardano.Api.Eon.ShelleyEraOnly ( ShelleyEraOnly(..) , shelleyEraOnlyConstraints - , shelleyEraOnlyToCardanoEra , shelleyEraOnlyToShelleyBasedEra , ShelleyEraOnlyConstraints @@ -99,9 +98,6 @@ shelleyEraOnlyConstraints :: () shelleyEraOnlyConstraints = \case ShelleyEraOnlyShelley -> id -shelleyEraOnlyToCardanoEra :: ShelleyEraOnly era -> CardanoEra era -shelleyEraOnlyToCardanoEra = shelleyBasedToCardanoEra . shelleyEraOnlyToShelleyBasedEra - shelleyEraOnlyToShelleyBasedEra :: ShelleyEraOnly era -> ShelleyBasedEra era shelleyEraOnlyToShelleyBasedEra = \case ShelleyEraOnlyShelley -> ShelleyBasedEraShelley diff --git a/cardano-api/internal/Cardano/Api/Eon/ShelleyToAllegraEra.hs b/cardano-api/internal/Cardano/Api/Eon/ShelleyToAllegraEra.hs index 4981aafbb2..f6d7b85259 100644 --- a/cardano-api/internal/Cardano/Api/Eon/ShelleyToAllegraEra.hs +++ b/cardano-api/internal/Cardano/Api/Eon/ShelleyToAllegraEra.hs @@ -11,7 +11,6 @@ module Cardano.Api.Eon.ShelleyToAllegraEra ( ShelleyToAllegraEra(..) , shelleyToAllegraEraConstraints - , shelleyToAllegraEraToCardanoEra , shelleyToAllegraEraToShelleyBasedEra , ShelleyToAllegraEraConstraints @@ -102,9 +101,6 @@ shelleyToAllegraEraConstraints = \case ShelleyToAllegraEraShelley -> id ShelleyToAllegraEraAllegra -> id -shelleyToAllegraEraToCardanoEra :: ShelleyToAllegraEra era -> CardanoEra era -shelleyToAllegraEraToCardanoEra = shelleyBasedToCardanoEra . shelleyToAllegraEraToShelleyBasedEra - shelleyToAllegraEraToShelleyBasedEra :: ShelleyToAllegraEra era -> ShelleyBasedEra era shelleyToAllegraEraToShelleyBasedEra = \case ShelleyToAllegraEraShelley -> ShelleyBasedEraShelley diff --git a/cardano-api/internal/Cardano/Api/Eon/ShelleyToAlonzoEra.hs b/cardano-api/internal/Cardano/Api/Eon/ShelleyToAlonzoEra.hs index cc708db742..b017c699bb 100644 --- a/cardano-api/internal/Cardano/Api/Eon/ShelleyToAlonzoEra.hs +++ b/cardano-api/internal/Cardano/Api/Eon/ShelleyToAlonzoEra.hs @@ -11,7 +11,6 @@ module Cardano.Api.Eon.ShelleyToAlonzoEra ( ShelleyToAlonzoEra(..) , shelleyToAlonzoEraConstraints - , shelleyToAlonzoEraToCardanoEra , shelleyToAlonzoEraToShelleyBasedEra , ShelleyToAlonzoEraConstraints @@ -103,9 +102,6 @@ shelleyToAlonzoEraConstraints = \case ShelleyToAlonzoEraMary -> id ShelleyToAlonzoEraAlonzo -> id -shelleyToAlonzoEraToCardanoEra :: ShelleyToAlonzoEra era -> CardanoEra era -shelleyToAlonzoEraToCardanoEra = shelleyBasedToCardanoEra . shelleyToAlonzoEraToShelleyBasedEra - shelleyToAlonzoEraToShelleyBasedEra :: ShelleyToAlonzoEra era -> ShelleyBasedEra era shelleyToAlonzoEraToShelleyBasedEra = \case ShelleyToAlonzoEraShelley -> ShelleyBasedEraShelley diff --git a/cardano-api/internal/Cardano/Api/Eon/ShelleyToBabbageEra.hs b/cardano-api/internal/Cardano/Api/Eon/ShelleyToBabbageEra.hs index e6b0907b36..20cc65eb11 100644 --- a/cardano-api/internal/Cardano/Api/Eon/ShelleyToBabbageEra.hs +++ b/cardano-api/internal/Cardano/Api/Eon/ShelleyToBabbageEra.hs @@ -11,7 +11,6 @@ module Cardano.Api.Eon.ShelleyToBabbageEra ( ShelleyToBabbageEra(..) , shelleyToBabbageEraConstraints - , shelleyToBabbageEraToCardanoEra , shelleyToBabbageEraToShelleyBasedEra , ShelleyToBabbageEraConstraints @@ -105,9 +104,6 @@ shelleyToBabbageEraConstraints = \case ShelleyToBabbageEraAlonzo -> id ShelleyToBabbageEraBabbage -> id -shelleyToBabbageEraToCardanoEra :: ShelleyToBabbageEra era -> CardanoEra era -shelleyToBabbageEraToCardanoEra = shelleyBasedToCardanoEra . shelleyToBabbageEraToShelleyBasedEra - shelleyToBabbageEraToShelleyBasedEra :: ShelleyToBabbageEra era -> ShelleyBasedEra era shelleyToBabbageEraToShelleyBasedEra = \case ShelleyToBabbageEraShelley -> ShelleyBasedEraShelley diff --git a/cardano-api/internal/Cardano/Api/Eon/ShelleyToMaryEra.hs b/cardano-api/internal/Cardano/Api/Eon/ShelleyToMaryEra.hs index 41c0b919a9..b48ee997bd 100644 --- a/cardano-api/internal/Cardano/Api/Eon/ShelleyToMaryEra.hs +++ b/cardano-api/internal/Cardano/Api/Eon/ShelleyToMaryEra.hs @@ -11,7 +11,6 @@ module Cardano.Api.Eon.ShelleyToMaryEra ( ShelleyToMaryEra(..) , shelleyToMaryEraConstraints - , shelleyToMaryEraToCardanoEra , shelleyToMaryEraToShelleyBasedEra , ShelleyToMaryEraConstraints @@ -101,9 +100,6 @@ shelleyToMaryEraConstraints = \case ShelleyToMaryEraAllegra -> id ShelleyToMaryEraMary -> id -shelleyToMaryEraToCardanoEra :: ShelleyToMaryEra era -> CardanoEra era -shelleyToMaryEraToCardanoEra = shelleyBasedToCardanoEra . shelleyToMaryEraToShelleyBasedEra - shelleyToMaryEraToShelleyBasedEra :: ShelleyToMaryEra era -> ShelleyBasedEra era shelleyToMaryEraToShelleyBasedEra = \case ShelleyToMaryEraShelley -> ShelleyBasedEraShelley diff --git a/cardano-api/internal/Cardano/Api/Feature.hs b/cardano-api/internal/Cardano/Api/Feature.hs index 7333e56e7c..ff909c0000 100644 --- a/cardano-api/internal/Cardano/Api/Feature.hs +++ b/cardano-api/internal/Cardano/Api/Feature.hs @@ -48,4 +48,4 @@ asFeaturedInShelleyBasedEra :: () => a -> ShelleyBasedEra era -> Maybe (Featured eon era a) -asFeaturedInShelleyBasedEra value = asFeaturedInEra value . shelleyBasedToCardanoEra +asFeaturedInShelleyBasedEra value = asFeaturedInEra value . toCardanoEra diff --git a/cardano-api/internal/Cardano/Api/Fees.hs b/cardano-api/internal/Cardano/Api/Fees.hs index e02e0cbdd0..c98457db4d 100644 --- a/cardano-api/internal/Cardano/Api/Fees.hs +++ b/cardano-api/internal/Cardano/Api/Fees.hs @@ -328,7 +328,7 @@ evaluateTransactionFee :: forall era. () -> L.Coin evaluateTransactionFee sbe pp txbody keywitcount byronwitcount refScriptsSize = shelleyBasedEraConstraints sbe $ - case makeSignedTransaction' (shelleyBasedToCardanoEra sbe) [] txbody of + case makeSignedTransaction' (toCardanoEra sbe) [] txbody of ShelleyTx _ tx -> L.estimateMinFeeTx pp tx (fromIntegral keywitcount) (fromIntegral byronwitcount) refScriptsSize @@ -353,7 +353,7 @@ calculateMinTxFee :: forall era. () -> L.Coin calculateMinTxFee sbe pp utxo txbody keywitcount = shelleyBasedEraConstraints sbe $ - case makeSignedTransaction' (shelleyBasedToCardanoEra sbe) [] txbody of + case makeSignedTransaction' (toCardanoEra sbe) [] txbody of ShelleyTx _ tx -> L.calcMinFeeTx (toLedgerUTxO sbe utxo) pp tx (fromIntegral keywitcount) @@ -1102,7 +1102,7 @@ makeTransactionBodyAutoBalance sbe systemstart history lpp@(LedgerProtocolParame return (BalancedTxBody finalTxBodyContent txbody3 (TxOut changeaddr balance TxOutDatumNone ReferenceScriptNone) fee) where era :: CardanoEra era - era = shelleyBasedToCardanoEra sbe + era = toCardanoEra sbe -- | In the event of spending the exact amount of lovelace in -- the specified input(s), this function excludes the change diff --git a/cardano-api/internal/Cardano/Api/IPC.hs b/cardano-api/internal/Cardano/Api/IPC.hs index 537f8f8e71..258769290c 100644 --- a/cardano-api/internal/Cardano/Api/IPC.hs +++ b/cardano-api/internal/Cardano/Api/IPC.hs @@ -82,6 +82,7 @@ import Cardano.Api.InMode import Cardano.Api.IO import Cardano.Api.IPC.Version import Cardano.Api.Modes +import Cardano.Api.Monad.Error (ExceptT (..)) import Cardano.Api.NetworkId import Cardano.Api.Protocol import Cardano.Api.Query @@ -124,6 +125,7 @@ import qualified Ouroboros.Network.Protocol.LocalTxSubmission.Client as Net.Tx import Control.Concurrent.STM (TMVar, atomically, newEmptyTMVarIO, putTMVar, takeTMVar, tryPutTMVar) import Control.Monad (void) +import Control.Monad.IO.Class import Control.Tracer (nullTracer) import Data.Aeson (ToJSON, object, toJSON, (.=)) import qualified Data.ByteString.Lazy as LBS @@ -181,10 +183,11 @@ data LocalNodeConnectInfo = -- | Establish a connection to a local node and execute the given set of -- protocol handlers. -- -connectToLocalNode :: () +connectToLocalNode + :: MonadIO m => LocalNodeConnectInfo -> LocalNodeClientProtocolsInMode - -> IO () + -> m () connectToLocalNode localNodeConnectInfo handlers = connectToLocalNodeWithVersion localNodeConnectInfo (const handlers) @@ -192,16 +195,17 @@ connectToLocalNode localNodeConnectInfo handlers -- protocol handlers parameterized on the negotiated node-to-client protocol -- version. -- -connectToLocalNodeWithVersion :: () +connectToLocalNodeWithVersion + :: MonadIO m => LocalNodeConnectInfo -> (NodeToClientVersion -> LocalNodeClientProtocolsInMode) - -> IO () + -> m () connectToLocalNodeWithVersion LocalNodeConnectInfo { localNodeSocketPath, localNodeNetworkId, localConsensusModeParams } clients = - Net.withIOManager $ \iomgr -> + liftIO $ Net.withIOManager $ \iomgr -> Net.connectTo (Net.localSnocket iomgr) Net.NetworkConnectTracers { @@ -534,9 +538,9 @@ queryNodeLocalState :: forall result. () => LocalNodeConnectInfo -> Net.Query.Target ChainPoint -> QueryInMode result - -> IO (Either AcquiringFailure result) + -> ExceptT AcquiringFailure IO result queryNodeLocalState connctInfo mpoint query = do - resultVar <- newEmptyTMVarIO + resultVar <- liftIO newEmptyTMVarIO connectToLocalNode connctInfo LocalNodeClientProtocols { @@ -545,7 +549,7 @@ queryNodeLocalState connctInfo mpoint query = do localTxSubmissionClient = Nothing, localTxMonitoringClient = Nothing } - atomically (takeTMVar resultVar) + ExceptT $ atomically (takeTMVar resultVar) where singleQuery :: Net.Query.Target ChainPoint @@ -570,12 +574,13 @@ queryNodeLocalState connctInfo mpoint query = do pure $ Net.Query.SendMsgDone () } -submitTxToNodeLocal :: () +submitTxToNodeLocal + :: MonadIO m => LocalNodeConnectInfo -> TxInMode - -> IO (Net.Tx.SubmitResult TxValidationErrorInCardanoMode) + -> m (Net.Tx.SubmitResult TxValidationErrorInCardanoMode) submitTxToNodeLocal connctInfo tx = do - resultVar <- newEmptyTMVarIO + resultVar <- liftIO newEmptyTMVarIO connectToLocalNode connctInfo LocalNodeClientProtocols { @@ -584,7 +589,7 @@ submitTxToNodeLocal connctInfo tx = do localStateQueryClient = Nothing, localTxMonitoringClient = Nothing } - atomically (takeTMVar resultVar) + liftIO $ atomically (takeTMVar resultVar) where localTxSubmissionClientSingle :: () => TMVar (Net.Tx.SubmitResult TxValidationErrorInCardanoMode) @@ -654,12 +659,13 @@ data LocalTxMonitoringQuery | LocalTxMonitoringMempoolInformation -queryTxMonitoringLocal :: () +queryTxMonitoringLocal + :: MonadIO m => LocalNodeConnectInfo -> LocalTxMonitoringQuery - -> IO LocalTxMonitoringResult + -> m LocalTxMonitoringResult queryTxMonitoringLocal connectInfo localTxMonitoringQuery = do - resultVar <- newEmptyTMVarIO + resultVar <- liftIO newEmptyTMVarIO let client = case localTxMonitoringQuery of LocalTxMonitoringQueryTx txidInMode -> @@ -677,7 +683,7 @@ queryTxMonitoringLocal connectInfo localTxMonitoringQuery = do localStateQueryClient = Nothing, localTxMonitoringClient = Just client } - atomically (takeTMVar resultVar) + liftIO $ atomically (takeTMVar resultVar) where localTxMonitorClientTxExists :: () => TxIdInMode @@ -716,11 +722,12 @@ queryTxMonitoringLocal connectInfo localTxMonitoringQuery = do -- Get tip as 'ChainPoint' -- -getLocalChainTip :: () +getLocalChainTip + :: MonadIO m => LocalNodeConnectInfo - -> IO ChainTip + -> m ChainTip getLocalChainTip localNodeConInfo = do - resultVar <- newEmptyTMVarIO + resultVar <- liftIO newEmptyTMVarIO connectToLocalNode localNodeConInfo LocalNodeClientProtocols @@ -729,7 +736,7 @@ getLocalChainTip localNodeConInfo = do , localStateQueryClient = Nothing , localTxMonitoringClient = Nothing } - atomically $ takeTMVar resultVar + liftIO . atomically $ takeTMVar resultVar chainSyncGetCurrentTip :: () => TMVar ChainTip diff --git a/cardano-api/internal/Cardano/Api/Monad/Error.hs b/cardano-api/internal/Cardano/Api/Monad/Error.hs index 2cb37486c1..919b941b65 100644 --- a/cardano-api/internal/Cardano/Api/Monad/Error.hs +++ b/cardano-api/internal/Cardano/Api/Monad/Error.hs @@ -14,6 +14,7 @@ module Cardano.Api.Monad.Error , handleIOExceptionsWith , handleIOExceptionsLiftWith , hoistIOEither + , liftMaybe , module Control.Monad.Except , module Control.Monad.IO.Class @@ -87,3 +88,10 @@ hoistIOEither :: MonadIOTransError e t m => IO (Either e a) -> t m a hoistIOEither = liftExceptT . ExceptT . liftIO + +-- | Lift 'Maybe' into 'MonadError' +liftMaybe :: MonadError e m + => e -- ^ Error to throw, if 'Nothing' + -> Maybe a + -> m a +liftMaybe e = maybe (throwError e) pure diff --git a/cardano-api/internal/Cardano/Api/ProtocolParameters.hs b/cardano-api/internal/Cardano/Api/ProtocolParameters.hs index d36a7ca2d3..85cfe85e7f 100644 --- a/cardano-api/internal/Cardano/Api/ProtocolParameters.hs +++ b/cardano-api/internal/Cardano/Api/ProtocolParameters.hs @@ -1786,7 +1786,7 @@ checkProtocolParameters sbe ProtocolParameters{..} = ShelleyBasedEraBabbage -> checkBabbageParams ShelleyBasedEraConway -> checkBabbageParams where - era = shelleyBasedToCardanoEra sbe + era = toCardanoEra sbe cModel = not $ Map.null protocolParamCostModels prices = isJust protocolParamPrices diff --git a/cardano-api/internal/Cardano/Api/Query.hs b/cardano-api/internal/Cardano/Api/Query.hs index b9fccd0065..58c6167079 100644 --- a/cardano-api/internal/Cardano/Api/Query.hs +++ b/cardano-api/internal/Cardano/Api/Query.hs @@ -715,7 +715,7 @@ toConsensusQueryShelleyBased sbe = \case creds' = Set.map toShelleyStakeCredential creds where - era = shelleyBasedToCardanoEra sbe + era = toCardanoEra sbe consensusQueryInEraInMode :: forall era erablock modeblock result result' xs. diff --git a/cardano-api/internal/Cardano/Api/Tx/Body.hs b/cardano-api/internal/Cardano/Api/Tx/Body.hs index d6c2492326..4132336c42 100644 --- a/cardano-api/internal/Cardano/Api/Tx/Body.hs +++ b/cardano-api/internal/Cardano/Api/Tx/Body.hs @@ -1412,7 +1412,7 @@ createTransactionBody :: () -> Either TxBodyError (TxBody era) createTransactionBody sbe bc = shelleyBasedEraConstraints sbe $ do - let era = shelleyBasedToCardanoEra sbe + let era = toCardanoEra sbe apiTxOuts = txOuts bc apiScriptWitnesses = collectTxBodyScriptWitnesses sbe bc apiScriptValidity = txScriptValidity bc @@ -1587,7 +1587,7 @@ validateTxInsCollateral txInsCollateral languages = validateTxOuts :: ShelleyBasedEra era -> [TxOut CtxTx era] -> Either TxBodyError () validateTxOuts sbe txOuts = do - let era = shelleyBasedToCardanoEra sbe + let era = toCardanoEra sbe cardanoEraConstraints era $ sequence_ [ do diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs index c65781ef80..f32e492ad9 100644 --- a/cardano-api/src/Cardano/Api.hs +++ b/cardano-api/src/Cardano/Api.hs @@ -60,33 +60,27 @@ module Cardano.Api ( ByronToAlonzoEra(..), byronToAlonzoEraConstraints, - byronToAlonzoEraToCardanoEra, -- ** From Shelley ShelleyEraOnly(..), shelleyEraOnlyConstraints, - shelleyEraOnlyToCardanoEra, shelleyEraOnlyToShelleyBasedEra, ShelleyToAllegraEra(..), shelleyToAllegraEraConstraints, - shelleyToAllegraEraToCardanoEra, shelleyToAllegraEraToShelleyBasedEra, ShelleyToMaryEra(..), shelleyToMaryEraConstraints, - shelleyToMaryEraToCardanoEra, shelleyToMaryEraToShelleyBasedEra, ShelleyToAlonzoEra(..), shelleyToAlonzoEraConstraints, - shelleyToAlonzoEraToCardanoEra, shelleyToAlonzoEraToShelleyBasedEra, ShelleyToBabbageEra(..), shelleyToBabbageEraConstraints, - shelleyToBabbageEraToCardanoEra, shelleyToBabbageEraToShelleyBasedEra, ShelleyBasedEra(..), @@ -94,7 +88,6 @@ module Cardano.Api ( AnyShelleyBasedEra(..), InAnyShelleyBasedEra(..), inAnyShelleyBasedEra, - shelleyBasedToCardanoEra, shelleyBasedEraConstraints, -- ** From Allegra @@ -103,28 +96,24 @@ module Cardano.Api ( -- ** From Mary MaryEraOnwards(..), maryEraOnwardsConstraints, - maryEraOnwardsToCardanoEra, maryEraOnwardsToShelleyBasedEra, -- ** From Alonzo AlonzoEraOnwards(..), alonzoEraOnwardsConstraints, - alonzoEraOnwardsToCardanoEra, alonzoEraOnwardsToShelleyBasedEra, -- ** From Babbage BabbageEraOnwards(..), babbageEraOnwardsConstraints, - babbageEraOnwardsToCardanoEra, babbageEraOnwardsToShelleyBasedEra, -- ** From Conway ConwayEraOnwards(..), conwayEraOnwardsConstraints, - conwayEraOnwardsToCardanoEra, conwayEraOnwardsToShelleyBasedEra, -- * Era case handling diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Eras.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Eras.hs index 162979a003..f12610a875 100644 --- a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Eras.hs +++ b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Eras.hs @@ -23,7 +23,7 @@ prop_maxBound_CardanoMatchesShelley = property $ do AnyCardanoEra era <- forAll $ Gen.element [maxBound] AnyShelleyBasedEra sbe <- forAll $ Gen.element [maxBound] - fromEnum (anyCardanoEra era) === fromEnum (anyCardanoEra (shelleyBasedToCardanoEra sbe)) + fromEnum (anyCardanoEra era) === fromEnum (anyCardanoEra (toCardanoEra sbe)) -------------------------------------------------------------------------------- -- Aeson instances @@ -44,7 +44,7 @@ prop_toJSON_CardanoMatchesShelley :: Property prop_toJSON_CardanoMatchesShelley = property $ do AnyShelleyBasedEra sbe <- forAll $ Gen.element [minBound..maxBound] - toJSON (AnyShelleyBasedEra sbe) === toJSON (anyCardanoEra (shelleyBasedToCardanoEra sbe)) + toJSON (AnyShelleyBasedEra sbe) === toJSON (anyCardanoEra (toCardanoEra sbe)) tests :: TestTree tests = testGroup "Test.Cardano.Api.Json"