From c936d54a4834d4e7d757e42ef290d633e03ef318 Mon Sep 17 00:00:00 2001 From: John Ky Date: Wed, 25 Oct 2023 21:15:23 +1100 Subject: [PATCH 01/37] Delete ShelleyMode --- cardano-api/internal/Cardano/Api/Block.hs | 51 ++++--------------- .../internal/Cardano/Api/Convenience/Query.hs | 1 - cardano-api/internal/Cardano/Api/IPC.hs | 7 --- cardano-api/internal/Cardano/Api/InMode.hs | 26 ---------- cardano-api/internal/Cardano/Api/Modes.hs | 40 --------------- cardano-api/internal/Cardano/Api/Query.hs | 11 ---- .../internal/Cardano/Api/Query/Expr.hs | 1 - cardano-api/src/Cardano/Api/Shelley.hs | 2 - .../cardano-api-test/Test/Cardano/Api/Json.hs | 2 - 9 files changed, 10 insertions(+), 131 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/Block.hs b/cardano-api/internal/Cardano/Api/Block.hs index 3b923c1741..4ab4863ef6 100644 --- a/cardano-api/internal/Cardano/Api/Block.hs +++ b/cardano-api/internal/Cardano/Api/Block.hs @@ -76,11 +76,8 @@ import qualified Ouroboros.Consensus.Cardano.Block as Consensus import qualified Ouroboros.Consensus.Cardano.ByronHFC as Consensus import qualified Ouroboros.Consensus.HardFork.Combinator as Consensus import qualified Ouroboros.Consensus.HardFork.Combinator.Degenerate as Consensus -import qualified Ouroboros.Consensus.Ledger.SupportsProtocol as Consensus -import qualified Ouroboros.Consensus.Protocol.TPraos as Consensus import qualified Ouroboros.Consensus.Shelley.Ledger as Consensus import qualified Ouroboros.Consensus.Shelley.Protocol.Abstract as Consensus -import qualified Ouroboros.Consensus.Shelley.ShelleyHFC as Consensus import qualified Ouroboros.Network.Block as Consensus import Data.Aeson (FromJSON (..), ToJSON (..), Value (..), object, withObject, (.:), (.=)) @@ -208,25 +205,16 @@ data BlockInMode mode where deriving instance Show (BlockInMode mode) -fromConsensusBlock :: ConsensusBlockForMode mode ~ block - => Consensus.LedgerSupportsProtocol - (Consensus.ShelleyBlock - (Consensus.TPraos Consensus.StandardCrypto) - (Consensus.ShelleyEra Consensus.StandardCrypto)) - => ConsensusMode mode -> block -> BlockInMode mode -fromConsensusBlock ByronMode = - \b -> case b of +fromConsensusBlock :: () + => ConsensusBlockForMode mode ~ block + => ConsensusMode mode + -> block + -> BlockInMode mode +fromConsensusBlock ByronMode = \case Consensus.DegenBlock b' -> BlockInMode cardanoEra (ByronBlock b') ByronEraInByronMode -fromConsensusBlock ShelleyMode = - \b -> case b of - Consensus.DegenBlock b' -> - BlockInMode cardanoEra (ShelleyBlock ShelleyBasedEraShelley b') - ShelleyEraInShelleyMode - -fromConsensusBlock CardanoMode = - \b -> case b of +fromConsensusBlock CardanoMode = \case Consensus.BlockByron b' -> BlockInMode cardanoEra (ByronBlock b') ByronEraInCardanoMode @@ -254,21 +242,13 @@ fromConsensusBlock CardanoMode = BlockInMode cardanoEra (ShelleyBlock ShelleyBasedEraConway b') ConwayEraInCardanoMode -toConsensusBlock - :: ConsensusBlockForMode mode ~ block - => Consensus.LedgerSupportsProtocol - (Consensus.ShelleyBlock - (Consensus.TPraos Consensus.StandardCrypto) - (Consensus.ShelleyEra Consensus.StandardCrypto)) +toConsensusBlock :: () + => ConsensusBlockForMode mode ~ block => BlockInMode mode -> block -toConsensusBlock bInMode = - case bInMode of +toConsensusBlock = \case -- Byron mode BlockInMode _ (ByronBlock b') ByronEraInByronMode -> Consensus.DegenBlock b' - -- Shelley mode - BlockInMode _ (ShelleyBlock ShelleyBasedEraShelley b') ShelleyEraInShelleyMode -> Consensus.DegenBlock b' - -- Cardano mode BlockInMode _ (ByronBlock b') ByronEraInCardanoMode -> Consensus.BlockByron b' BlockInMode _ (ShelleyBlock ShelleyBasedEraShelley b') ShelleyEraInCardanoMode -> Consensus.BlockShelley b' @@ -372,14 +352,12 @@ toConsensusPointInMode :: ConsensusMode mode -- individually for each case that we satisfy the type equality constraint -- HeaderHash block ~ OneEraHash xs toConsensusPointInMode ByronMode = toConsensusPointHF -toConsensusPointInMode ShelleyMode = toConsensusPointHF toConsensusPointInMode CardanoMode = toConsensusPointHF fromConsensusPointInMode :: ConsensusMode mode -> Consensus.Point (ConsensusBlockForMode mode) -> ChainPoint fromConsensusPointInMode ByronMode = fromConsensusPointHF -fromConsensusPointInMode ShelleyMode = fromConsensusPointHF fromConsensusPointInMode CardanoMode = fromConsensusPointHF @@ -477,14 +455,6 @@ fromConsensusTip ByronMode = conv conv (Consensus.Tip slot (Consensus.OneEraHash h) block) = ChainTip slot (HeaderHash h) block -fromConsensusTip ShelleyMode = conv - where - conv :: Consensus.Tip (Consensus.ShelleyBlockHFC (Consensus.TPraos Consensus.StandardCrypto) Consensus.StandardShelley) - -> ChainTip - conv Consensus.TipGenesis = ChainTipAtGenesis - conv (Consensus.Tip slot (Consensus.OneEraHash hashSBS) block) = - ChainTip slot (HeaderHash hashSBS) block - fromConsensusTip CardanoMode = conv where conv :: Consensus.Tip (Consensus.CardanoBlock Consensus.StandardCrypto) @@ -504,7 +474,6 @@ TODO: In principle we should be able to use this common implementation rather fromConsensusTip = \mode -> case mode of ByronMode -> conv - ShelleyMode -> conv CardanoMode -> conv where conv :: HeaderHash block ~ OneEraHash xs diff --git a/cardano-api/internal/Cardano/Api/Convenience/Query.hs b/cardano-api/internal/Cardano/Api/Convenience/Query.hs index d77f122930..de3889e7ec 100644 --- a/cardano-api/internal/Cardano/Api/Convenience/Query.hs +++ b/cardano-api/internal/Cardano/Api/Convenience/Query.hs @@ -142,7 +142,6 @@ determineEra determineEra cModeParams localNodeConnInfo = case consensusModeOnly cModeParams of ByronMode -> return . Right $ AnyCardanoEra ByronEra - ShelleyMode -> return . Right $ AnyCardanoEra ShelleyEra CardanoMode -> queryNodeLocalState localNodeConnInfo Nothing $ QueryCurrentEra CardanoModeIsMultiEra diff --git a/cardano-api/internal/Cardano/Api/IPC.hs b/cardano-api/internal/Cardano/Api/IPC.hs index 78027acc76..cfa113678e 100644 --- a/cardano-api/internal/Cardano/Api/IPC.hs +++ b/cardano-api/internal/Cardano/Api/IPC.hs @@ -30,7 +30,6 @@ module Cardano.Api.IPC ( -- ** Modes -- | TODO move to Cardano.Api ByronMode, - ShelleyMode, CardanoMode, ConsensusModeParams(..), EpochSlots(..), @@ -193,7 +192,6 @@ localConsensusMode LocalNodeConnectInfo {localConsensusModeParams} = consensusModeOnly :: ConsensusModeParams mode -> ConsensusMode mode consensusModeOnly ByronModeParams{} = ByronMode -consensusModeOnly ShelleyModeParams{} = ShelleyMode consensusModeOnly CardanoModeParams{} = CardanoMode @@ -422,11 +420,6 @@ mkLocalNodeClientParams modeparams clients = (ProtocolClientInfoArgsByron epochSlots) (convLocalNodeClientProtocols ByronMode . clients) - ShelleyModeParams -> - LocalNodeClientParamsSingleBlock - ProtocolClientInfoArgsShelley - (convLocalNodeClientProtocols ShelleyMode . clients) - CardanoModeParams epochSlots -> LocalNodeClientParamsCardano (ProtocolClientInfoArgsCardano epochSlots) diff --git a/cardano-api/internal/Cardano/Api/InMode.hs b/cardano-api/internal/Cardano/Api/InMode.hs index e1a2a38433..5b4b1d0696 100644 --- a/cardano-api/internal/Cardano/Api/InMode.hs +++ b/cardano-api/internal/Cardano/Api/InMode.hs @@ -38,8 +38,6 @@ import qualified Ouroboros.Consensus.HardFork.Combinator as Consensus import Ouroboros.Consensus.HardFork.Combinator.AcrossEras (EraMismatch) import qualified Ouroboros.Consensus.HardFork.Combinator.Degenerate as Consensus import qualified Ouroboros.Consensus.Ledger.SupportsMempool as Consensus -import qualified Ouroboros.Consensus.Ledger.SupportsProtocol as Consensus -import qualified Ouroboros.Consensus.Protocol.TPraos as TPraos import qualified Ouroboros.Consensus.Shelley.HFEras as Consensus import qualified Ouroboros.Consensus.Shelley.Ledger as Consensus import qualified Ouroboros.Consensus.TypeFamilyWrappers as Consensus @@ -78,10 +76,6 @@ fromConsensusGenTx fromConsensusGenTx ByronMode (Consensus.HardForkGenTx (Consensus.OneEraGenTx (Z tx'))) = TxInByronSpecial tx' ByronEraInByronMode -fromConsensusGenTx ShelleyMode (Consensus.HardForkGenTx (Consensus.OneEraGenTx (Z tx'))) = - let Consensus.ShelleyTx _txid shelleyEraTx = tx' - in TxInMode (ShelleyTx ShelleyBasedEraShelley shelleyEraTx) ShelleyEraInShelleyMode - fromConsensusGenTx CardanoMode (Consensus.HardForkGenTx (Consensus.OneEraGenTx (Z tx'))) = TxInByronSpecial tx' ByronEraInCardanoMode @@ -130,11 +124,6 @@ toConsensusGenTx (TxInByronSpecial gtx ByronEraInByronMode) = toConsensusGenTx (TxInByronSpecial gtx ByronEraInCardanoMode) = Consensus.HardForkGenTx (Consensus.OneEraGenTx (Z gtx)) -toConsensusGenTx (TxInMode (ShelleyTx _ tx) ShelleyEraInShelleyMode) = - Consensus.HardForkGenTx (Consensus.OneEraGenTx (Z tx')) - where - tx' = Consensus.mkShelleyTx tx - toConsensusGenTx (TxInMode (ShelleyTx _ tx) ShelleyEraInCardanoMode) = Consensus.HardForkGenTx (Consensus.OneEraGenTx (S (Z tx'))) where @@ -193,12 +182,6 @@ toConsensusTxId (TxIdInMode txid ByronEraInByronMode) = txid' :: Consensus.TxId (Consensus.GenTx Consensus.ByronBlock) txid' = Consensus.ByronTxId $ toByronTxId txid -toConsensusTxId (TxIdInMode t ShelleyEraInShelleyMode) = - Consensus.HardForkGenTxId $ Consensus.OneEraGenTxId $ Z (Consensus.WrapGenTxId txid') - where - txid' :: Consensus.TxId (Consensus.GenTx Consensus.StandardShelleyBlock) - txid' = Consensus.ShelleyTxId $ toShelleyTxId t - toConsensusTxId (TxIdInMode txid ByronEraInCardanoMode) = Consensus.HardForkGenTxId . Consensus.OneEraGenTxId . Z $ Consensus.WrapGenTxId txid' where @@ -320,10 +303,6 @@ deriving instance Show (TxValidationErrorInMode mode) fromConsensusApplyTxErr :: ConsensusBlockForMode mode ~ block - => Consensus.LedgerSupportsProtocol - (Consensus.ShelleyBlock - (TPraos.TPraos Consensus.StandardCrypto) - (Consensus.ShelleyEra Consensus.StandardCrypto)) => ConsensusMode mode -> Consensus.ApplyTxErr block -> TxValidationErrorInMode mode @@ -332,11 +311,6 @@ fromConsensusApplyTxErr ByronMode (Consensus.DegenApplyTxErr err) = (ByronTxValidationError err) ByronEraInByronMode -fromConsensusApplyTxErr ShelleyMode (Consensus.DegenApplyTxErr err) = - TxValidationErrorInMode - (ShelleyTxValidationError ShelleyBasedEraShelley err) - ShelleyEraInShelleyMode - fromConsensusApplyTxErr CardanoMode (Consensus.ApplyTxErrByron err) = TxValidationErrorInMode (ByronTxValidationError err) diff --git a/cardano-api/internal/Cardano/Api/Modes.hs b/cardano-api/internal/Cardano/Api/Modes.hs index c18554320f..5626ef3d82 100644 --- a/cardano-api/internal/Cardano/Api/Modes.hs +++ b/cardano-api/internal/Cardano/Api/Modes.hs @@ -2,7 +2,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} @@ -15,7 +14,6 @@ module Cardano.Api.Modes ( -- * Consensus modes ByronMode, - ShelleyMode, CardanoMode, ConsensusMode(..), AnyConsensusMode(..), @@ -79,16 +77,6 @@ import Data.Text (Text) -- data ByronMode --- | The Shelley-only consensus mode consists of only the Shelley era. --- --- This was used for the early Shelley testnets prior to the use of the --- multi-era 'CardanoMode'. It is useful for setting up Shelley test networks --- (e.g. for benchmarking) without having to go through the complication of the --- hard fork from Byron to Shelley eras. It also shows how a single-era --- consensus mode works. It may be replaced by other single-era modes in future. --- -data ShelleyMode - -- | The Cardano consensus mode consists of all the eras currently in use on -- the Cardano mainnet. This is currently: the 'ByronEra'; 'ShelleyEra', -- 'AllegraEra' and 'MaryEra', in that order. @@ -108,7 +96,6 @@ deriving instance Show AnyConsensusModeParams -- data ConsensusMode mode where ByronMode :: ConsensusMode ByronMode - ShelleyMode :: ConsensusMode ShelleyMode CardanoMode :: ConsensusMode CardanoMode @@ -121,7 +108,6 @@ deriving instance Show AnyConsensusMode renderMode :: AnyConsensusMode -> Text renderMode (AnyConsensusMode ByronMode) = "ByronMode" -renderMode (AnyConsensusMode ShelleyMode) = "ShelleyMode" renderMode (AnyConsensusMode CardanoMode) = "CardanoMode" -- | The subset of consensus modes that consist of multiple eras. Some features @@ -136,8 +122,6 @@ deriving instance Show (ConsensusModeIsMultiEra mode) toEraInMode :: CardanoEra era -> ConsensusMode mode -> Maybe (EraInMode era mode) toEraInMode ByronEra ByronMode = Just ByronEraInByronMode toEraInMode _ ByronMode = Nothing -toEraInMode ShelleyEra ShelleyMode = Just ShelleyEraInShelleyMode -toEraInMode _ ShelleyMode = Nothing toEraInMode ByronEra CardanoMode = Just ByronEraInCardanoMode toEraInMode ShelleyEra CardanoMode = Just ShelleyEraInCardanoMode toEraInMode AllegraEra CardanoMode = Just AllegraEraInCardanoMode @@ -152,8 +136,6 @@ toEraInMode ConwayEra CardanoMode = Just ConwayEraInCardanoMode data EraInMode era mode where ByronEraInByronMode :: EraInMode ByronEra ByronMode - ShelleyEraInShelleyMode :: EraInMode ShelleyEra ShelleyMode - ByronEraInCardanoMode :: EraInMode ByronEra CardanoMode ShelleyEraInCardanoMode :: EraInMode ShelleyEra CardanoMode AllegraEraInCardanoMode :: EraInMode AllegraEra CardanoMode @@ -173,13 +155,6 @@ instance FromJSON (EraInMode ByronEra ByronMode) where "parsing 'EraInMode ByronEra ByronMode' failed, " invalid -instance FromJSON (EraInMode ShelleyEra ShelleyMode) where - parseJSON "ShelleyEraInShelleyMode" = pure ShelleyEraInShelleyMode - parseJSON invalid = - invalidJSONFailure "ShelleyEraInShelleyMode" - "parsing 'EraInMode ShelleyEra ShelleyMode' failed, " - invalid - instance FromJSON (EraInMode ByronEra CardanoMode) where parseJSON "ByronEraInCardanoMode" = pure ByronEraInCardanoMode parseJSON invalid = @@ -236,7 +211,6 @@ invalidJSONFailure expectedType errorMsg invalidValue = instance ToJSON (EraInMode era mode) where toJSON ByronEraInByronMode = "ByronEraInByronMode" - toJSON ShelleyEraInShelleyMode = "ShelleyEraInShelleyMode" toJSON ByronEraInCardanoMode = "ByronEraInCardanoMode" toJSON ShelleyEraInCardanoMode = "ShelleyEraInCardanoMode" toJSON AllegraEraInCardanoMode = "AllegraEraInCardanoMode" @@ -247,7 +221,6 @@ instance ToJSON (EraInMode era mode) where eraInModeToEra :: EraInMode era mode -> CardanoEra era eraInModeToEra ByronEraInByronMode = ByronEra -eraInModeToEra ShelleyEraInShelleyMode = ShelleyEra eraInModeToEra ByronEraInCardanoMode = ByronEra eraInModeToEra ShelleyEraInCardanoMode = ShelleyEra eraInModeToEra AllegraEraInCardanoMode = AllegraEra @@ -267,7 +240,6 @@ anyEraInModeToAnyEra :: AnyEraInMode mode -> AnyCardanoEra anyEraInModeToAnyEra (AnyEraInMode erainmode) = case erainmode of ByronEraInByronMode -> AnyCardanoEra ByronEra - ShelleyEraInShelleyMode -> AnyCardanoEra ShelleyEra ByronEraInCardanoMode -> AnyCardanoEra ByronEra ShelleyEraInCardanoMode -> AnyCardanoEra ShelleyEra AllegraEraInCardanoMode -> AnyCardanoEra AllegraEra @@ -295,9 +267,6 @@ data ConsensusModeParams mode where :: Byron.EpochSlots -> ConsensusModeParams ByronMode - ShelleyModeParams - :: ConsensusModeParams ShelleyMode - CardanoModeParams :: Byron.EpochSlots -> ConsensusModeParams CardanoMode @@ -313,7 +282,6 @@ deriving instance Show (ConsensusModeParams mode) -- type family ConsensusBlockForMode mode where ConsensusBlockForMode ByronMode = Consensus.ByronBlockHFC - ConsensusBlockForMode ShelleyMode = Consensus.ShelleyBlockHFC (Consensus.TPraos StandardCrypto) Consensus.StandardShelley ConsensusBlockForMode CardanoMode = Consensus.CardanoBlock StandardCrypto type family ConsensusBlockForEra era where @@ -371,7 +339,6 @@ toConsensusEraIndex :: ConsensusBlockForMode mode ~ Consensus.HardForkBlock xs => EraInMode era mode -> Consensus.EraIndex xs toConsensusEraIndex ByronEraInByronMode = eraIndex0 -toConsensusEraIndex ShelleyEraInShelleyMode = eraIndex0 toConsensusEraIndex ByronEraInCardanoMode = eraIndex0 toConsensusEraIndex ShelleyEraInCardanoMode = eraIndex1 @@ -393,13 +360,6 @@ fromConsensusEraIndex ByronMode = fromByronEraIndex -> AnyEraInMode ByronMode fromByronEraIndex (Consensus.EraIndex (Z (K ()))) = AnyEraInMode ByronEraInByronMode -fromConsensusEraIndex ShelleyMode = fromShelleyEraIndex - where - fromShelleyEraIndex :: Consensus.EraIndex - '[Consensus.StandardShelleyBlock] - -> AnyEraInMode ShelleyMode - fromShelleyEraIndex (Consensus.EraIndex (Z (K ()))) = - AnyEraInMode ShelleyEraInShelleyMode fromConsensusEraIndex CardanoMode = fromShelleyEraIndex diff --git a/cardano-api/internal/Cardano/Api/Query.hs b/cardano-api/internal/Cardano/Api/Query.hs index d2a8702bb0..df52e142af 100644 --- a/cardano-api/internal/Cardano/Api/Query.hs +++ b/cardano-api/internal/Cardano/Api/Query.hs @@ -580,7 +580,6 @@ toConsensusQuery (QueryInEra ByronEraInCardanoMode QueryByronUpdateState) = toConsensusQuery (QueryInEra erainmode (QueryInShelleyBasedEra sbe q)) = case erainmode of ByronEraInByronMode -> case sbe of {} - ShelleyEraInShelleyMode -> toConsensusQueryShelleyBased erainmode q ByronEraInCardanoMode -> case sbe of {} ShelleyEraInCardanoMode -> toConsensusQueryShelleyBased erainmode q AllegraEraInCardanoMode -> toConsensusQueryShelleyBased erainmode q @@ -700,7 +699,6 @@ consensusQueryInEraInMode erainmode = Consensus.BlockQuery . case erainmode of ByronEraInByronMode -> Consensus.DegenQuery - ShelleyEraInShelleyMode -> Consensus.DegenQuery ByronEraInCardanoMode -> Consensus.QueryIfCurrentByron ShelleyEraInCardanoMode -> Consensus.QueryIfCurrentShelley AllegraEraInCardanoMode -> Consensus.QueryIfCurrentAllegra @@ -770,15 +768,6 @@ fromConsensusQueryResult (QueryInEra ByronEraInByronMode (QueryInShelleyBasedEra sbe _)) _ _ = case sbe of {} -fromConsensusQueryResult (QueryInEra ShelleyEraInShelleyMode - (QueryInShelleyBasedEra _sbe q)) q' r' = - case (q', r') of - (Consensus.BlockQuery (Consensus.DegenQuery q''), - Consensus.DegenQueryResult r'') - -> Right (fromConsensusQueryResultShelleyBased - ShelleyBasedEraShelley q q'' r'') - _ -> fromConsensusQueryResultMismatch - fromConsensusQueryResult (QueryInEra ByronEraInCardanoMode (QueryInShelleyBasedEra sbe _)) _ _ = case sbe of {} diff --git a/cardano-api/internal/Cardano/Api/Query/Expr.hs b/cardano-api/internal/Cardano/Api/Query/Expr.hs index e5104f29e4..0e537be1f0 100644 --- a/cardano-api/internal/Cardano/Api/Query/Expr.hs +++ b/cardano-api/internal/Cardano/Api/Query/Expr.hs @@ -227,7 +227,6 @@ determineEraExpr :: () determineEraExpr cModeParams = runExceptT $ case consensusModeOnly cModeParams of ByronMode -> pure $ AnyCardanoEra ByronEra - ShelleyMode -> pure $ AnyCardanoEra ShelleyEra CardanoMode -> ExceptT queryCurrentEra queryConstitution :: () diff --git a/cardano-api/src/Cardano/Api/Shelley.hs b/cardano-api/src/Cardano/Api/Shelley.hs index e2ffc024aa..4ad2623f2b 100644 --- a/cardano-api/src/Cardano/Api/Shelley.hs +++ b/cardano-api/src/Cardano/Api/Shelley.hs @@ -214,10 +214,8 @@ module Cardano.Api.Shelley -- ** Low level protocol interaction with a Cardano node LocalNodeConnectInfo(LocalNodeConnectInfo), - ShelleyMode, ConsensusMode ( ByronMode - , ShelleyMode ), LocalNodeClientProtocols(LocalNodeClientProtocols), diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Json.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Json.hs index 6f3e3ff4b9..e6c16a8279 100644 --- a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Json.hs +++ b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Json.hs @@ -55,7 +55,6 @@ prop_json_roundtrip_txout_utxo_context = H.property $ do prop_json_roundtrip_eraInMode :: Property prop_json_roundtrip_eraInMode = H.property $ do H.assert $ parseEither rountripEraInModeParser ByronEraInByronMode == Right ByronEraInByronMode - H.assert $ parseEither rountripEraInModeParser ShelleyEraInShelleyMode == Right ShelleyEraInShelleyMode H.assert $ parseEither rountripEraInModeParser ByronEraInCardanoMode == Right ByronEraInCardanoMode H.assert $ parseEither rountripEraInModeParser ShelleyEraInCardanoMode == Right ShelleyEraInCardanoMode H.assert $ parseEither rountripEraInModeParser AllegraEraInCardanoMode == Right AllegraEraInCardanoMode @@ -71,7 +70,6 @@ prop_json_roundtrip_eraInMode = H.property $ do rountripEraInModeParser :: EraInMode era mode -> Parser (EraInMode era mode) rountripEraInModeParser = \case ByronEraInByronMode -> parseJSON $ toJSON ByronEraInByronMode - ShelleyEraInShelleyMode -> parseJSON $ toJSON ShelleyEraInShelleyMode ByronEraInCardanoMode -> parseJSON $ toJSON ByronEraInCardanoMode ShelleyEraInCardanoMode -> parseJSON $ toJSON ShelleyEraInCardanoMode AllegraEraInCardanoMode -> parseJSON $ toJSON AllegraEraInCardanoMode From 12abf7efd888a5719731314851e72ff304e1ad1e Mon Sep 17 00:00:00 2001 From: John Ky Date: Wed, 25 Oct 2023 21:23:12 +1100 Subject: [PATCH 02/37] Delete ByronMode --- cardano-api/internal/Cardano/Api/Block.hs | 17 -------- .../internal/Cardano/Api/Convenience/Query.hs | 35 ++++++---------- cardano-api/internal/Cardano/Api/IPC.hs | 7 ---- cardano-api/internal/Cardano/Api/InMode.hs | 25 ----------- cardano-api/internal/Cardano/Api/Modes.hs | 42 ------------------- cardano-api/internal/Cardano/Api/Query.hs | 20 --------- .../internal/Cardano/Api/Query/Expr.hs | 1 - cardano-api/src/Cardano/Api/Byron.hs | 5 --- cardano-api/src/Cardano/Api/Shelley.hs | 3 -- .../cardano-api-test/Test/Cardano/Api/Json.hs | 2 - 10 files changed, 12 insertions(+), 145 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/Block.hs b/cardano-api/internal/Cardano/Api/Block.hs index 4ab4863ef6..e754519f16 100644 --- a/cardano-api/internal/Cardano/Api/Block.hs +++ b/cardano-api/internal/Cardano/Api/Block.hs @@ -73,9 +73,7 @@ import Cardano.Slotting.Slot (EpochNo, SlotNo, WithOrigin (..)) import qualified Ouroboros.Consensus.Block as Consensus import qualified Ouroboros.Consensus.Byron.Ledger as Consensus import qualified Ouroboros.Consensus.Cardano.Block as Consensus -import qualified Ouroboros.Consensus.Cardano.ByronHFC as Consensus import qualified Ouroboros.Consensus.HardFork.Combinator as Consensus -import qualified Ouroboros.Consensus.HardFork.Combinator.Degenerate as Consensus import qualified Ouroboros.Consensus.Shelley.Ledger as Consensus import qualified Ouroboros.Consensus.Shelley.Protocol.Abstract as Consensus import qualified Ouroboros.Network.Block as Consensus @@ -210,10 +208,6 @@ fromConsensusBlock :: () => ConsensusMode mode -> block -> BlockInMode mode -fromConsensusBlock ByronMode = \case - Consensus.DegenBlock b' -> - BlockInMode cardanoEra (ByronBlock b') ByronEraInByronMode - fromConsensusBlock CardanoMode = \case Consensus.BlockByron b' -> BlockInMode cardanoEra (ByronBlock b') ByronEraInCardanoMode @@ -247,7 +241,6 @@ toConsensusBlock :: () => BlockInMode mode -> block toConsensusBlock = \case -- Byron mode - BlockInMode _ (ByronBlock b') ByronEraInByronMode -> Consensus.DegenBlock b' -- Cardano mode BlockInMode _ (ByronBlock b') ByronEraInCardanoMode -> Consensus.BlockByron b' @@ -351,13 +344,11 @@ toConsensusPointInMode :: ConsensusMode mode -- It's the same concrete impl in all cases, but we have to show -- individually for each case that we satisfy the type equality constraint -- HeaderHash block ~ OneEraHash xs -toConsensusPointInMode ByronMode = toConsensusPointHF toConsensusPointInMode CardanoMode = toConsensusPointHF fromConsensusPointInMode :: ConsensusMode mode -> Consensus.Point (ConsensusBlockForMode mode) -> ChainPoint -fromConsensusPointInMode ByronMode = fromConsensusPointHF fromConsensusPointInMode CardanoMode = fromConsensusPointHF @@ -448,13 +439,6 @@ fromConsensusTip :: ConsensusBlockForMode mode ~ block => ConsensusMode mode -> Consensus.Tip block -> ChainTip -fromConsensusTip ByronMode = conv - where - conv :: Consensus.Tip Consensus.ByronBlockHFC -> ChainTip - conv Consensus.TipGenesis = ChainTipAtGenesis - conv (Consensus.Tip slot (Consensus.OneEraHash h) block) = - ChainTip slot (HeaderHash h) block - fromConsensusTip CardanoMode = conv where conv :: Consensus.Tip (Consensus.CardanoBlock Consensus.StandardCrypto) @@ -473,7 +457,6 @@ TODO: In principle we should be able to use this common implementation rather some reason not able to use it to see that it is indeed the only pattern. fromConsensusTip = \mode -> case mode of - ByronMode -> conv CardanoMode -> conv where conv :: HeaderHash block ~ OneEraHash xs diff --git a/cardano-api/internal/Cardano/Api/Convenience/Query.hs b/cardano-api/internal/Cardano/Api/Convenience/Query.hs index de3889e7ec..9cb14356c8 100644 --- a/cardano-api/internal/Cardano/Api/Convenience/Query.hs +++ b/cardano-api/internal/Cardano/Api/Convenience/Query.hs @@ -135,26 +135,24 @@ queryStateForBalancedTx era allTxIns certs = runExceptT $ do pure (utxo, LedgerProtocolParameters pparams, eraHistory, systemStart, stakePools, stakeDelegDeposits, drepDelegDeposits) -- | Query the node to determine which era it is in. -determineEra - :: ConsensusModeParams mode +determineEra :: () + => ConsensusModeParams mode -> LocalNodeConnectInfo mode -> IO (Either AcquiringFailure AnyCardanoEra) determineEra cModeParams localNodeConnInfo = case consensusModeOnly cModeParams of - ByronMode -> return . Right $ AnyCardanoEra ByronEra CardanoMode -> queryNodeLocalState localNodeConnInfo Nothing $ QueryCurrentEra CardanoModeIsMultiEra -- | Execute a query against the local node. The local -- node must be in CardanoMode. -executeQueryCardanoMode - :: SocketPath - -> CardanoEra era +executeQueryCardanoMode :: () + => SocketPath -> NetworkId -> QueryInMode CardanoMode (Either EraMismatch result) -> IO (Either QueryConvenienceError result) -executeQueryCardanoMode socketPath era nid q = runExceptT $ do +executeQueryCardanoMode socketPath nid q = runExceptT $ do let localNodeConnInfo = LocalNodeConnectInfo { localConsensusModeParams = CardanoModeParams (EpochSlots 21600) @@ -162,23 +160,14 @@ executeQueryCardanoMode socketPath era nid q = runExceptT $ do , localNodeSocketPath = socketPath } - ExceptT $ executeQueryAnyMode era localNodeConnInfo q + ExceptT $ executeQueryAnyMode localNodeConnInfo q -- | Execute a query against the local node in any mode. -executeQueryAnyMode - :: forall result era mode. CardanoEra era - -> LocalNodeConnectInfo mode +executeQueryAnyMode :: forall result mode. () + => LocalNodeConnectInfo mode -> QueryInMode mode (Either EraMismatch result) -> IO (Either QueryConvenienceError result) -executeQueryAnyMode era localNodeConnInfo q = runExceptT $ do - let cMode = consensusModeOnly $ localConsensusModeParams localNodeConnInfo - - eraInMode <- pure (toEraInMode era cMode) - & onNothing (left $ EraConsensusModeMismatch (AnyConsensusMode CardanoMode) (anyCardanoEra era)) - - case eraInMode of - ByronEraInByronMode -> left ByronEraNotSupported - _ -> - lift (queryNodeLocalState localNodeConnInfo Nothing q) - & onLeft (left . AcqFailure) - & onLeft (left . QueryEraMismatch) +executeQueryAnyMode localNodeConnInfo q = runExceptT $ do + lift (queryNodeLocalState localNodeConnInfo Nothing q) + & onLeft (left . AcqFailure) + & onLeft (left . QueryEraMismatch) diff --git a/cardano-api/internal/Cardano/Api/IPC.hs b/cardano-api/internal/Cardano/Api/IPC.hs index cfa113678e..9e5a8f8151 100644 --- a/cardano-api/internal/Cardano/Api/IPC.hs +++ b/cardano-api/internal/Cardano/Api/IPC.hs @@ -29,7 +29,6 @@ module Cardano.Api.IPC ( -- ** Modes -- | TODO move to Cardano.Api - ByronMode, CardanoMode, ConsensusModeParams(..), EpochSlots(..), @@ -191,7 +190,6 @@ localConsensusMode LocalNodeConnectInfo {localConsensusModeParams} = consensusModeOnly :: ConsensusModeParams mode -> ConsensusMode mode -consensusModeOnly ByronModeParams{} = ByronMode consensusModeOnly CardanoModeParams{} = CardanoMode @@ -415,11 +413,6 @@ mkLocalNodeClientParams modeparams clients = -- block type monomorphic. -- case modeparams of - ByronModeParams epochSlots -> - LocalNodeClientParamsSingleBlock - (ProtocolClientInfoArgsByron epochSlots) - (convLocalNodeClientProtocols ByronMode . clients) - CardanoModeParams epochSlots -> LocalNodeClientParamsCardano (ProtocolClientInfoArgsCardano epochSlots) diff --git a/cardano-api/internal/Cardano/Api/InMode.hs b/cardano-api/internal/Cardano/Api/InMode.hs index 5b4b1d0696..955da3313a 100644 --- a/cardano-api/internal/Cardano/Api/InMode.hs +++ b/cardano-api/internal/Cardano/Api/InMode.hs @@ -36,7 +36,6 @@ import qualified Ouroboros.Consensus.Byron.Ledger as Consensus import qualified Ouroboros.Consensus.Cardano.Block as Consensus import qualified Ouroboros.Consensus.HardFork.Combinator as Consensus import Ouroboros.Consensus.HardFork.Combinator.AcrossEras (EraMismatch) -import qualified Ouroboros.Consensus.HardFork.Combinator.Degenerate as Consensus import qualified Ouroboros.Consensus.Ledger.SupportsMempool as Consensus import qualified Ouroboros.Consensus.Shelley.HFEras as Consensus import qualified Ouroboros.Consensus.Shelley.Ledger as Consensus @@ -73,9 +72,6 @@ deriving instance Show (TxInMode mode) fromConsensusGenTx :: ConsensusBlockForMode mode ~ block => ConsensusMode mode -> Consensus.GenTx block -> TxInMode mode -fromConsensusGenTx ByronMode (Consensus.HardForkGenTx (Consensus.OneEraGenTx (Z tx'))) = - TxInByronSpecial tx' ByronEraInByronMode - fromConsensusGenTx CardanoMode (Consensus.HardForkGenTx (Consensus.OneEraGenTx (Z tx'))) = TxInByronSpecial tx' ByronEraInCardanoMode @@ -106,11 +102,6 @@ fromConsensusGenTx CardanoMode (Consensus.HardForkGenTx (Consensus.OneEraGenTx ( toConsensusGenTx :: ConsensusBlockForMode mode ~ block => TxInMode mode -> Consensus.GenTx block -toConsensusGenTx (TxInMode (ByronTx ByronEraOnlyByron tx) ByronEraInByronMode) = - Consensus.HardForkGenTx (Consensus.OneEraGenTx (Z tx')) - where - tx' = Consensus.ByronTx (Consensus.byronIdTx tx) tx - toConsensusGenTx (TxInMode (ByronTx ByronEraOnlyByron tx) ByronEraInCardanoMode) = Consensus.HardForkGenTx (Consensus.OneEraGenTx (Z tx')) where @@ -118,9 +109,6 @@ toConsensusGenTx (TxInMode (ByronTx ByronEraOnlyByron tx) ByronEraInCardanoMode) --TODO: add the above as mkByronTx to the consensus code, -- matching mkShelleyTx below -toConsensusGenTx (TxInByronSpecial gtx ByronEraInByronMode) = - Consensus.HardForkGenTx (Consensus.OneEraGenTx (Z gtx)) - toConsensusGenTx (TxInByronSpecial gtx ByronEraInCardanoMode) = Consensus.HardForkGenTx (Consensus.OneEraGenTx (Z gtx)) @@ -154,8 +142,6 @@ toConsensusGenTx (TxInMode (ShelleyTx _ tx) ConwayEraInCardanoMode) = where tx' = Consensus.mkShelleyTx tx -toConsensusGenTx (TxInMode (ShelleyTx _ _) ByronEraInByronMode) = - error "Cardano.Api.InMode.toConsensusGenTx: ShelleyTx In Byron era" toConsensusGenTx (TxInMode (ShelleyTx _ _) ByronEraInCardanoMode) = error "Cardano.Api.InMode.toConsensusGenTx: ShelleyTx In Byron era" @@ -176,12 +162,6 @@ data TxIdInMode mode where toConsensusTxId :: ConsensusBlockForMode mode ~ block => TxIdInMode mode -> Consensus.TxId (Consensus.GenTx block) -toConsensusTxId (TxIdInMode txid ByronEraInByronMode) = - Consensus.HardForkGenTxId . Consensus.OneEraGenTxId . Z $ Consensus.WrapGenTxId txid' - where - txid' :: Consensus.TxId (Consensus.GenTx Consensus.ByronBlock) - txid' = Consensus.ByronTxId $ toByronTxId txid - toConsensusTxId (TxIdInMode txid ByronEraInCardanoMode) = Consensus.HardForkGenTxId . Consensus.OneEraGenTxId . Z $ Consensus.WrapGenTxId txid' where @@ -306,11 +286,6 @@ fromConsensusApplyTxErr :: ConsensusBlockForMode mode ~ block => ConsensusMode mode -> Consensus.ApplyTxErr block -> TxValidationErrorInMode mode -fromConsensusApplyTxErr ByronMode (Consensus.DegenApplyTxErr err) = - TxValidationErrorInMode - (ByronTxValidationError err) - ByronEraInByronMode - fromConsensusApplyTxErr CardanoMode (Consensus.ApplyTxErrByron err) = TxValidationErrorInMode (ByronTxValidationError err) diff --git a/cardano-api/internal/Cardano/Api/Modes.hs b/cardano-api/internal/Cardano/Api/Modes.hs index 5626ef3d82..348b883cbf 100644 --- a/cardano-api/internal/Cardano/Api/Modes.hs +++ b/cardano-api/internal/Cardano/Api/Modes.hs @@ -13,7 +13,6 @@ module Cardano.Api.Modes ( -- * Consensus modes - ByronMode, CardanoMode, ConsensusMode(..), AnyConsensusMode(..), @@ -68,15 +67,6 @@ import Data.Text (Text) -- Consensus modes -- --- | The Byron-only consensus mode consists of only the Byron era. --- --- This was used on the mainnet before the deployment of the multi-era --- 'CardanoMode'. It is now of little practical use, though it illustrates --- how a single-era consensus mode works. It may be sensible to remove this --- at some stage. --- -data ByronMode - -- | The Cardano consensus mode consists of all the eras currently in use on -- the Cardano mainnet. This is currently: the 'ByronEra'; 'ShelleyEra', -- 'AllegraEra' and 'MaryEra', in that order. @@ -95,7 +85,6 @@ deriving instance Show AnyConsensusModeParams -- non-uniform way. -- data ConsensusMode mode where - ByronMode :: ConsensusMode ByronMode CardanoMode :: ConsensusMode CardanoMode @@ -107,7 +96,6 @@ data AnyConsensusMode where deriving instance Show AnyConsensusMode renderMode :: AnyConsensusMode -> Text -renderMode (AnyConsensusMode ByronMode) = "ByronMode" renderMode (AnyConsensusMode CardanoMode) = "CardanoMode" -- | The subset of consensus modes that consist of multiple eras. Some features @@ -120,8 +108,6 @@ data ConsensusModeIsMultiEra mode where deriving instance Show (ConsensusModeIsMultiEra mode) toEraInMode :: CardanoEra era -> ConsensusMode mode -> Maybe (EraInMode era mode) -toEraInMode ByronEra ByronMode = Just ByronEraInByronMode -toEraInMode _ ByronMode = Nothing toEraInMode ByronEra CardanoMode = Just ByronEraInCardanoMode toEraInMode ShelleyEra CardanoMode = Just ShelleyEraInCardanoMode toEraInMode AllegraEra CardanoMode = Just AllegraEraInCardanoMode @@ -134,8 +120,6 @@ toEraInMode ConwayEra CardanoMode = Just ConwayEraInCardanoMode -- 'ConsensusMode'. -- data EraInMode era mode where - ByronEraInByronMode :: EraInMode ByronEra ByronMode - ByronEraInCardanoMode :: EraInMode ByronEra CardanoMode ShelleyEraInCardanoMode :: EraInMode ShelleyEra CardanoMode AllegraEraInCardanoMode :: EraInMode AllegraEra CardanoMode @@ -148,13 +132,6 @@ deriving instance Show (EraInMode era mode) deriving instance Eq (EraInMode era mode) -instance FromJSON (EraInMode ByronEra ByronMode) where - parseJSON "ByronEraInByronMode" = pure ByronEraInByronMode - parseJSON invalid = - invalidJSONFailure "ByronEraInByronMode" - "parsing 'EraInMode ByronEra ByronMode' failed, " - invalid - instance FromJSON (EraInMode ByronEra CardanoMode) where parseJSON "ByronEraInCardanoMode" = pure ByronEraInCardanoMode parseJSON invalid = @@ -210,7 +187,6 @@ invalidJSONFailure expectedType errorMsg invalidValue = (typeMismatch expectedType invalidValue) instance ToJSON (EraInMode era mode) where - toJSON ByronEraInByronMode = "ByronEraInByronMode" toJSON ByronEraInCardanoMode = "ByronEraInCardanoMode" toJSON ShelleyEraInCardanoMode = "ShelleyEraInCardanoMode" toJSON AllegraEraInCardanoMode = "AllegraEraInCardanoMode" @@ -220,7 +196,6 @@ instance ToJSON (EraInMode era mode) where toJSON ConwayEraInCardanoMode = "ConwayEraInCardanoMode" eraInModeToEra :: EraInMode era mode -> CardanoEra era -eraInModeToEra ByronEraInByronMode = ByronEra eraInModeToEra ByronEraInCardanoMode = ByronEra eraInModeToEra ShelleyEraInCardanoMode = ShelleyEra eraInModeToEra AllegraEraInCardanoMode = AllegraEra @@ -239,7 +214,6 @@ deriving instance Show (AnyEraInMode mode) anyEraInModeToAnyEra :: AnyEraInMode mode -> AnyCardanoEra anyEraInModeToAnyEra (AnyEraInMode erainmode) = case erainmode of - ByronEraInByronMode -> AnyCardanoEra ByronEra ByronEraInCardanoMode -> AnyCardanoEra ByronEra ShelleyEraInCardanoMode -> AnyCardanoEra ShelleyEra AllegraEraInCardanoMode -> AnyCardanoEra AllegraEra @@ -263,10 +237,6 @@ anyEraInModeToAnyEra (AnyEraInMode erainmode) = -- data ConsensusModeParams mode where - ByronModeParams - :: Byron.EpochSlots - -> ConsensusModeParams ByronMode - CardanoModeParams :: Byron.EpochSlots -> ConsensusModeParams CardanoMode @@ -281,7 +251,6 @@ deriving instance Show (ConsensusModeParams mode) -- and the block type used by the consensus libraries. -- type family ConsensusBlockForMode mode where - ConsensusBlockForMode ByronMode = Consensus.ByronBlockHFC ConsensusBlockForMode CardanoMode = Consensus.CardanoBlock StandardCrypto type family ConsensusBlockForEra era where @@ -338,8 +307,6 @@ eraIndex6 = eraIndexSucc eraIndex5 toConsensusEraIndex :: ConsensusBlockForMode mode ~ Consensus.HardForkBlock xs => EraInMode era mode -> Consensus.EraIndex xs -toConsensusEraIndex ByronEraInByronMode = eraIndex0 - toConsensusEraIndex ByronEraInCardanoMode = eraIndex0 toConsensusEraIndex ShelleyEraInCardanoMode = eraIndex1 toConsensusEraIndex AllegraEraInCardanoMode = eraIndex2 @@ -353,15 +320,6 @@ fromConsensusEraIndex :: ConsensusBlockForMode mode ~ Consensus.HardForkBlock xs => ConsensusMode mode -> Consensus.EraIndex xs -> AnyEraInMode mode -fromConsensusEraIndex ByronMode = fromByronEraIndex - where - fromByronEraIndex :: Consensus.EraIndex - '[Consensus.ByronBlock] - -> AnyEraInMode ByronMode - fromByronEraIndex (Consensus.EraIndex (Z (K ()))) = - AnyEraInMode ByronEraInByronMode - - fromConsensusEraIndex CardanoMode = fromShelleyEraIndex where fromShelleyEraIndex :: Consensus.EraIndex diff --git a/cardano-api/internal/Cardano/Api/Query.hs b/cardano-api/internal/Cardano/Api/Query.hs index df52e142af..527f1c6524 100644 --- a/cardano-api/internal/Cardano/Api/Query.hs +++ b/cardano-api/internal/Cardano/Api/Query.hs @@ -115,7 +115,6 @@ import qualified Ouroboros.Consensus.Cardano.Block as Consensus import qualified Ouroboros.Consensus.HardFork.Combinator as Consensus import Ouroboros.Consensus.HardFork.Combinator.AcrossEras (EraMismatch) import qualified Ouroboros.Consensus.HardFork.Combinator.AcrossEras as Consensus -import qualified Ouroboros.Consensus.HardFork.Combinator.Degenerate as Consensus import qualified Ouroboros.Consensus.HardFork.History as Consensus import qualified Ouroboros.Consensus.HardFork.History as History import qualified Ouroboros.Consensus.HardFork.History.Qry as Qry @@ -556,11 +555,6 @@ toConsensusQuery (QueryCurrentEra CardanoModeIsMultiEra) = Consensus.QueryHardFork Consensus.GetCurrentEra -toConsensusQuery (QueryInEra ByronEraInByronMode QueryByronUpdateState) = - Some $ Consensus.BlockQuery $ - Consensus.DegenQuery - Consensus.GetUpdateInterfaceState - toConsensusQuery (QueryEraHistory CardanoModeIsMultiEra) = Some $ Consensus.BlockQuery $ Consensus.QueryHardFork @@ -579,7 +573,6 @@ toConsensusQuery (QueryInEra ByronEraInCardanoMode QueryByronUpdateState) = toConsensusQuery (QueryInEra erainmode (QueryInShelleyBasedEra sbe q)) = case erainmode of - ByronEraInByronMode -> case sbe of {} ByronEraInCardanoMode -> case sbe of {} ShelleyEraInCardanoMode -> toConsensusQueryShelleyBased erainmode q AllegraEraInCardanoMode -> toConsensusQueryShelleyBased erainmode q @@ -698,7 +691,6 @@ consensusQueryInEraInMode consensusQueryInEraInMode erainmode = Consensus.BlockQuery . case erainmode of - ByronEraInByronMode -> Consensus.DegenQuery ByronEraInCardanoMode -> Consensus.QueryIfCurrentByron ShelleyEraInCardanoMode -> Consensus.QueryIfCurrentShelley AllegraEraInCardanoMode -> Consensus.QueryIfCurrentAllegra @@ -748,14 +740,6 @@ fromConsensusQueryResult (QueryCurrentEra CardanoModeIsMultiEra) q' r' = -> anyEraInModeToAnyEra (fromConsensusEraIndex CardanoMode r') _ -> fromConsensusQueryResultMismatch -fromConsensusQueryResult (QueryInEra ByronEraInByronMode - QueryByronUpdateState) q' r' = - case (q', r') of - (Consensus.BlockQuery (Consensus.DegenQuery Consensus.GetUpdateInterfaceState), - Consensus.DegenQueryResult r'') - -> Right (ByronUpdateState r'') - _ -> fromConsensusQueryResultMismatch - fromConsensusQueryResult (QueryInEra ByronEraInCardanoMode QueryByronUpdateState) q' r' = case q' of @@ -764,10 +748,6 @@ fromConsensusQueryResult (QueryInEra ByronEraInCardanoMode -> bimap fromConsensusEraMismatch ByronUpdateState r' _ -> fromConsensusQueryResultMismatch -fromConsensusQueryResult (QueryInEra ByronEraInByronMode - (QueryInShelleyBasedEra sbe _)) _ _ = - case sbe of {} - fromConsensusQueryResult (QueryInEra ByronEraInCardanoMode (QueryInShelleyBasedEra sbe _)) _ _ = case sbe of {} diff --git a/cardano-api/internal/Cardano/Api/Query/Expr.hs b/cardano-api/internal/Cardano/Api/Query/Expr.hs index 0e537be1f0..fafee70c30 100644 --- a/cardano-api/internal/Cardano/Api/Query/Expr.hs +++ b/cardano-api/internal/Cardano/Api/Query/Expr.hs @@ -226,7 +226,6 @@ determineEraExpr :: () -> LocalStateQueryExpr block point (QueryInMode mode) r IO (Either UnsupportedNtcVersionError AnyCardanoEra) determineEraExpr cModeParams = runExceptT $ case consensusModeOnly cModeParams of - ByronMode -> pure $ AnyCardanoEra ByronEra CardanoMode -> ExceptT queryCurrentEra queryConstitution :: () diff --git a/cardano-api/src/Cardano/Api/Byron.hs b/cardano-api/src/Cardano/Api/Byron.hs index 9afcc47f1e..4dfd9d9a41 100644 --- a/cardano-api/src/Cardano/Api/Byron.hs +++ b/cardano-api/src/Cardano/Api/Byron.hs @@ -47,10 +47,6 @@ module Cardano.Api.Byron -- ** Low level protocol interaction with a Cardano node LocalNodeConnectInfo(LocalNodeConnectInfo), - ByronMode, - ConsensusMode - ( ByronMode - ), LocalNodeClientProtocols(LocalNodeClientProtocols), -- *** Chain sync protocol @@ -92,7 +88,6 @@ module Cardano.Api.Byron import Cardano.Api import Cardano.Api.Address -import Cardano.Api.IPC import Cardano.Api.Keys.Byron import Cardano.Api.NetworkId import Cardano.Api.SpecialByron diff --git a/cardano-api/src/Cardano/Api/Shelley.hs b/cardano-api/src/Cardano/Api/Shelley.hs index 4ad2623f2b..0096c76acc 100644 --- a/cardano-api/src/Cardano/Api/Shelley.hs +++ b/cardano-api/src/Cardano/Api/Shelley.hs @@ -214,9 +214,6 @@ module Cardano.Api.Shelley -- ** Low level protocol interaction with a Cardano node LocalNodeConnectInfo(LocalNodeConnectInfo), - ConsensusMode - ( ByronMode - ), LocalNodeClientProtocols(LocalNodeClientProtocols), -- ** Shelley based eras diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Json.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Json.hs index e6c16a8279..a33963f049 100644 --- a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Json.hs +++ b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Json.hs @@ -54,7 +54,6 @@ prop_json_roundtrip_txout_utxo_context = H.property $ do prop_json_roundtrip_eraInMode :: Property prop_json_roundtrip_eraInMode = H.property $ do - H.assert $ parseEither rountripEraInModeParser ByronEraInByronMode == Right ByronEraInByronMode H.assert $ parseEither rountripEraInModeParser ByronEraInCardanoMode == Right ByronEraInCardanoMode H.assert $ parseEither rountripEraInModeParser ShelleyEraInCardanoMode == Right ShelleyEraInCardanoMode H.assert $ parseEither rountripEraInModeParser AllegraEraInCardanoMode == Right AllegraEraInCardanoMode @@ -69,7 +68,6 @@ prop_json_roundtrip_eraInMode = H.property $ do -- need to add a new 'FromJSON' instance. rountripEraInModeParser :: EraInMode era mode -> Parser (EraInMode era mode) rountripEraInModeParser = \case - ByronEraInByronMode -> parseJSON $ toJSON ByronEraInByronMode ByronEraInCardanoMode -> parseJSON $ toJSON ByronEraInCardanoMode ShelleyEraInCardanoMode -> parseJSON $ toJSON ShelleyEraInCardanoMode AllegraEraInCardanoMode -> parseJSON $ toJSON AllegraEraInCardanoMode From 10ab5d7c61b07734995402cba601e86b31534f0f Mon Sep 17 00:00:00 2001 From: John Ky Date: Wed, 25 Oct 2023 21:46:46 +1100 Subject: [PATCH 03/37] Delete anyEraInModeToAnyEra and AnyEraInMode --- cardano-api/internal/Cardano/Api/Modes.hs | 96 ++++++++--------------- cardano-api/internal/Cardano/Api/Query.hs | 2 +- 2 files changed, 35 insertions(+), 63 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/Modes.hs b/cardano-api/internal/Cardano/Api/Modes.hs index 348b883cbf..54bc3c5a34 100644 --- a/cardano-api/internal/Cardano/Api/Modes.hs +++ b/cardano-api/internal/Cardano/Api/Modes.hs @@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} @@ -22,8 +23,6 @@ module Cardano.Api.Modes ( -- * The eras supported by each mode EraInMode(..), eraInModeToEra, - anyEraInModeToAnyEra, - AnyEraInMode(..), toEraInMode, -- * The protocols supported in each era @@ -204,25 +203,6 @@ eraInModeToEra AlonzoEraInCardanoMode = AlonzoEra eraInModeToEra BabbageEraInCardanoMode = BabbageEra eraInModeToEra ConwayEraInCardanoMode = ConwayEra - -data AnyEraInMode mode where - AnyEraInMode :: EraInMode era mode -> AnyEraInMode mode - -deriving instance Show (AnyEraInMode mode) - - -anyEraInModeToAnyEra :: AnyEraInMode mode -> AnyCardanoEra -anyEraInModeToAnyEra (AnyEraInMode erainmode) = - case erainmode of - ByronEraInCardanoMode -> AnyCardanoEra ByronEra - ShelleyEraInCardanoMode -> AnyCardanoEra ShelleyEra - AllegraEraInCardanoMode -> AnyCardanoEra AllegraEra - MaryEraInCardanoMode -> AnyCardanoEra MaryEra - AlonzoEraInCardanoMode -> AnyCardanoEra AlonzoEra - BabbageEraInCardanoMode -> AnyCardanoEra BabbageEra - ConwayEraInCardanoMode -> AnyCardanoEra ConwayEra - - -- | The consensus-mode-specific parameters needed to connect to a local node -- that is using each consensus mode. -- @@ -304,44 +284,36 @@ eraIndex5 = eraIndexSucc eraIndex4 eraIndex6 :: Consensus.EraIndex (x6 : x5 : x4 : x3 : x2 : x1 : x0 : xs) eraIndex6 = eraIndexSucc eraIndex5 -toConsensusEraIndex :: ConsensusBlockForMode mode ~ Consensus.HardForkBlock xs - => EraInMode era mode - -> Consensus.EraIndex xs -toConsensusEraIndex ByronEraInCardanoMode = eraIndex0 -toConsensusEraIndex ShelleyEraInCardanoMode = eraIndex1 -toConsensusEraIndex AllegraEraInCardanoMode = eraIndex2 -toConsensusEraIndex MaryEraInCardanoMode = eraIndex3 -toConsensusEraIndex AlonzoEraInCardanoMode = eraIndex4 -toConsensusEraIndex BabbageEraInCardanoMode = eraIndex5 -toConsensusEraIndex ConwayEraInCardanoMode = eraIndex6 - - -fromConsensusEraIndex :: ConsensusBlockForMode mode ~ Consensus.HardForkBlock xs - => ConsensusMode mode - -> Consensus.EraIndex xs - -> AnyEraInMode mode -fromConsensusEraIndex CardanoMode = fromShelleyEraIndex - where - fromShelleyEraIndex :: Consensus.EraIndex - (Consensus.CardanoEras StandardCrypto) - -> AnyEraInMode CardanoMode - fromShelleyEraIndex (Consensus.EraIndex (Z (K ()))) = - AnyEraInMode ByronEraInCardanoMode - - fromShelleyEraIndex (Consensus.EraIndex (S (Z (K ())))) = - AnyEraInMode ShelleyEraInCardanoMode - - fromShelleyEraIndex (Consensus.EraIndex (S (S (Z (K ()))))) = - AnyEraInMode AllegraEraInCardanoMode - - fromShelleyEraIndex (Consensus.EraIndex (S (S (S (Z (K ())))))) = - AnyEraInMode MaryEraInCardanoMode - - fromShelleyEraIndex (Consensus.EraIndex (S (S (S (S (Z (K ()))))))) = - AnyEraInMode AlonzoEraInCardanoMode - - fromShelleyEraIndex (Consensus.EraIndex (S (S (S (S (S (Z (K ())))))))) = - AnyEraInMode BabbageEraInCardanoMode - - fromShelleyEraIndex (Consensus.EraIndex (S (S (S (S (S (S (Z (K ()))))))))) = - AnyEraInMode ConwayEraInCardanoMode +toConsensusEraIndex :: () + => ConsensusBlockForMode CardanoMode ~ Consensus.HardForkBlock xs + => CardanoEra era + -> Consensus.EraIndex xs +toConsensusEraIndex = \case + ByronEra -> eraIndex0 + ShelleyEra -> eraIndex1 + AllegraEra -> eraIndex2 + MaryEra -> eraIndex3 + AlonzoEra -> eraIndex4 + BabbageEra -> eraIndex5 + ConwayEra -> eraIndex6 + + +fromConsensusEraIndex :: () + => ConsensusMode mode + -> Consensus.EraIndex (Consensus.CardanoEras StandardCrypto) + -> AnyCardanoEra +fromConsensusEraIndex CardanoMode = \case + Consensus.EraIndex (Z (K ())) -> + AnyCardanoEra ByronEra + Consensus.EraIndex (S (Z (K ()))) -> + AnyCardanoEra ShelleyEra + Consensus.EraIndex (S (S (Z (K ())))) -> + AnyCardanoEra AllegraEra + Consensus.EraIndex (S (S (S (Z (K ()))))) -> + AnyCardanoEra MaryEra + Consensus.EraIndex (S (S (S (S (Z (K ())))))) -> + AnyCardanoEra AlonzoEra + Consensus.EraIndex (S (S (S (S (S (Z (K ()))))))) -> + AnyCardanoEra BabbageEra + Consensus.EraIndex (S (S (S (S (S (S (Z (K ())))))))) -> + AnyCardanoEra ConwayEra diff --git a/cardano-api/internal/Cardano/Api/Query.hs b/cardano-api/internal/Cardano/Api/Query.hs index 527f1c6524..11edbec386 100644 --- a/cardano-api/internal/Cardano/Api/Query.hs +++ b/cardano-api/internal/Cardano/Api/Query.hs @@ -737,7 +737,7 @@ fromConsensusQueryResult (QueryChainPoint mode) q' r' = fromConsensusQueryResult (QueryCurrentEra CardanoModeIsMultiEra) q' r' = case q' of Consensus.BlockQuery (Consensus.QueryHardFork Consensus.GetCurrentEra) - -> anyEraInModeToAnyEra (fromConsensusEraIndex CardanoMode r') + -> fromConsensusEraIndex CardanoMode r' _ -> fromConsensusQueryResultMismatch fromConsensusQueryResult (QueryInEra ByronEraInCardanoMode From 9dceb3216f5a74c5362865897cec90e3c10adcd9 Mon Sep 17 00:00:00 2001 From: John Ky Date: Wed, 25 Oct 2023 22:08:57 +1100 Subject: [PATCH 04/37] Delete ConsensusModeIsMultiEra --- .../internal/Cardano/Api/Convenience/Query.hs | 3 +- cardano-api/internal/Cardano/Api/IPC.hs | 34 +++++------- cardano-api/internal/Cardano/Api/Modes.hs | 10 ---- cardano-api/internal/Cardano/Api/Query.hs | 55 +++++++++---------- .../internal/Cardano/Api/Query/Expr.hs | 4 +- cardano-api/src/Cardano/Api.hs | 1 - 6 files changed, 42 insertions(+), 65 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/Convenience/Query.hs b/cardano-api/internal/Cardano/Api/Convenience/Query.hs index 9cb14356c8..831cd0993b 100644 --- a/cardano-api/internal/Cardano/Api/Convenience/Query.hs +++ b/cardano-api/internal/Cardano/Api/Convenience/Query.hs @@ -142,8 +142,7 @@ determineEra :: () determineEra cModeParams localNodeConnInfo = case consensusModeOnly cModeParams of CardanoMode -> - queryNodeLocalState localNodeConnInfo Nothing - $ QueryCurrentEra CardanoModeIsMultiEra + queryNodeLocalState localNodeConnInfo Nothing QueryCurrentEra -- | Execute a query against the local node. The local -- node must be in CardanoMode. diff --git a/cardano-api/internal/Cardano/Api/IPC.hs b/cardano-api/internal/Cardano/Api/IPC.hs index 9e5a8f8151..5fa07c4e44 100644 --- a/cardano-api/internal/Cardano/Api/IPC.hs +++ b/cardano-api/internal/Cardano/Api/IPC.hs @@ -419,11 +419,11 @@ mkLocalNodeClientParams modeparams clients = (convLocalNodeClientProtocols CardanoMode . clients) -convLocalNodeClientProtocols :: forall mode block. - ConsensusBlockForMode mode ~ block - => ConsensusMode mode - -> LocalNodeClientProtocolsInMode mode - -> LocalNodeClientProtocolsForBlock block +convLocalNodeClientProtocols :: forall block. () + => ConsensusBlockForMode CardanoMode ~ block + => ConsensusMode CardanoMode + -> LocalNodeClientProtocolsInMode CardanoMode + -> LocalNodeClientProtocolsForBlock block convLocalNodeClientProtocols mode LocalNodeClientProtocols { @@ -438,15 +438,9 @@ convLocalNodeClientProtocols LocalChainSyncClientPipelined clientPipelined -> LocalChainSyncClientPipelined $ convLocalChainSyncClientPipelined mode clientPipelined LocalChainSyncClient client -> LocalChainSyncClient $ convLocalChainSyncClient mode client, - localTxSubmissionClientForBlock = convLocalTxSubmissionClient mode <$> - localTxSubmissionClient, - - localStateQueryClientForBlock = convLocalStateQueryClient mode <$> - localStateQueryClient, - - localTxMonitoringClientForBlock = convLocalTxMonitoringClient mode <$> - localTxMonitoringClient - + localTxSubmissionClientForBlock = convLocalTxSubmissionClient mode <$> localTxSubmissionClient, + localStateQueryClientForBlock = convLocalStateQueryClient mode <$> localStateQueryClient, + localTxMonitoringClientForBlock = convLocalTxMonitoringClient mode <$> localTxMonitoringClient } convLocalTxMonitoringClient @@ -500,12 +494,12 @@ convLocalTxSubmissionClient mode = convLocalStateQueryClient - :: forall mode block m a. - (ConsensusBlockForMode mode ~ block, Functor m) - => ConsensusMode mode - -> LocalStateQueryClient (BlockInMode mode) ChainPoint (QueryInMode mode) m a - -> LocalStateQueryClient block (Consensus.Point block) - (Consensus.Query block) m a + :: forall block m a. () + => ConsensusBlockForMode CardanoMode ~ block + => Functor m + => ConsensusMode CardanoMode + -> LocalStateQueryClient (BlockInMode CardanoMode) ChainPoint (QueryInMode CardanoMode) m a + -> LocalStateQueryClient block (Consensus.Point block) (Consensus.Query block) m a convLocalStateQueryClient mode = Net.Query.mapLocalStateQueryClient (toConsensusPointInMode mode) diff --git a/cardano-api/internal/Cardano/Api/Modes.hs b/cardano-api/internal/Cardano/Api/Modes.hs index 54bc3c5a34..6d6e13cae8 100644 --- a/cardano-api/internal/Cardano/Api/Modes.hs +++ b/cardano-api/internal/Cardano/Api/Modes.hs @@ -18,7 +18,6 @@ module Cardano.Api.Modes ( ConsensusMode(..), AnyConsensusMode(..), renderMode, - ConsensusModeIsMultiEra(..), -- * The eras supported by each mode EraInMode(..), @@ -97,15 +96,6 @@ deriving instance Show AnyConsensusMode renderMode :: AnyConsensusMode -> Text renderMode (AnyConsensusMode CardanoMode) = "CardanoMode" --- | The subset of consensus modes that consist of multiple eras. Some features --- are not supported in single-era modes (for exact compatibility without --- using the hard fork combination at all). --- -data ConsensusModeIsMultiEra mode where - CardanoModeIsMultiEra :: ConsensusModeIsMultiEra CardanoMode - -deriving instance Show (ConsensusModeIsMultiEra mode) - toEraInMode :: CardanoEra era -> ConsensusMode mode -> Maybe (EraInMode era mode) toEraInMode ByronEra CardanoMode = Just ByronEraInCardanoMode toEraInMode ShelleyEra CardanoMode = Just ShelleyEraInCardanoMode diff --git a/cardano-api/internal/Cardano/Api/Query.hs b/cardano-api/internal/Cardano/Api/Query.hs index 11edbec386..5117b0e3a7 100644 --- a/cardano-api/internal/Cardano/Api/Query.hs +++ b/cardano-api/internal/Cardano/Api/Query.hs @@ -4,6 +4,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} @@ -152,8 +153,7 @@ import GHC.Stack data QueryInMode mode result where QueryCurrentEra - :: ConsensusModeIsMultiEra mode - -> QueryInMode mode AnyCardanoEra + :: QueryInMode mode AnyCardanoEra QueryInEra :: EraInMode era mode @@ -161,8 +161,7 @@ data QueryInMode mode result where -> QueryInMode mode (Either EraMismatch result) QueryEraHistory - :: ConsensusModeIsMultiEra mode - -> QueryInMode mode (EraHistory mode) + :: QueryInMode mode (EraHistory mode) QuerySystemStart :: QueryInMode mode SystemStart @@ -175,12 +174,13 @@ data QueryInMode mode result where -> QueryInMode mode ChainPoint instance NodeToClientVersionOf (QueryInMode mode result) where - nodeToClientVersionOf (QueryCurrentEra _) = NodeToClientV_9 - nodeToClientVersionOf (QueryInEra _ q) = nodeToClientVersionOf q - nodeToClientVersionOf (QueryEraHistory _) = NodeToClientV_9 - nodeToClientVersionOf QuerySystemStart = NodeToClientV_9 - nodeToClientVersionOf QueryChainBlockNo = NodeToClientV_10 - nodeToClientVersionOf (QueryChainPoint _) = NodeToClientV_10 + nodeToClientVersionOf = \case + QueryCurrentEra -> NodeToClientV_9 + QueryInEra _ q -> nodeToClientVersionOf q + QueryEraHistory -> NodeToClientV_9 + QuerySystemStart -> NodeToClientV_9 + QueryChainBlockNo -> NodeToClientV_10 + QueryChainPoint _ -> NodeToClientV_10 data EraHistory mode where EraHistory @@ -205,11 +205,6 @@ toLedgerEpochInfo (EraHistory _ interpreter) = LedgerEpochInfo $ hoistEpochInfo (first (Text.pack . show) . runExcept) $ Consensus.interpreterToEpochInfo interpreter ---TODO: add support for these --- QueryEraStart :: ConsensusModeIsMultiEra mode --- -> EraInMode era mode --- -> QueryInMode mode (Maybe EraStart) - newtype SlotsInEpoch = SlotsInEpoch Word64 newtype SlotsToEpochEnd = SlotsToEpochEnd Word64 @@ -546,16 +541,16 @@ fromShelleyRewardAccounts = -- Conversions of queries into the consensus types. -- -toConsensusQuery :: forall mode block result. - ConsensusBlockForMode mode ~ block - => QueryInMode mode result - -> Some (Consensus.Query block) -toConsensusQuery (QueryCurrentEra CardanoModeIsMultiEra) = +toConsensusQuery :: forall block result. () + => ConsensusBlockForMode CardanoMode ~ block + => QueryInMode CardanoMode result + -> Some (Consensus.Query block) +toConsensusQuery QueryCurrentEra = Some $ Consensus.BlockQuery $ Consensus.QueryHardFork Consensus.GetCurrentEra -toConsensusQuery (QueryEraHistory CardanoModeIsMultiEra) = +toConsensusQuery QueryEraHistory = Some $ Consensus.BlockQuery $ Consensus.QueryHardFork Consensus.GetInterpreter @@ -703,14 +698,14 @@ consensusQueryInEraInMode erainmode = -- Conversions of query results from the consensus types. -- -fromConsensusQueryResult :: forall mode block result result'. - HasCallStack - => ConsensusBlockForMode mode ~ block - => QueryInMode mode result - -> Consensus.Query block result' - -> result' - -> result -fromConsensusQueryResult (QueryEraHistory CardanoModeIsMultiEra) q' r' = +fromConsensusQueryResult :: forall block result result'. () + => HasCallStack + => ConsensusBlockForMode CardanoMode ~ block + => QueryInMode CardanoMode result + -> Consensus.Query block result' + -> result' + -> result +fromConsensusQueryResult QueryEraHistory q' r' = case q' of Consensus.BlockQuery (Consensus.QueryHardFork Consensus.GetInterpreter) -> EraHistory CardanoMode r' @@ -734,7 +729,7 @@ fromConsensusQueryResult (QueryChainPoint mode) q' r' = -> fromConsensusPointInMode mode r' _ -> fromConsensusQueryResultMismatch -fromConsensusQueryResult (QueryCurrentEra CardanoModeIsMultiEra) q' r' = +fromConsensusQueryResult QueryCurrentEra q' r' = case q' of Consensus.BlockQuery (Consensus.QueryHardFork Consensus.GetCurrentEra) -> fromConsensusEraIndex CardanoMode r' diff --git a/cardano-api/internal/Cardano/Api/Query/Expr.hs b/cardano-api/internal/Cardano/Api/Query/Expr.hs index fafee70c30..454a5a3d5b 100644 --- a/cardano-api/internal/Cardano/Api/Query/Expr.hs +++ b/cardano-api/internal/Cardano/Api/Query/Expr.hs @@ -78,7 +78,7 @@ queryChainPoint = queryCurrentEra :: () => LocalStateQueryExpr block point (QueryInMode CardanoMode) r IO (Either UnsupportedNtcVersionError AnyCardanoEra) queryCurrentEra = - queryExpr $ QueryCurrentEra CardanoModeIsMultiEra + queryExpr QueryCurrentEra queryCurrentEpochState :: () => EraInMode era mode @@ -104,7 +104,7 @@ queryDebugLedgerState eraInMode sbe = queryEraHistory :: () => LocalStateQueryExpr block point (QueryInMode CardanoMode) r IO (Either UnsupportedNtcVersionError (EraHistory CardanoMode)) queryEraHistory = - queryExpr $ QueryEraHistory CardanoModeIsMultiEra + queryExpr QueryEraHistory queryGenesisParameters :: () => EraInMode era mode diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs index d9a2884192..22871c8e15 100644 --- a/cardano-api/src/Cardano/Api.hs +++ b/cardano-api/src/Cardano/Api.hs @@ -790,7 +790,6 @@ module Cardano.Api ( renderMode, ConsensusMode(CardanoMode), consensusModeOnly, - ConsensusModeIsMultiEra(..), AnyConsensusModeParams(..), ConsensusModeParams(..), ConsensusProtocol, From ce8e3c0a1cda0b5c8c8d99c6fb524919af762842 Mon Sep 17 00:00:00 2001 From: John Ky Date: Wed, 25 Oct 2023 22:14:10 +1100 Subject: [PATCH 05/37] Deparameterise LocalNodeClientProtocolsInMode --- .../internal/Cardano/Api/Convenience/Query.hs | 6 +- cardano-api/internal/Cardano/Api/IPC.hs | 79 ++++++++++--------- cardano-api/internal/Cardano/Api/IPC/Monad.hs | 4 +- .../internal/Cardano/Api/LedgerState.hs | 7 +- 4 files changed, 51 insertions(+), 45 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/Convenience/Query.hs b/cardano-api/internal/Cardano/Api/Convenience/Query.hs index 831cd0993b..bb99dccb98 100644 --- a/cardano-api/internal/Cardano/Api/Convenience/Query.hs +++ b/cardano-api/internal/Cardano/Api/Convenience/Query.hs @@ -162,9 +162,9 @@ executeQueryCardanoMode socketPath nid q = runExceptT $ do ExceptT $ executeQueryAnyMode localNodeConnInfo q -- | Execute a query against the local node in any mode. -executeQueryAnyMode :: forall result mode. () - => LocalNodeConnectInfo mode - -> QueryInMode mode (Either EraMismatch result) +executeQueryAnyMode :: forall result. () + => LocalNodeConnectInfo CardanoMode + -> QueryInMode CardanoMode (Either EraMismatch result) -> IO (Either QueryConvenienceError result) executeQueryAnyMode localNodeConnInfo q = runExceptT $ do lift (queryNodeLocalState localNodeConnInfo Nothing q) diff --git a/cardano-api/internal/Cardano/Api/IPC.hs b/cardano-api/internal/Cardano/Api/IPC.hs index 5fa07c4e44..de2459885c 100644 --- a/cardano-api/internal/Cardano/Api/IPC.hs +++ b/cardano-api/internal/Cardano/Api/IPC.hs @@ -165,16 +165,16 @@ data LocalChainSyncClient block point tip m | LocalChainSyncClient (ChainSyncClient block point tip m ()) -- public, exported -type LocalNodeClientProtocolsInMode mode = +type LocalNodeClientProtocolsInMode = LocalNodeClientProtocols - (BlockInMode mode) + (BlockInMode CardanoMode) ChainPoint ChainTip SlotNo - (TxInMode mode) - (TxIdInMode mode) - (TxValidationErrorInMode mode) - (QueryInMode mode) + (TxInMode CardanoMode) + (TxIdInMode CardanoMode) + (TxValidationErrorInMode CardanoMode) + (QueryInMode CardanoMode) IO data LocalNodeConnectInfo mode = @@ -200,9 +200,10 @@ consensusModeOnly CardanoModeParams{} = CardanoMode -- | Establish a connection to a local node and execute the given set of -- protocol handlers. -- -connectToLocalNode :: LocalNodeConnectInfo mode - -> LocalNodeClientProtocolsInMode mode - -> IO () +connectToLocalNode :: () + => LocalNodeConnectInfo CardanoMode + -> LocalNodeClientProtocolsInMode + -> IO () connectToLocalNode localNodeConnectInfo handlers = connectToLocalNodeWithVersion localNodeConnectInfo (const handlers) @@ -210,9 +211,10 @@ connectToLocalNode localNodeConnectInfo handlers -- protocol handlers parameterized on the negotiated node-to-client protocol -- version. -- -connectToLocalNodeWithVersion :: LocalNodeConnectInfo mode - -> (NodeToClientVersion -> LocalNodeClientProtocolsInMode mode) - -> IO () +connectToLocalNodeWithVersion :: () + => LocalNodeConnectInfo CardanoMode + -> (NodeToClientVersion -> LocalNodeClientProtocolsInMode) + -> IO () connectToLocalNodeWithVersion LocalNodeConnectInfo { localNodeSocketPath, localNodeNetworkId, @@ -395,11 +397,11 @@ data LocalNodeClientProtocolsForBlock block = -- | Convert from the mode-parametrised style to the block-parametrised style. -- -mkLocalNodeClientParams :: forall mode block. - ConsensusBlockForMode mode ~ block - => ConsensusModeParams mode - -> (NodeToClientVersion -> LocalNodeClientProtocolsInMode mode) - -> LocalNodeClientParams +mkLocalNodeClientParams :: forall block. () + => ConsensusBlockForMode CardanoMode ~ block + => ConsensusModeParams CardanoMode + -> (NodeToClientVersion -> LocalNodeClientProtocolsInMode) + -> LocalNodeClientParams mkLocalNodeClientParams modeparams clients = -- For each of the possible consensus modes we pick the concrete block type -- (by picking the appropriate 'ProtocolClient' value). @@ -422,7 +424,7 @@ mkLocalNodeClientParams modeparams clients = convLocalNodeClientProtocols :: forall block. () => ConsensusBlockForMode CardanoMode ~ block => ConsensusMode CardanoMode - -> LocalNodeClientProtocolsInMode CardanoMode + -> LocalNodeClientProtocolsInMode -> LocalNodeClientProtocolsForBlock block convLocalNodeClientProtocols mode @@ -559,11 +561,11 @@ toAcquiringFailure :: Net.Query.AcquireFailure -> AcquiringFailure toAcquiringFailure AcquireFailurePointTooOld = AFPointTooOld toAcquiringFailure AcquireFailurePointNotOnChain = AFPointNotOnChain -queryNodeLocalState :: forall mode result. - LocalNodeConnectInfo mode - -> Maybe ChainPoint - -> QueryInMode mode result - -> IO (Either AcquiringFailure result) +queryNodeLocalState :: forall result. () + => LocalNodeConnectInfo CardanoMode + -> Maybe ChainPoint + -> QueryInMode CardanoMode result + -> IO (Either AcquiringFailure result) queryNodeLocalState connctInfo mpoint query = do resultVar <- newEmptyTMVarIO connectToLocalNode @@ -579,8 +581,7 @@ queryNodeLocalState connctInfo mpoint query = do singleQuery :: Maybe ChainPoint -> TMVar (Either AcquiringFailure result) - -> Net.Query.LocalStateQueryClient (BlockInMode mode) ChainPoint - (QueryInMode mode) IO () + -> Net.Query.LocalStateQueryClient (BlockInMode CardanoMode) ChainPoint (QueryInMode CardanoMode) IO () singleQuery mPointVar' resultVar' = LocalStateQueryClient $ do pure $ @@ -600,10 +601,10 @@ queryNodeLocalState connctInfo mpoint query = do pure $ Net.Query.SendMsgDone () } -submitTxToNodeLocal :: forall mode. - LocalNodeConnectInfo mode - -> TxInMode mode - -> IO (Net.Tx.SubmitResult (TxValidationErrorInMode mode)) +submitTxToNodeLocal :: () + => LocalNodeConnectInfo CardanoMode + -> TxInMode CardanoMode + -> IO (Net.Tx.SubmitResult (TxValidationErrorInMode CardanoMode)) submitTxToNodeLocal connctInfo tx = do resultVar <- newEmptyTMVarIO connectToLocalNode @@ -616,11 +617,9 @@ submitTxToNodeLocal connctInfo tx = do } atomically (takeTMVar resultVar) where - localTxSubmissionClientSingle - :: TMVar (Net.Tx.SubmitResult (TxValidationErrorInMode mode)) - -> Net.Tx.LocalTxSubmissionClient (TxInMode mode) - (TxValidationErrorInMode mode) - IO () + localTxSubmissionClientSingle :: () + => TMVar (Net.Tx.SubmitResult (TxValidationErrorInMode CardanoMode)) + -> Net.Tx.LocalTxSubmissionClient (TxInMode CardanoMode) (TxValidationErrorInMode CardanoMode) IO () localTxSubmissionClientSingle resultVar = LocalTxSubmissionClient $ pure $ Net.Tx.SendMsgSubmitTx tx $ \result -> do @@ -686,10 +685,10 @@ data LocalTxMonitoringQuery mode | LocalTxMonitoringMempoolInformation -queryTxMonitoringLocal - :: forall mode. LocalNodeConnectInfo mode - -> LocalTxMonitoringQuery mode - -> IO (LocalTxMonitoringResult mode) +queryTxMonitoringLocal :: () + => LocalNodeConnectInfo CardanoMode + -> LocalTxMonitoringQuery CardanoMode + -> IO (LocalTxMonitoringResult CardanoMode) queryTxMonitoringLocal connectInfo localTxMonitoringQuery = do resultVar <- newEmptyTMVarIO @@ -748,7 +747,9 @@ queryTxMonitoringLocal connectInfo localTxMonitoringQuery = do -- Get tip as 'ChainPoint' -- -getLocalChainTip :: LocalNodeConnectInfo mode -> IO ChainTip +getLocalChainTip :: () + => LocalNodeConnectInfo CardanoMode + -> IO ChainTip getLocalChainTip localNodeConInfo = do resultVar <- newEmptyTMVarIO connectToLocalNode diff --git a/cardano-api/internal/Cardano/Api/IPC/Monad.hs b/cardano-api/internal/Cardano/Api/IPC/Monad.hs index e4eadecd38..f9949777f8 100644 --- a/cardano-api/internal/Cardano/Api/IPC/Monad.hs +++ b/cardano-api/internal/Cardano/Api/IPC/Monad.hs @@ -41,9 +41,9 @@ newtype LocalStateQueryExpr block point query r m a = LocalStateQueryExpr -- | Execute a local state query expression. executeLocalStateQueryExpr - :: LocalNodeConnectInfo mode + :: LocalNodeConnectInfo CardanoMode -> Maybe ChainPoint - -> LocalStateQueryExpr (BlockInMode mode) ChainPoint (QueryInMode mode) () IO a + -> LocalStateQueryExpr (BlockInMode CardanoMode) ChainPoint (QueryInMode CardanoMode) () IO a -> IO (Either AcquiringFailure a) executeLocalStateQueryExpr connectInfo mpoint f = do tmvResultLocalState <- newEmptyTMVarIO diff --git a/cardano-api/internal/Cardano/Api/LedgerState.hs b/cardano-api/internal/Cardano/Api/LedgerState.hs index 2104f5ee06..d903254c65 100644 --- a/cardano-api/internal/Cardano/Api/LedgerState.hs +++ b/cardano-api/internal/Cardano/Api/LedgerState.hs @@ -426,7 +426,12 @@ foldBlocks nodeConfigFilePath socketPath validationMode state0 accumulate = do Nothing -> lift $ readIORef stateIORef where - protocols :: IORef a -> IORef (Maybe LedgerStateError) -> Env -> LedgerState -> LocalNodeClientProtocolsInMode CardanoMode + protocols :: () + => IORef a + -> IORef (Maybe LedgerStateError) + -> Env + -> LedgerState + -> LocalNodeClientProtocolsInMode protocols stateIORef errorIORef env ledgerState = LocalNodeClientProtocols { localChainSyncClient = LocalChainSyncClientPipelined (chainSyncClient 50 stateIORef errorIORef env ledgerState), From b1e3a95294f3e171db71acdd38a31ae6d4f9a510 Mon Sep 17 00:00:00 2001 From: John Ky Date: Tue, 31 Oct 2023 17:54:08 +1100 Subject: [PATCH 06/37] Compressed coding style for LocalNodeClientProtocols definition --- cardano-api/internal/Cardano/Api/IPC.hs | 39 ++++++++++--------------- 1 file changed, 16 insertions(+), 23 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/IPC.hs b/cardano-api/internal/Cardano/Api/IPC.hs index de2459885c..68af017031 100644 --- a/cardano-api/internal/Cardano/Api/IPC.hs +++ b/cardano-api/internal/Cardano/Api/IPC.hs @@ -145,19 +145,12 @@ import Data.Void (Void) -- 'connectToLocalNode'. -- data LocalNodeClientProtocols block point tip slot tx txid txerr query m = - LocalNodeClientProtocols { - localChainSyncClient - :: LocalChainSyncClient block point tip m - - , localTxSubmissionClient - :: Maybe (LocalTxSubmissionClient tx txerr m ()) - - , localStateQueryClient - :: Maybe (LocalStateQueryClient block point query m ()) - - , localTxMonitoringClient - :: Maybe (LocalTxMonitorClient txid tx slot m ()) - } + LocalNodeClientProtocols + { localChainSyncClient :: LocalChainSyncClient block point tip m + , localTxSubmissionClient :: Maybe (LocalTxSubmissionClient tx txerr m ()) + , localStateQueryClient :: Maybe (LocalStateQueryClient block point query m ()) + , localTxMonitoringClient :: Maybe (LocalTxMonitorClient txid tx slot m ()) + } data LocalChainSyncClient block point tip m = NoLocalChainSyncClient @@ -166,16 +159,16 @@ data LocalChainSyncClient block point tip m -- public, exported type LocalNodeClientProtocolsInMode = - LocalNodeClientProtocols - (BlockInMode CardanoMode) - ChainPoint - ChainTip - SlotNo - (TxInMode CardanoMode) - (TxIdInMode CardanoMode) - (TxValidationErrorInMode CardanoMode) - (QueryInMode CardanoMode) - IO + LocalNodeClientProtocols + (BlockInMode CardanoMode) + ChainPoint + ChainTip + SlotNo + (TxInMode CardanoMode) + (TxIdInMode CardanoMode) + (TxValidationErrorInMode CardanoMode) + (QueryInMode CardanoMode) + IO data LocalNodeConnectInfo mode = LocalNodeConnectInfo { From a3c70c70b344332a52f898d38cfa084e6fc4daf8 Mon Sep 17 00:00:00 2001 From: John Ky Date: Wed, 25 Oct 2023 22:24:43 +1100 Subject: [PATCH 07/37] Remove mode related type parameters from LocalNodeClientProtocols --- cardano-api/internal/Cardano/Api/IPC.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/cardano-api/internal/Cardano/Api/IPC.hs b/cardano-api/internal/Cardano/Api/IPC.hs index 68af017031..336915e981 100644 --- a/cardano-api/internal/Cardano/Api/IPC.hs +++ b/cardano-api/internal/Cardano/Api/IPC.hs @@ -149,7 +149,7 @@ data LocalNodeClientProtocols block point tip slot tx txid txerr query m = { localChainSyncClient :: LocalChainSyncClient block point tip m , localTxSubmissionClient :: Maybe (LocalTxSubmissionClient tx txerr m ()) , localStateQueryClient :: Maybe (LocalStateQueryClient block point query m ()) - , localTxMonitoringClient :: Maybe (LocalTxMonitorClient txid tx slot m ()) + , localTxMonitoringClient :: Maybe (LocalTxMonitorClient (TxIdInMode CardanoMode) tx slot m ()) } data LocalChainSyncClient block point tip m From 26e912991156bd655d9230989319f1cd86eeb9af Mon Sep 17 00:00:00 2001 From: John Ky Date: Tue, 31 Oct 2023 21:00:59 +1100 Subject: [PATCH 08/37] stuff --- cardano-api/internal/Cardano/Api/IPC.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/cardano-api/internal/Cardano/Api/IPC.hs b/cardano-api/internal/Cardano/Api/IPC.hs index 336915e981..68af017031 100644 --- a/cardano-api/internal/Cardano/Api/IPC.hs +++ b/cardano-api/internal/Cardano/Api/IPC.hs @@ -149,7 +149,7 @@ data LocalNodeClientProtocols block point tip slot tx txid txerr query m = { localChainSyncClient :: LocalChainSyncClient block point tip m , localTxSubmissionClient :: Maybe (LocalTxSubmissionClient tx txerr m ()) , localStateQueryClient :: Maybe (LocalStateQueryClient block point query m ()) - , localTxMonitoringClient :: Maybe (LocalTxMonitorClient (TxIdInMode CardanoMode) tx slot m ()) + , localTxMonitoringClient :: Maybe (LocalTxMonitorClient txid tx slot m ()) } data LocalChainSyncClient block point tip m From f57d03e1820bf3516e262b6b16e5430737947ece Mon Sep 17 00:00:00 2001 From: John Ky Date: Wed, 25 Oct 2023 22:33:34 +1100 Subject: [PATCH 09/37] Rename TxValidationErrorInMode to TxValidationErrorInCardanoMode and remove mode type parameter --- cardano-api/internal/Cardano/Api/IPC.hs | 23 ++++++------ cardano-api/internal/Cardano/Api/InMode.hs | 41 ++++++++++++---------- cardano-api/src/Cardano/Api.hs | 2 +- 3 files changed, 34 insertions(+), 32 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/IPC.hs b/cardano-api/internal/Cardano/Api/IPC.hs index 68af017031..1046a6397b 100644 --- a/cardano-api/internal/Cardano/Api/IPC.hs +++ b/cardano-api/internal/Cardano/Api/IPC.hs @@ -43,7 +43,7 @@ module Cardano.Api.IPC ( -- *** Local tx submission LocalTxSubmissionClient(..), TxInMode(..), - TxValidationErrorInMode(..), + TxValidationErrorInCardanoMode, TxValidationError, submitTxToNodeLocal, SubmitResult(..), @@ -166,7 +166,7 @@ type LocalNodeClientProtocolsInMode = SlotNo (TxInMode CardanoMode) (TxIdInMode CardanoMode) - (TxValidationErrorInMode CardanoMode) + TxValidationErrorInCardanoMode (QueryInMode CardanoMode) IO @@ -475,13 +475,12 @@ convLocalChainSyncClientPipelined mode = (fromConsensusBlock mode) (fromConsensusTip mode) -convLocalTxSubmissionClient - :: forall mode block m a. - (ConsensusBlockForMode mode ~ block, Functor m) - => ConsensusMode mode - -> LocalTxSubmissionClient (TxInMode mode) (TxValidationErrorInMode mode) m a - -> LocalTxSubmissionClient (Consensus.GenTx block) - (Consensus.ApplyTxErr block) m a +convLocalTxSubmissionClient :: forall block m a. () + => ConsensusBlockForMode CardanoMode ~ block + => Functor m + => ConsensusMode CardanoMode + -> LocalTxSubmissionClient (TxInMode CardanoMode) TxValidationErrorInCardanoMode m a + -> LocalTxSubmissionClient (Consensus.GenTx block) (Consensus.ApplyTxErr block) m a convLocalTxSubmissionClient mode = Net.Tx.mapLocalTxSubmissionClient toConsensusGenTx @@ -597,7 +596,7 @@ queryNodeLocalState connctInfo mpoint query = do submitTxToNodeLocal :: () => LocalNodeConnectInfo CardanoMode -> TxInMode CardanoMode - -> IO (Net.Tx.SubmitResult (TxValidationErrorInMode CardanoMode)) + -> IO (Net.Tx.SubmitResult TxValidationErrorInCardanoMode) submitTxToNodeLocal connctInfo tx = do resultVar <- newEmptyTMVarIO connectToLocalNode @@ -611,8 +610,8 @@ submitTxToNodeLocal connctInfo tx = do atomically (takeTMVar resultVar) where localTxSubmissionClientSingle :: () - => TMVar (Net.Tx.SubmitResult (TxValidationErrorInMode CardanoMode)) - -> Net.Tx.LocalTxSubmissionClient (TxInMode CardanoMode) (TxValidationErrorInMode CardanoMode) IO () + => TMVar (Net.Tx.SubmitResult TxValidationErrorInCardanoMode) + -> Net.Tx.LocalTxSubmissionClient (TxInMode CardanoMode) TxValidationErrorInCardanoMode IO () localTxSubmissionClientSingle resultVar = LocalTxSubmissionClient $ pure $ Net.Tx.SendMsgSubmitTx tx $ \result -> do diff --git a/cardano-api/internal/Cardano/Api/InMode.hs b/cardano-api/internal/Cardano/Api/InMode.hs index 955da3313a..1ccc7d0b1a 100644 --- a/cardano-api/internal/Cardano/Api/InMode.hs +++ b/cardano-api/internal/Cardano/Api/InMode.hs @@ -21,7 +21,7 @@ module Cardano.Api.InMode ( -- * Transaction validation errors TxValidationError(..), - TxValidationErrorInMode(..), + TxValidationErrorInCardanoMode(..), fromConsensusApplyTxErr, ) where @@ -271,53 +271,56 @@ instance Show (TxValidationError era) where -- -- This is used in the LocalStateQuery protocol. -- -data TxValidationErrorInMode mode where - TxValidationErrorInMode :: TxValidationError era - -> EraInMode era mode - -> TxValidationErrorInMode mode +data TxValidationErrorInCardanoMode where + TxValidationErrorInCardanoMode :: () + => TxValidationError era + -> EraInMode era CardanoMode + -> TxValidationErrorInCardanoMode - TxValidationEraMismatch :: EraMismatch - -> TxValidationErrorInMode mode + TxValidationEraMismatch :: () + => EraMismatch + -> TxValidationErrorInCardanoMode -deriving instance Show (TxValidationErrorInMode mode) +deriving instance Show TxValidationErrorInCardanoMode -fromConsensusApplyTxErr :: ConsensusBlockForMode mode ~ block - => ConsensusMode mode - -> Consensus.ApplyTxErr block - -> TxValidationErrorInMode mode +fromConsensusApplyTxErr :: () + => ConsensusBlockForMode CardanoMode ~ block + => ConsensusMode CardanoMode + -> Consensus.ApplyTxErr block + -> TxValidationErrorInCardanoMode fromConsensusApplyTxErr CardanoMode (Consensus.ApplyTxErrByron err) = - TxValidationErrorInMode + TxValidationErrorInCardanoMode (ByronTxValidationError err) ByronEraInCardanoMode fromConsensusApplyTxErr CardanoMode (Consensus.ApplyTxErrShelley err) = - TxValidationErrorInMode + TxValidationErrorInCardanoMode (ShelleyTxValidationError ShelleyBasedEraShelley err) ShelleyEraInCardanoMode fromConsensusApplyTxErr CardanoMode (Consensus.ApplyTxErrAllegra err) = - TxValidationErrorInMode + TxValidationErrorInCardanoMode (ShelleyTxValidationError ShelleyBasedEraAllegra err) AllegraEraInCardanoMode fromConsensusApplyTxErr CardanoMode (Consensus.ApplyTxErrMary err) = - TxValidationErrorInMode + TxValidationErrorInCardanoMode (ShelleyTxValidationError ShelleyBasedEraMary err) MaryEraInCardanoMode fromConsensusApplyTxErr CardanoMode (Consensus.ApplyTxErrAlonzo err) = - TxValidationErrorInMode + TxValidationErrorInCardanoMode (ShelleyTxValidationError ShelleyBasedEraAlonzo err) AlonzoEraInCardanoMode fromConsensusApplyTxErr CardanoMode (Consensus.ApplyTxErrBabbage err) = - TxValidationErrorInMode + TxValidationErrorInCardanoMode (ShelleyTxValidationError ShelleyBasedEraBabbage err) BabbageEraInCardanoMode fromConsensusApplyTxErr CardanoMode (Consensus.ApplyTxErrConway err) = - TxValidationErrorInMode + TxValidationErrorInCardanoMode (ShelleyTxValidationError ShelleyBasedEraConway err) ConwayEraInCardanoMode diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs index 22871c8e15..5b15056a52 100644 --- a/cardano-api/src/Cardano/Api.hs +++ b/cardano-api/src/Cardano/Api.hs @@ -824,7 +824,7 @@ module Cardano.Api ( -- *** Local tx submission LocalTxSubmissionClient(..), TxInMode(..), - TxValidationErrorInMode(..), + TxValidationErrorInCardanoMode(..), SubmitResult(..), submitTxToNodeLocal, From 9d6c1c5096b45bf3305b4444ae3113e1668b1429 Mon Sep 17 00:00:00 2001 From: John Ky Date: Wed, 25 Oct 2023 22:41:44 +1100 Subject: [PATCH 10/37] Deparameterise LocalNodeConnectInfo --- .../internal/Cardano/Api/Convenience/Query.hs | 6 +++--- cardano-api/internal/Cardano/Api/IPC.hs | 20 ++++++++++--------- cardano-api/internal/Cardano/Api/IPC/Monad.hs | 4 ++-- .../internal/Cardano/Api/LedgerState.hs | 12 +++++------ 4 files changed, 21 insertions(+), 21 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/Convenience/Query.hs b/cardano-api/internal/Cardano/Api/Convenience/Query.hs index bb99dccb98..84f551d624 100644 --- a/cardano-api/internal/Cardano/Api/Convenience/Query.hs +++ b/cardano-api/internal/Cardano/Api/Convenience/Query.hs @@ -136,8 +136,8 @@ queryStateForBalancedTx era allTxIns certs = runExceptT $ do -- | Query the node to determine which era it is in. determineEra :: () - => ConsensusModeParams mode - -> LocalNodeConnectInfo mode + => ConsensusModeParams CardanoMode + -> LocalNodeConnectInfo -> IO (Either AcquiringFailure AnyCardanoEra) determineEra cModeParams localNodeConnInfo = case consensusModeOnly cModeParams of @@ -163,7 +163,7 @@ executeQueryCardanoMode socketPath nid q = runExceptT $ do -- | Execute a query against the local node in any mode. executeQueryAnyMode :: forall result. () - => LocalNodeConnectInfo CardanoMode + => LocalNodeConnectInfo -> QueryInMode CardanoMode (Either EraMismatch result) -> IO (Either QueryConvenienceError result) executeQueryAnyMode localNodeConnInfo q = runExceptT $ do diff --git a/cardano-api/internal/Cardano/Api/IPC.hs b/cardano-api/internal/Cardano/Api/IPC.hs index 1046a6397b..056fc968cb 100644 --- a/cardano-api/internal/Cardano/Api/IPC.hs +++ b/cardano-api/internal/Cardano/Api/IPC.hs @@ -170,14 +170,16 @@ type LocalNodeClientProtocolsInMode = (QueryInMode CardanoMode) IO -data LocalNodeConnectInfo mode = +data LocalNodeConnectInfo = LocalNodeConnectInfo { - localConsensusModeParams :: ConsensusModeParams mode, + localConsensusModeParams :: ConsensusModeParams CardanoMode, localNodeNetworkId :: NetworkId, localNodeSocketPath :: SocketPath } -localConsensusMode :: LocalNodeConnectInfo mode -> ConsensusMode mode +localConsensusMode :: () + => LocalNodeConnectInfo + -> ConsensusMode CardanoMode localConsensusMode LocalNodeConnectInfo {localConsensusModeParams} = consensusModeOnly localConsensusModeParams @@ -194,7 +196,7 @@ consensusModeOnly CardanoModeParams{} = CardanoMode -- protocol handlers. -- connectToLocalNode :: () - => LocalNodeConnectInfo CardanoMode + => LocalNodeConnectInfo -> LocalNodeClientProtocolsInMode -> IO () connectToLocalNode localNodeConnectInfo handlers @@ -205,7 +207,7 @@ connectToLocalNode localNodeConnectInfo handlers -- version. -- connectToLocalNodeWithVersion :: () - => LocalNodeConnectInfo CardanoMode + => LocalNodeConnectInfo -> (NodeToClientVersion -> LocalNodeClientProtocolsInMode) -> IO () connectToLocalNodeWithVersion LocalNodeConnectInfo { @@ -554,7 +556,7 @@ toAcquiringFailure AcquireFailurePointTooOld = AFPointTooOld toAcquiringFailure AcquireFailurePointNotOnChain = AFPointNotOnChain queryNodeLocalState :: forall result. () - => LocalNodeConnectInfo CardanoMode + => LocalNodeConnectInfo -> Maybe ChainPoint -> QueryInMode CardanoMode result -> IO (Either AcquiringFailure result) @@ -594,7 +596,7 @@ queryNodeLocalState connctInfo mpoint query = do } submitTxToNodeLocal :: () - => LocalNodeConnectInfo CardanoMode + => LocalNodeConnectInfo -> TxInMode CardanoMode -> IO (Net.Tx.SubmitResult TxValidationErrorInCardanoMode) submitTxToNodeLocal connctInfo tx = do @@ -678,7 +680,7 @@ data LocalTxMonitoringQuery mode queryTxMonitoringLocal :: () - => LocalNodeConnectInfo CardanoMode + => LocalNodeConnectInfo -> LocalTxMonitoringQuery CardanoMode -> IO (LocalTxMonitoringResult CardanoMode) queryTxMonitoringLocal connectInfo localTxMonitoringQuery = do @@ -740,7 +742,7 @@ queryTxMonitoringLocal connectInfo localTxMonitoringQuery = do -- getLocalChainTip :: () - => LocalNodeConnectInfo CardanoMode + => LocalNodeConnectInfo -> IO ChainTip getLocalChainTip localNodeConInfo = do resultVar <- newEmptyTMVarIO diff --git a/cardano-api/internal/Cardano/Api/IPC/Monad.hs b/cardano-api/internal/Cardano/Api/IPC/Monad.hs index f9949777f8..4dba3a1541 100644 --- a/cardano-api/internal/Cardano/Api/IPC/Monad.hs +++ b/cardano-api/internal/Cardano/Api/IPC/Monad.hs @@ -40,8 +40,8 @@ newtype LocalStateQueryExpr block point query r m a = LocalStateQueryExpr } deriving (Functor, Applicative, Monad, MonadReader NodeToClientVersion, MonadIO) -- | Execute a local state query expression. -executeLocalStateQueryExpr - :: LocalNodeConnectInfo CardanoMode +executeLocalStateQueryExpr :: () + => LocalNodeConnectInfo -> Maybe ChainPoint -> LocalStateQueryExpr (BlockInMode CardanoMode) ChainPoint (QueryInMode CardanoMode) () IO a -> IO (Either AcquiringFailure a) diff --git a/cardano-api/internal/Cardano/Api/LedgerState.hs b/cardano-api/internal/Cardano/Api/LedgerState.hs index d903254c65..885de8fa72 100644 --- a/cardano-api/internal/Cardano/Api/LedgerState.hs +++ b/cardano-api/internal/Cardano/Api/LedgerState.hs @@ -409,13 +409,11 @@ foldBlocks nodeConfigFilePath socketPath validationMode state0 accumulate = do cardanoModeParams = CardanoModeParams . EpochSlots $ 10 * envSecurityParam env -- Connect to the node. - let connectInfo :: LocalNodeConnectInfo CardanoMode - connectInfo = - LocalNodeConnectInfo { - localConsensusModeParams = cardanoModeParams, - localNodeNetworkId = networkId', - localNodeSocketPath = socketPath - } + let connectInfo = LocalNodeConnectInfo + { localConsensusModeParams = cardanoModeParams + , localNodeNetworkId = networkId' + , localNodeSocketPath = socketPath + } lift $ connectToLocalNode connectInfo From 9aca53bf7e4427ae53425bef702f695c416b76eb Mon Sep 17 00:00:00 2001 From: John Ky Date: Wed, 25 Oct 2023 22:45:56 +1100 Subject: [PATCH 11/37] Deparameterise LocalTxMonitoringQuery and LocalTxMonitoringResult --- cardano-api/internal/Cardano/Api/IPC.hs | 42 +++++++++++----------- cardano-api/internal/Cardano/Api/InMode.hs | 6 ++-- 2 files changed, 24 insertions(+), 24 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/IPC.hs b/cardano-api/internal/Cardano/Api/IPC.hs index 056fc968cb..904c1075d5 100644 --- a/cardano-api/internal/Cardano/Api/IPC.hs +++ b/cardano-api/internal/Cardano/Api/IPC.hs @@ -440,11 +440,11 @@ convLocalNodeClientProtocols localTxMonitoringClientForBlock = convLocalTxMonitoringClient mode <$> localTxMonitoringClient } -convLocalTxMonitoringClient - :: forall mode block m a. ConsensusBlockForMode mode ~ block +convLocalTxMonitoringClient :: forall block m a. () + => ConsensusBlockForMode CardanoMode ~ block => Functor m - => ConsensusMode mode - -> LocalTxMonitorClient (TxIdInMode mode) (TxInMode mode) SlotNo m a + => ConsensusMode CardanoMode + -> LocalTxMonitorClient (TxIdInMode CardanoMode) (TxInMode CardanoMode) SlotNo m a -> LocalTxMonitorClient (Consensus.TxId (Consensus.GenTx block)) (Consensus.GenTx block) SlotNo m a convLocalTxMonitoringClient mode = mapLocalTxMonitoringClient @@ -621,7 +621,7 @@ submitTxToNodeLocal connctInfo tx = do pure (Net.Tx.SendMsgDone ()) -data LocalTxMonitoringResult mode +data LocalTxMonitoringResult = LocalTxMonitoringTxExists TxId SlotNo -- ^ Slot number at which the mempool snapshot was taken @@ -629,13 +629,13 @@ data LocalTxMonitoringResult mode TxId SlotNo -- ^ Slot number at which the mempool snapshot was taken | LocalTxMonitoringNextTx - (Maybe (TxInMode mode)) + (Maybe (TxInMode CardanoMode)) SlotNo -- ^ Slot number at which the mempool snapshot was taken | LocalTxMonitoringMempoolSizeAndCapacity Consensus.MempoolSizeAndCapacity SlotNo -- ^ Slot number at which the mempool snapshot was taken -instance ToJSON (LocalTxMonitoringResult mode) where +instance ToJSON LocalTxMonitoringResult where toJSON result = object $ case result of LocalTxMonitoringTxExists tx slot -> @@ -664,11 +664,11 @@ instance ToJSON (LocalTxMonitoringResult mode) where , "slot" .= slot ] -data LocalTxMonitoringQuery mode +data LocalTxMonitoringQuery -- | Query if a particular tx exists in the mempool. Note that, the absence -- of a transaction does not imply anything about how the transaction was -- processed: it may have been dropped, or inserted in a block. - = LocalTxMonitoringQueryTx (TxIdInMode mode) + = LocalTxMonitoringQueryTx (TxIdInMode CardanoMode) -- | The mempool is modeled as an ordered list of transactions and thus, can -- be traversed linearly. 'LocalTxMonitoringSendNextTx' requests the next transaction from the -- current list. This must be a transaction that was not previously sent to @@ -681,8 +681,8 @@ data LocalTxMonitoringQuery mode queryTxMonitoringLocal :: () => LocalNodeConnectInfo - -> LocalTxMonitoringQuery CardanoMode - -> IO (LocalTxMonitoringResult CardanoMode) + -> LocalTxMonitoringQuery + -> IO LocalTxMonitoringResult queryTxMonitoringLocal connectInfo localTxMonitoringQuery = do resultVar <- newEmptyTMVarIO @@ -704,10 +704,10 @@ queryTxMonitoringLocal connectInfo localTxMonitoringQuery = do } atomically (takeTMVar resultVar) where - localTxMonitorClientTxExists - :: TxIdInMode mode - -> TMVar (LocalTxMonitoringResult mode) - -> LocalTxMonitorClient (TxIdInMode mode) (TxInMode mode) SlotNo IO () + localTxMonitorClientTxExists :: () + => TxIdInMode CardanoMode + -> TMVar LocalTxMonitoringResult + -> LocalTxMonitorClient (TxIdInMode CardanoMode) (TxInMode CardanoMode) SlotNo IO () localTxMonitorClientTxExists tIdInMode@(TxIdInMode txid _) resultVar = do LocalTxMonitorClient $ return $ CTxMon.SendMsgAcquire $ \slt -> do @@ -717,9 +717,9 @@ queryTxMonitoringLocal connectInfo localTxMonitoringQuery = do else atomically . putTMVar resultVar $ LocalTxMonitoringTxDoesNotExist txid slt return $ CTxMon.SendMsgRelease $ return $ CTxMon.SendMsgDone () - localTxMonitorNextTx - :: TMVar (LocalTxMonitoringResult mode) - -> LocalTxMonitorClient (TxIdInMode mode) (TxInMode mode) SlotNo IO () + localTxMonitorNextTx :: () + => TMVar LocalTxMonitoringResult + -> LocalTxMonitorClient (TxIdInMode CardanoMode) (TxInMode CardanoMode) SlotNo IO () localTxMonitorNextTx resultVar = LocalTxMonitorClient $ return $ do CTxMon.SendMsgAcquire $ \slt -> do @@ -727,9 +727,9 @@ queryTxMonitoringLocal connectInfo localTxMonitoringQuery = do atomically $ putTMVar resultVar $ LocalTxMonitoringNextTx mTx slt return $ CTxMon.SendMsgRelease $ return $ CTxMon.SendMsgDone () - localTxMonitorMempoolInfo - :: TMVar (LocalTxMonitoringResult mode) - -> LocalTxMonitorClient (TxIdInMode mode) (TxInMode mode) SlotNo IO () + localTxMonitorMempoolInfo :: () + => TMVar LocalTxMonitoringResult + -> LocalTxMonitorClient (TxIdInMode CardanoMode) (TxInMode CardanoMode) SlotNo IO () localTxMonitorMempoolInfo resultVar = LocalTxMonitorClient $ return $ do CTxMon.SendMsgAcquire $ \slt -> do diff --git a/cardano-api/internal/Cardano/Api/InMode.hs b/cardano-api/internal/Cardano/Api/InMode.hs index 1ccc7d0b1a..d1b1ba1154 100644 --- a/cardano-api/internal/Cardano/Api/InMode.hs +++ b/cardano-api/internal/Cardano/Api/InMode.hs @@ -159,9 +159,9 @@ toConsensusGenTx (TxInMode (ShelleyTx _ _) ByronEraInCardanoMode) = data TxIdInMode mode where TxIdInMode :: TxId -> EraInMode era mode -> TxIdInMode mode -toConsensusTxId - :: ConsensusBlockForMode mode ~ block - => TxIdInMode mode -> Consensus.TxId (Consensus.GenTx block) +toConsensusTxId :: () + => ConsensusBlockForMode CardanoMode ~ block + => TxIdInMode CardanoMode -> Consensus.TxId (Consensus.GenTx block) toConsensusTxId (TxIdInMode txid ByronEraInCardanoMode) = Consensus.HardForkGenTxId . Consensus.OneEraGenTxId . Z $ Consensus.WrapGenTxId txid' where From 0a9005d0b33031e43686ccbf8d9da3910f03961d Mon Sep 17 00:00:00 2001 From: John Ky Date: Wed, 25 Oct 2023 22:53:35 +1100 Subject: [PATCH 12/37] Deparameterise TxInMode --- cardano-api/internal/Cardano/Api/IPC.hs | 18 ++++----- cardano-api/internal/Cardano/Api/InMode.hs | 43 +++++++++++++--------- 2 files changed, 34 insertions(+), 27 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/IPC.hs b/cardano-api/internal/Cardano/Api/IPC.hs index 904c1075d5..26c9edcd71 100644 --- a/cardano-api/internal/Cardano/Api/IPC.hs +++ b/cardano-api/internal/Cardano/Api/IPC.hs @@ -164,7 +164,7 @@ type LocalNodeClientProtocolsInMode = ChainPoint ChainTip SlotNo - (TxInMode CardanoMode) + TxInMode (TxIdInMode CardanoMode) TxValidationErrorInCardanoMode (QueryInMode CardanoMode) @@ -444,7 +444,7 @@ convLocalTxMonitoringClient :: forall block m a. () => ConsensusBlockForMode CardanoMode ~ block => Functor m => ConsensusMode CardanoMode - -> LocalTxMonitorClient (TxIdInMode CardanoMode) (TxInMode CardanoMode) SlotNo m a + -> LocalTxMonitorClient (TxIdInMode CardanoMode) TxInMode SlotNo m a -> LocalTxMonitorClient (Consensus.TxId (Consensus.GenTx block)) (Consensus.GenTx block) SlotNo m a convLocalTxMonitoringClient mode = mapLocalTxMonitoringClient @@ -481,7 +481,7 @@ convLocalTxSubmissionClient :: forall block m a. () => ConsensusBlockForMode CardanoMode ~ block => Functor m => ConsensusMode CardanoMode - -> LocalTxSubmissionClient (TxInMode CardanoMode) TxValidationErrorInCardanoMode m a + -> LocalTxSubmissionClient TxInMode TxValidationErrorInCardanoMode m a -> LocalTxSubmissionClient (Consensus.GenTx block) (Consensus.ApplyTxErr block) m a convLocalTxSubmissionClient mode = Net.Tx.mapLocalTxSubmissionClient @@ -597,7 +597,7 @@ queryNodeLocalState connctInfo mpoint query = do submitTxToNodeLocal :: () => LocalNodeConnectInfo - -> TxInMode CardanoMode + -> TxInMode -> IO (Net.Tx.SubmitResult TxValidationErrorInCardanoMode) submitTxToNodeLocal connctInfo tx = do resultVar <- newEmptyTMVarIO @@ -613,7 +613,7 @@ submitTxToNodeLocal connctInfo tx = do where localTxSubmissionClientSingle :: () => TMVar (Net.Tx.SubmitResult TxValidationErrorInCardanoMode) - -> Net.Tx.LocalTxSubmissionClient (TxInMode CardanoMode) TxValidationErrorInCardanoMode IO () + -> Net.Tx.LocalTxSubmissionClient TxInMode TxValidationErrorInCardanoMode IO () localTxSubmissionClientSingle resultVar = LocalTxSubmissionClient $ pure $ Net.Tx.SendMsgSubmitTx tx $ \result -> do @@ -629,7 +629,7 @@ data LocalTxMonitoringResult TxId SlotNo -- ^ Slot number at which the mempool snapshot was taken | LocalTxMonitoringNextTx - (Maybe (TxInMode CardanoMode)) + (Maybe TxInMode) SlotNo -- ^ Slot number at which the mempool snapshot was taken | LocalTxMonitoringMempoolSizeAndCapacity Consensus.MempoolSizeAndCapacity @@ -707,7 +707,7 @@ queryTxMonitoringLocal connectInfo localTxMonitoringQuery = do localTxMonitorClientTxExists :: () => TxIdInMode CardanoMode -> TMVar LocalTxMonitoringResult - -> LocalTxMonitorClient (TxIdInMode CardanoMode) (TxInMode CardanoMode) SlotNo IO () + -> LocalTxMonitorClient (TxIdInMode CardanoMode) TxInMode SlotNo IO () localTxMonitorClientTxExists tIdInMode@(TxIdInMode txid _) resultVar = do LocalTxMonitorClient $ return $ CTxMon.SendMsgAcquire $ \slt -> do @@ -719,7 +719,7 @@ queryTxMonitoringLocal connectInfo localTxMonitoringQuery = do localTxMonitorNextTx :: () => TMVar LocalTxMonitoringResult - -> LocalTxMonitorClient (TxIdInMode CardanoMode) (TxInMode CardanoMode) SlotNo IO () + -> LocalTxMonitorClient (TxIdInMode CardanoMode) TxInMode SlotNo IO () localTxMonitorNextTx resultVar = LocalTxMonitorClient $ return $ do CTxMon.SendMsgAcquire $ \slt -> do @@ -729,7 +729,7 @@ queryTxMonitoringLocal connectInfo localTxMonitoringQuery = do localTxMonitorMempoolInfo :: () => TMVar LocalTxMonitoringResult - -> LocalTxMonitorClient (TxIdInMode CardanoMode) (TxInMode CardanoMode) SlotNo IO () + -> LocalTxMonitorClient (TxIdInMode CardanoMode) TxInMode SlotNo IO () localTxMonitorMempoolInfo resultVar = LocalTxMonitorClient $ return $ do CTxMon.SendMsgAcquire $ \slt -> do diff --git a/cardano-api/internal/Cardano/Api/InMode.hs b/cardano-api/internal/Cardano/Api/InMode.hs index d1b1ba1154..fc6e176cc7 100644 --- a/cardano-api/internal/Cardano/Api/InMode.hs +++ b/cardano-api/internal/Cardano/Api/InMode.hs @@ -54,24 +54,30 @@ import Data.SOP.Strict (NS (S, Z)) -- different transaction types for all the eras. It is used in the -- LocalTxSubmission protocol. -- -data TxInMode mode where - - -- | Everything we consider a normal transaction. - -- - TxInMode :: Tx era -> EraInMode era mode -> TxInMode mode +data TxInMode where + -- | Everything we consider a normal transaction. + -- + TxInMode + :: Tx era + -> EraInMode era CardanoMode + -> TxInMode - -- | Byron has various things we can post to the chain which are not - -- actually transactions. This covers: update proposals, votes and - -- delegation certs. - -- - TxInByronSpecial :: Consensus.GenTx Consensus.ByronBlock - -> EraInMode ByronEra mode -> TxInMode mode + -- | Byron has various things we can post to the chain which are not + -- actually transactions. This covers: update proposals, votes and + -- delegation certs. + -- + TxInByronSpecial + :: Consensus.GenTx Consensus.ByronBlock + -> EraInMode ByronEra CardanoMode + -> TxInMode -deriving instance Show (TxInMode mode) +deriving instance Show TxInMode -fromConsensusGenTx - :: ConsensusBlockForMode mode ~ block - => ConsensusMode mode -> Consensus.GenTx block -> TxInMode mode +fromConsensusGenTx :: () + => ConsensusBlockForMode CardanoMode ~ block + => ConsensusMode CardanoMode + -> Consensus.GenTx block + -> TxInMode fromConsensusGenTx CardanoMode (Consensus.HardForkGenTx (Consensus.OneEraGenTx (Z tx'))) = TxInByronSpecial tx' ByronEraInCardanoMode @@ -99,9 +105,10 @@ fromConsensusGenTx CardanoMode (Consensus.HardForkGenTx (Consensus.OneEraGenTx ( let Consensus.ShelleyTx _txid shelleyEraTx = tx' in TxInMode (ShelleyTx ShelleyBasedEraConway shelleyEraTx) ConwayEraInCardanoMode -toConsensusGenTx :: ConsensusBlockForMode mode ~ block - => TxInMode mode - -> Consensus.GenTx block +toConsensusGenTx :: () + => ConsensusBlockForMode CardanoMode ~ block + => TxInMode + -> Consensus.GenTx block toConsensusGenTx (TxInMode (ByronTx ByronEraOnlyByron tx) ByronEraInCardanoMode) = Consensus.HardForkGenTx (Consensus.OneEraGenTx (Z tx')) where From 9d6cb47cafdc82b1f2136100a52c74c54c08229b Mon Sep 17 00:00:00 2001 From: John Ky Date: Thu, 26 Oct 2023 21:58:11 +1100 Subject: [PATCH 13/37] Deparameterise mode in functions --- cardano-api/internal/Cardano/Api/Block.hs | 28 +++--- cardano-api/internal/Cardano/Api/IPC.hs | 35 +++---- cardano-api/internal/Cardano/Api/IPC/Monad.hs | 8 +- cardano-api/internal/Cardano/Api/Modes.hs | 4 +- cardano-api/internal/Cardano/Api/Query.hs | 32 +++---- .../internal/Cardano/Api/Query/Expr.hs | 96 +++++++++---------- .../cardano-api-test/Test/Cardano/Api/Json.hs | 2 +- 7 files changed, 102 insertions(+), 103 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/Block.hs b/cardano-api/internal/Cardano/Api/Block.hs index e754519f16..aaf1ab141d 100644 --- a/cardano-api/internal/Cardano/Api/Block.hs +++ b/cardano-api/internal/Cardano/Api/Block.hs @@ -204,10 +204,10 @@ data BlockInMode mode where deriving instance Show (BlockInMode mode) fromConsensusBlock :: () - => ConsensusBlockForMode mode ~ block - => ConsensusMode mode + => ConsensusBlockForMode CardanoMode ~ block + => ConsensusMode CardanoMode -> block - -> BlockInMode mode + -> BlockInMode CardanoMode fromConsensusBlock CardanoMode = \case Consensus.BlockByron b' -> BlockInMode cardanoEra (ByronBlock b') ByronEraInCardanoMode @@ -237,19 +237,17 @@ fromConsensusBlock CardanoMode = \case ConwayEraInCardanoMode toConsensusBlock :: () - => ConsensusBlockForMode mode ~ block - => BlockInMode mode -> block + => ConsensusBlockForMode CardanoMode ~ block + => BlockInMode CardanoMode + -> block toConsensusBlock = \case - -- Byron mode - - -- Cardano mode - BlockInMode _ (ByronBlock b') ByronEraInCardanoMode -> Consensus.BlockByron b' - BlockInMode _ (ShelleyBlock ShelleyBasedEraShelley b') ShelleyEraInCardanoMode -> Consensus.BlockShelley b' - BlockInMode _ (ShelleyBlock ShelleyBasedEraAllegra b') AllegraEraInCardanoMode -> Consensus.BlockAllegra b' - BlockInMode _ (ShelleyBlock ShelleyBasedEraMary b') MaryEraInCardanoMode -> Consensus.BlockMary b' - BlockInMode _ (ShelleyBlock ShelleyBasedEraAlonzo b') AlonzoEraInCardanoMode -> Consensus.BlockAlonzo b' - BlockInMode _ (ShelleyBlock ShelleyBasedEraBabbage b') BabbageEraInCardanoMode -> Consensus.BlockBabbage b' - BlockInMode _ (ShelleyBlock ShelleyBasedEraConway b') ConwayEraInCardanoMode -> Consensus.BlockConway b' + BlockInMode _ (ByronBlock b') ByronEraInCardanoMode -> Consensus.BlockByron b' + BlockInMode _ (ShelleyBlock ShelleyBasedEraShelley b') ShelleyEraInCardanoMode -> Consensus.BlockShelley b' + BlockInMode _ (ShelleyBlock ShelleyBasedEraAllegra b') AllegraEraInCardanoMode -> Consensus.BlockAllegra b' + BlockInMode _ (ShelleyBlock ShelleyBasedEraMary b') MaryEraInCardanoMode -> Consensus.BlockMary b' + BlockInMode _ (ShelleyBlock ShelleyBasedEraAlonzo b') AlonzoEraInCardanoMode -> Consensus.BlockAlonzo b' + BlockInMode _ (ShelleyBlock ShelleyBasedEraBabbage b') BabbageEraInCardanoMode -> Consensus.BlockBabbage b' + BlockInMode _ (ShelleyBlock ShelleyBasedEraConway b') ConwayEraInCardanoMode -> Consensus.BlockConway b' -- ---------------------------------------------------------------------------- -- Block headers diff --git a/cardano-api/internal/Cardano/Api/IPC.hs b/cardano-api/internal/Cardano/Api/IPC.hs index 26c9edcd71..c1ca079a0f 100644 --- a/cardano-api/internal/Cardano/Api/IPC.hs +++ b/cardano-api/internal/Cardano/Api/IPC.hs @@ -183,11 +183,11 @@ localConsensusMode :: () localConsensusMode LocalNodeConnectInfo {localConsensusModeParams} = consensusModeOnly localConsensusModeParams -consensusModeOnly :: ConsensusModeParams mode - -> ConsensusMode mode +consensusModeOnly :: () + => ConsensusModeParams CardanoMode + -> ConsensusMode CardanoMode consensusModeOnly CardanoModeParams{} = CardanoMode - -- ---------------------------------------------------------------------------- -- Actually connect to the node -- @@ -452,10 +452,11 @@ convLocalTxMonitoringClient mode = (fromConsensusGenTx mode) convLocalChainSyncClient - :: forall mode block m a. - (ConsensusBlockForMode mode ~ block, Functor m) - => ConsensusMode mode - -> ChainSyncClient (BlockInMode mode) ChainPoint ChainTip m a + :: forall block m a. () + => ConsensusBlockForMode CardanoMode ~ block + => Functor m + => ConsensusMode CardanoMode + -> ChainSyncClient (BlockInMode CardanoMode) ChainPoint ChainTip m a -> ChainSyncClient block (Net.Point block) (Net.Tip block) m a convLocalChainSyncClient mode = Net.Sync.mapChainSyncClient @@ -464,11 +465,11 @@ convLocalChainSyncClient mode = (fromConsensusBlock mode) (fromConsensusTip mode) -convLocalChainSyncClientPipelined - :: forall mode block m a. - (ConsensusBlockForMode mode ~ block, Functor m) - => ConsensusMode mode - -> ChainSyncClientPipelined (BlockInMode mode) ChainPoint ChainTip m a +convLocalChainSyncClientPipelined :: forall block m a. () + => ConsensusBlockForMode CardanoMode ~ block + => Functor m + => ConsensusMode CardanoMode + -> ChainSyncClientPipelined (BlockInMode CardanoMode) ChainPoint ChainTip m a -> ChainSyncClientPipelined block (Net.Point block) (Net.Tip block) m a convLocalChainSyncClientPipelined mode = mapChainSyncClientPipelined @@ -504,8 +505,8 @@ convLocalStateQueryClient mode = --TODO: Move to consensus -mapLocalTxMonitoringClient - :: forall txid txid' tx tx' m a. Functor m +mapLocalTxMonitoringClient :: forall txid txid' tx tx' m a. () + => Functor m => (txid -> txid') -> (tx'-> tx) -> LocalTxMonitorClient txid tx SlotNo m a @@ -756,9 +757,9 @@ getLocalChainTip localNodeConInfo = do } atomically $ takeTMVar resultVar -chainSyncGetCurrentTip - :: forall mode. TMVar ChainTip - -> ChainSyncClient (BlockInMode mode) ChainPoint ChainTip IO () +chainSyncGetCurrentTip :: () + => TMVar ChainTip + -> ChainSyncClient (BlockInMode CardanoMode) ChainPoint ChainTip IO () chainSyncGetCurrentTip tipVar = ChainSyncClient $ pure clientStIdle where diff --git a/cardano-api/internal/Cardano/Api/IPC/Monad.hs b/cardano-api/internal/Cardano/Api/IPC/Monad.hs index 4dba3a1541..eb2ba5b918 100644 --- a/cardano-api/internal/Cardano/Api/IPC/Monad.hs +++ b/cardano-api/internal/Cardano/Api/IPC/Monad.hs @@ -71,8 +71,8 @@ setupLocalStateQueryExpr :: -> Maybe ChainPoint -> TMVar (Either AcquiringFailure a) -> NodeToClientVersion - -> LocalStateQueryExpr (BlockInMode mode) ChainPoint (QueryInMode mode) () IO a - -> Net.Query.LocalStateQueryClient (BlockInMode mode) ChainPoint (QueryInMode mode) IO () + -> LocalStateQueryExpr (BlockInMode CardanoMode) ChainPoint (QueryInMode CardanoMode) () IO a + -> Net.Query.LocalStateQueryClient (BlockInMode CardanoMode) ChainPoint (QueryInMode CardanoMode) IO () setupLocalStateQueryExpr waitDone mPointVar' resultVar' ntcVersion f = LocalStateQueryClient . pure . Net.Query.SendMsgAcquire mPointVar' $ Net.Query.ClientStAcquiring @@ -88,11 +88,11 @@ setupLocalStateQueryExpr waitDone mPointVar' resultVar' ntcVersion f = } -- | Get the node server's Node-to-Client version. -getNtcVersion :: LocalStateQueryExpr block point (QueryInMode mode) r IO NodeToClientVersion +getNtcVersion :: LocalStateQueryExpr block point (QueryInMode CardanoMode) 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 (Either UnsupportedNtcVersionError a) +queryExpr :: QueryInMode CardanoMode a -> LocalStateQueryExpr block point (QueryInMode CardanoMode) r IO (Either UnsupportedNtcVersionError a) queryExpr q = do let minNtcVersion = nodeToClientVersionOf q ntcVersion <- getNtcVersion diff --git a/cardano-api/internal/Cardano/Api/Modes.hs b/cardano-api/internal/Cardano/Api/Modes.hs index 6d6e13cae8..4f95953f24 100644 --- a/cardano-api/internal/Cardano/Api/Modes.hs +++ b/cardano-api/internal/Cardano/Api/Modes.hs @@ -96,7 +96,7 @@ deriving instance Show AnyConsensusMode renderMode :: AnyConsensusMode -> Text renderMode (AnyConsensusMode CardanoMode) = "CardanoMode" -toEraInMode :: CardanoEra era -> ConsensusMode mode -> Maybe (EraInMode era mode) +toEraInMode :: CardanoEra era -> ConsensusMode CardanoMode -> Maybe (EraInMode era CardanoMode) toEraInMode ByronEra CardanoMode = Just ByronEraInCardanoMode toEraInMode ShelleyEra CardanoMode = Just ShelleyEraInCardanoMode toEraInMode AllegraEra CardanoMode = Just AllegraEraInCardanoMode @@ -289,7 +289,7 @@ toConsensusEraIndex = \case fromConsensusEraIndex :: () - => ConsensusMode mode + => ConsensusMode CardanoMode -> Consensus.EraIndex (Consensus.CardanoEras StandardCrypto) -> AnyCardanoEra fromConsensusEraIndex CardanoMode = \case diff --git a/cardano-api/internal/Cardano/Api/Query.hs b/cardano-api/internal/Cardano/Api/Query.hs index 5117b0e3a7..4a6d470894 100644 --- a/cardano-api/internal/Cardano/Api/Query.hs +++ b/cardano-api/internal/Cardano/Api/Query.hs @@ -189,18 +189,18 @@ data EraHistory mode where -> History.Interpreter xs -> EraHistory mode -getProgress :: SlotNo -> EraHistory mode -> Either Qry.PastHorizonException (RelativeTime, SlotLength) +getProgress :: SlotNo -> EraHistory CardanoMode -> Either Qry.PastHorizonException (RelativeTime, SlotLength) getProgress slotNo (EraHistory _ interpreter) = Qry.interpretQuery interpreter (Qry.slotToWallclock slotNo) -- | Returns the slot number for provided relative time from 'SystemStart' -getSlotForRelativeTime :: RelativeTime -> EraHistory mode -> Either Qry.PastHorizonException SlotNo +getSlotForRelativeTime :: RelativeTime -> EraHistory CardanoMode -> Either Qry.PastHorizonException SlotNo getSlotForRelativeTime relTime (EraHistory _ interpreter) = do (slotNo, _, _) <- Qry.interpretQuery interpreter $ Qry.wallclockToSlot relTime pure slotNo newtype LedgerEpochInfo = LedgerEpochInfo { unLedgerEpochInfo :: Consensus.EpochInfo (Either Text) } -toLedgerEpochInfo :: EraHistory mode -> LedgerEpochInfo +toLedgerEpochInfo :: EraHistory CardanoMode -> LedgerEpochInfo toLedgerEpochInfo (EraHistory _ interpreter) = LedgerEpochInfo $ hoistEpochInfo (first (Text.pack . show) . runExcept) $ Consensus.interpreterToEpochInfo interpreter @@ -209,12 +209,15 @@ newtype SlotsInEpoch = SlotsInEpoch Word64 newtype SlotsToEpochEnd = SlotsToEpochEnd Word64 -slotToEpoch :: SlotNo -> EraHistory mode -> Either Qry.PastHorizonException (EpochNo, SlotsInEpoch, SlotsToEpochEnd) +slotToEpoch :: () + => SlotNo + -> EraHistory CardanoMode + -> Either Qry.PastHorizonException (EpochNo, SlotsInEpoch, SlotsToEpochEnd) slotToEpoch slotNo (EraHistory _ interpreter) = case Qry.interpretQuery interpreter (Qry.slotToEpoch slotNo) of Right (epochNumber, slotsInEpoch, slotsToEpochEnd) -> Right (epochNumber, SlotsInEpoch slotsInEpoch, SlotsToEpochEnd slotsToEpochEnd) Left e -> Left e -deriving instance Show (QueryInMode mode result) +deriving instance Show (QueryInMode CardanoMode result) data QueryInEra era result where QueryByronUpdateState :: QueryInEra ByronEra ByronUpdateState @@ -577,14 +580,11 @@ toConsensusQuery (QueryInEra erainmode (QueryInShelleyBasedEra sbe q)) = ConwayEraInCardanoMode -> toConsensusQueryShelleyBased erainmode q -toConsensusQueryShelleyBased - :: forall era ledgerera mode protocol block xs result. - ConsensusBlockForEra era ~ Consensus.ShelleyBlock protocol ledgerera - => Core.EraCrypto ledgerera ~ Consensus.StandardCrypto - => ShelleyLedgerEra era ~ ledgerera - => ConsensusBlockForMode mode ~ block - => block ~ Consensus.HardForkBlock xs - => EraInMode era mode +toConsensusQueryShelleyBased :: forall era protocol block result. () + => ConsensusBlockForEra era ~ Consensus.ShelleyBlock protocol (ShelleyLedgerEra era) + => Core.EraCrypto (ShelleyLedgerEra era) ~ Consensus.StandardCrypto + => ConsensusBlockForMode CardanoMode ~ block + => EraInMode era CardanoMode -> QueryInShelleyBasedEra era result -> Some (Consensus.Query block) toConsensusQueryShelleyBased erainmode QueryEpoch = @@ -675,12 +675,12 @@ toConsensusQueryShelleyBased erainmode (QueryCommitteeMembersState coldCreds hot Some (consensusQueryInEraInMode erainmode (Consensus.GetCommitteeMembersState coldCreds hotCreds statuses)) consensusQueryInEraInMode - :: forall era mode erablock modeblock result result' xs. + :: forall era erablock modeblock result result' xs. ConsensusBlockForEra era ~ erablock - => ConsensusBlockForMode mode ~ modeblock + => ConsensusBlockForMode CardanoMode ~ modeblock => modeblock ~ Consensus.HardForkBlock xs => Consensus.HardForkQueryResult xs result ~ result' - => EraInMode era mode + => EraInMode era CardanoMode -> Consensus.BlockQuery erablock result -> Consensus.Query modeblock result' consensusQueryInEraInMode erainmode = diff --git a/cardano-api/internal/Cardano/Api/Query/Expr.hs b/cardano-api/internal/Cardano/Api/Query/Expr.hs index 454a5a3d5b..fa45734a06 100644 --- a/cardano-api/internal/Cardano/Api/Query/Expr.hs +++ b/cardano-api/internal/Cardano/Api/Query/Expr.hs @@ -66,7 +66,7 @@ import Data.Set (Set) import qualified Data.Set as S queryChainBlockNo :: () - => LocalStateQueryExpr block point (QueryInMode mode) r IO (Either UnsupportedNtcVersionError (WithOrigin BlockNo)) + => LocalStateQueryExpr block point (QueryInMode CardanoMode) r IO (Either UnsupportedNtcVersionError (WithOrigin BlockNo)) queryChainBlockNo = queryExpr QueryChainBlockNo @@ -81,23 +81,23 @@ queryCurrentEra = queryExpr QueryCurrentEra queryCurrentEpochState :: () - => EraInMode era mode + => EraInMode era CardanoMode -> ShelleyBasedEra era - -> LocalStateQueryExpr block point (QueryInMode mode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch (SerialisedCurrentEpochState era))) + -> LocalStateQueryExpr block point (QueryInMode CardanoMode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch (SerialisedCurrentEpochState era))) queryCurrentEpochState eraInMode sbe = queryExpr $ QueryInEra eraInMode $ QueryInShelleyBasedEra sbe QueryCurrentEpochState queryEpoch :: () - => EraInMode era mode + => EraInMode era CardanoMode -> ShelleyBasedEra era - -> LocalStateQueryExpr block point (QueryInMode mode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch EpochNo)) + -> LocalStateQueryExpr block point (QueryInMode CardanoMode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch EpochNo)) queryEpoch eraInMode sbe = queryExpr $ QueryInEra eraInMode $ QueryInShelleyBasedEra sbe QueryEpoch queryDebugLedgerState :: () - => EraInMode era mode + => EraInMode era CardanoMode -> ShelleyBasedEra era - -> LocalStateQueryExpr block point (QueryInMode mode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch (SerialisedDebugLedgerState era))) + -> LocalStateQueryExpr block point (QueryInMode CardanoMode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch (SerialisedDebugLedgerState era))) queryDebugLedgerState eraInMode sbe = queryExpr $ QueryInEra eraInMode $ QueryInShelleyBasedEra sbe QueryDebugLedgerState @@ -107,165 +107,165 @@ queryEraHistory = queryExpr QueryEraHistory queryGenesisParameters :: () - => EraInMode era mode + => EraInMode era CardanoMode -> ShelleyBasedEra era - -> LocalStateQueryExpr block point (QueryInMode mode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch (GenesisParameters ShelleyEra))) + -> LocalStateQueryExpr block point (QueryInMode CardanoMode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch (GenesisParameters ShelleyEra))) queryGenesisParameters eraInMode sbe = queryExpr $ QueryInEra eraInMode $ QueryInShelleyBasedEra sbe QueryGenesisParameters queryPoolDistribution :: () - => EraInMode era mode + => EraInMode era CardanoMode -> ShelleyBasedEra era -> Maybe (Set PoolId) - -> LocalStateQueryExpr block point (QueryInMode mode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch (SerialisedPoolDistribution era))) + -> LocalStateQueryExpr block point (QueryInMode CardanoMode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch (SerialisedPoolDistribution era))) queryPoolDistribution eraInMode sbe mPoolIds = queryExpr $ QueryInEra eraInMode $ QueryInShelleyBasedEra sbe $ QueryPoolDistribution mPoolIds queryPoolState :: () - => EraInMode era mode + => EraInMode era CardanoMode -> ShelleyBasedEra era -> Maybe (Set PoolId) - -> LocalStateQueryExpr block point (QueryInMode mode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch (SerialisedPoolState era))) + -> LocalStateQueryExpr block point (QueryInMode CardanoMode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch (SerialisedPoolState era))) queryPoolState eraInMode sbe mPoolIds = queryExpr $ QueryInEra eraInMode $ QueryInShelleyBasedEra sbe $ QueryPoolState mPoolIds queryProtocolParameters :: () - => EraInMode era mode + => EraInMode era CardanoMode -> ShelleyBasedEra era - -> LocalStateQueryExpr block point (QueryInMode mode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch (Ledger.PParams (ShelleyLedgerEra era)))) + -> LocalStateQueryExpr block point (QueryInMode CardanoMode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch (Ledger.PParams (ShelleyLedgerEra era)))) queryProtocolParameters eraInMode sbe = queryExpr $ QueryInEra eraInMode $ QueryInShelleyBasedEra sbe QueryProtocolParameters queryConstitutionHash :: () - => EraInMode era mode + => EraInMode era CardanoMode -> ShelleyBasedEra era - -> LocalStateQueryExpr block point (QueryInMode mode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch (Maybe (SafeHash (EraCrypto (ShelleyLedgerEra era)) L.AnchorData)))) + -> LocalStateQueryExpr block point (QueryInMode CardanoMode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch (Maybe (SafeHash (EraCrypto (ShelleyLedgerEra era)) L.AnchorData)))) queryConstitutionHash eraInMode sbe = (fmap . fmap . fmap . fmap) (L.anchorDataHash . L.constitutionAnchor) $ queryExpr $ QueryInEra eraInMode $ QueryInShelleyBasedEra sbe QueryConstitution queryProtocolParametersUpdate :: () - => EraInMode era mode + => EraInMode era CardanoMode -> ShelleyBasedEra era - -> LocalStateQueryExpr block point (QueryInMode mode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch (Map (Hash GenesisKey) ProtocolParametersUpdate))) + -> LocalStateQueryExpr block point (QueryInMode CardanoMode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch (Map (Hash GenesisKey) ProtocolParametersUpdate))) queryProtocolParametersUpdate eraInMode sbe = queryExpr $ QueryInEra eraInMode $ QueryInShelleyBasedEra sbe QueryProtocolParametersUpdate queryProtocolState :: () - => EraInMode era mode + => EraInMode era CardanoMode -> ShelleyBasedEra era - -> LocalStateQueryExpr block point (QueryInMode mode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch (ProtocolState era))) + -> LocalStateQueryExpr block point (QueryInMode CardanoMode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch (ProtocolState era))) queryProtocolState eraInMode sbe = queryExpr $ QueryInEra eraInMode $ QueryInShelleyBasedEra sbe QueryProtocolState queryStakeAddresses :: () - => EraInMode era mode + => EraInMode era CardanoMode -> ShelleyBasedEra era -> Set StakeCredential -> NetworkId - -> LocalStateQueryExpr block point (QueryInMode mode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch (Map StakeAddress Lovelace, Map StakeAddress PoolId))) + -> LocalStateQueryExpr block point (QueryInMode CardanoMode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch (Map StakeAddress Lovelace, Map StakeAddress PoolId))) queryStakeAddresses eraInMode sbe stakeCredentials networkId = queryExpr $ QueryInEra eraInMode $ QueryInShelleyBasedEra sbe $ QueryStakeAddresses stakeCredentials networkId queryStakeDelegDeposits :: () - => EraInMode era mode + => EraInMode era CardanoMode -> ShelleyBasedEra era -> Set StakeCredential - -> LocalStateQueryExpr block point (QueryInMode mode) r IO (Either UnsupportedNtcVersionError (Either Consensus.EraMismatch (Map StakeCredential Lovelace))) + -> LocalStateQueryExpr block point (QueryInMode CardanoMode) r IO (Either UnsupportedNtcVersionError (Either Consensus.EraMismatch (Map StakeCredential Lovelace))) queryStakeDelegDeposits eraInMode sbe stakeCreds | S.null stakeCreds = pure . pure $ pure mempty | otherwise = queryExpr $ QueryInEra eraInMode . QueryInShelleyBasedEra sbe $ QueryStakeDelegDeposits stakeCreds queryStakeDistribution :: () - => EraInMode era mode + => EraInMode era CardanoMode -> ShelleyBasedEra era - -> LocalStateQueryExpr block point (QueryInMode mode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch (Map (Hash StakePoolKey) Rational))) + -> LocalStateQueryExpr block point (QueryInMode CardanoMode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch (Map (Hash StakePoolKey) Rational))) queryStakeDistribution eraInMode sbe = queryExpr $ QueryInEra eraInMode $ QueryInShelleyBasedEra sbe QueryStakeDistribution queryStakePoolParameters :: () - => EraInMode era mode + => EraInMode era CardanoMode -> ShelleyBasedEra era -> Set PoolId - -> LocalStateQueryExpr block point (QueryInMode mode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch (Map PoolId StakePoolParameters))) + -> LocalStateQueryExpr block point (QueryInMode CardanoMode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch (Map PoolId StakePoolParameters))) queryStakePoolParameters eraInMode sbe poolIds | S.null poolIds = pure . pure $ pure mempty | otherwise = queryExpr $ QueryInEra eraInMode $ QueryInShelleyBasedEra sbe $ QueryStakePoolParameters poolIds queryStakePools :: () - => EraInMode era mode + => EraInMode era CardanoMode -> ShelleyBasedEra era - -> LocalStateQueryExpr block point (QueryInMode mode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch (Set PoolId))) + -> LocalStateQueryExpr block point (QueryInMode CardanoMode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch (Set PoolId))) queryStakePools eraInMode sbe = queryExpr $ QueryInEra eraInMode . QueryInShelleyBasedEra sbe $ QueryStakePools queryStakeSnapshot :: () - => EraInMode era mode + => EraInMode era CardanoMode -> ShelleyBasedEra era -> Maybe (Set PoolId) - -> LocalStateQueryExpr block point (QueryInMode mode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch (SerialisedStakeSnapshots era))) + -> LocalStateQueryExpr block point (QueryInMode CardanoMode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch (SerialisedStakeSnapshots era))) queryStakeSnapshot eraInMode sbe mPoolIds = queryExpr $ QueryInEra eraInMode $ QueryInShelleyBasedEra sbe $ QueryStakeSnapshot mPoolIds querySystemStart :: () - => LocalStateQueryExpr block point (QueryInMode mode) r IO (Either UnsupportedNtcVersionError SystemStart) + => LocalStateQueryExpr block point (QueryInMode CardanoMode) r IO (Either UnsupportedNtcVersionError SystemStart) querySystemStart = queryExpr QuerySystemStart queryUtxo :: () - => EraInMode era mode + => EraInMode era CardanoMode -> ShelleyBasedEra era -> QueryUTxOFilter - -> LocalStateQueryExpr block point (QueryInMode mode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch (UTxO era))) + -> LocalStateQueryExpr block point (QueryInMode CardanoMode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch (UTxO era))) queryUtxo eraInMode sbe utxoFilter = queryExpr $ QueryInEra eraInMode $ QueryInShelleyBasedEra sbe $ QueryUTxO utxoFilter -- | A monad expression that determines what era the node is in. determineEraExpr :: () - => ConsensusModeParams mode - -> LocalStateQueryExpr block point (QueryInMode mode) r IO (Either UnsupportedNtcVersionError AnyCardanoEra) + => ConsensusModeParams CardanoMode + -> LocalStateQueryExpr block point (QueryInMode CardanoMode) r IO (Either UnsupportedNtcVersionError AnyCardanoEra) determineEraExpr cModeParams = runExceptT $ case consensusModeOnly cModeParams of CardanoMode -> ExceptT queryCurrentEra queryConstitution :: () - => EraInMode era mode + => EraInMode era CardanoMode -> ShelleyBasedEra era - -> LocalStateQueryExpr block point (QueryInMode mode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch (Maybe (L.Constitution (ShelleyLedgerEra era))))) + -> LocalStateQueryExpr block point (QueryInMode CardanoMode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch (Maybe (L.Constitution (ShelleyLedgerEra era))))) queryConstitution eraInMode sbe = queryExpr $ QueryInEra eraInMode $ QueryInShelleyBasedEra sbe QueryConstitution queryGovState :: () - => EraInMode era mode + => EraInMode era CardanoMode -> ShelleyBasedEra era - -> LocalStateQueryExpr block point (QueryInMode mode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch (L.GovState (ShelleyLedgerEra era)))) + -> LocalStateQueryExpr block point (QueryInMode CardanoMode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch (L.GovState (ShelleyLedgerEra era)))) queryGovState eraInMode sbe = queryExpr $ QueryInEra eraInMode $ QueryInShelleyBasedEra sbe QueryGovState queryDRepState :: () - => EraInMode era mode + => EraInMode era CardanoMode -> ShelleyBasedEra era -> Set (L.Credential L.DRepRole L.StandardCrypto) -- ^ An empty credentials set means that states for all DReps will be returned - -> LocalStateQueryExpr block point (QueryInMode mode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch (Map (L.Credential L.DRepRole L.StandardCrypto) (L.DRepState L.StandardCrypto)))) + -> LocalStateQueryExpr block point (QueryInMode CardanoMode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch (Map (L.Credential L.DRepRole L.StandardCrypto) (L.DRepState L.StandardCrypto)))) queryDRepState eraInMode sbe drepCreds = queryExpr $ QueryInEra eraInMode $ QueryInShelleyBasedEra sbe $ QueryDRepState drepCreds queryDRepStakeDistribution :: () - => EraInMode era mode + => EraInMode era CardanoMode -> ShelleyBasedEra era -> Set (L.DRep L.StandardCrypto) -- ^ An empty DRep set means that distributions for all DReps will be returned - -> LocalStateQueryExpr block point (QueryInMode mode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch (Map (L.DRep L.StandardCrypto) Lovelace))) + -> LocalStateQueryExpr block point (QueryInMode CardanoMode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch (Map (L.DRep L.StandardCrypto) Lovelace))) queryDRepStakeDistribution eraInMode sbe dreps = queryExpr $ QueryInEra eraInMode $ QueryInShelleyBasedEra sbe $ QueryDRepStakeDistr dreps -- | Returns info about committee members filtered by: cold credentials, hot credentials and statuses. -- If empty sets are passed as filters, then no filtering is done. queryCommitteeMembersState :: () - => EraInMode era mode + => EraInMode era CardanoMode -> ShelleyBasedEra era -> Set (L.Credential L.ColdCommitteeRole L.StandardCrypto) -> Set (L.Credential L.HotCommitteeRole L.StandardCrypto) -> Set L.MemberStatus - -> LocalStateQueryExpr block point (QueryInMode mode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch (Maybe (L.CommitteeMembersState L.StandardCrypto)))) + -> LocalStateQueryExpr block point (QueryInMode CardanoMode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch (Maybe (L.CommitteeMembersState L.StandardCrypto)))) queryCommitteeMembersState eraInMode sbe coldCreds hotCreds statuses = queryExpr $ QueryInEra eraInMode $ QueryInShelleyBasedEra sbe (QueryCommitteeMembersState coldCreds hotCreds statuses) diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Json.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Json.hs index a33963f049..e73cbe8a2f 100644 --- a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Json.hs +++ b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Json.hs @@ -66,7 +66,7 @@ prop_json_roundtrip_eraInMode = H.property $ do -- Defined this way instead of using 'tripping' in order to warn the -- developer if there's ever a new constructor in 'EraInMode' and we would -- need to add a new 'FromJSON' instance. - rountripEraInModeParser :: EraInMode era mode -> Parser (EraInMode era mode) + rountripEraInModeParser :: EraInMode era CardanoMode -> Parser (EraInMode era CardanoMode) rountripEraInModeParser = \case ByronEraInCardanoMode -> parseJSON $ toJSON ByronEraInCardanoMode ShelleyEraInCardanoMode -> parseJSON $ toJSON ShelleyEraInCardanoMode From 8be7b29c3b88be74fc15cf689e19553f3966c75c Mon Sep 17 00:00:00 2001 From: John Ky Date: Thu, 26 Oct 2023 22:07:02 +1100 Subject: [PATCH 14/37] Deparameterise BlockInMode --- cardano-api/internal/Cardano/Api/Block.hs | 65 ++++++------------- cardano-api/internal/Cardano/Api/IPC.hs | 16 ++--- cardano-api/internal/Cardano/Api/IPC/Monad.hs | 6 +- .../internal/Cardano/Api/LedgerState.hs | 56 ++++++++-------- 4 files changed, 60 insertions(+), 83 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/Block.hs b/cardano-api/internal/Cardano/Api/Block.hs index aaf1ab141d..e6a2010857 100644 --- a/cardano-api/internal/Cardano/Api/Block.hs +++ b/cardano-api/internal/Cardano/Api/Block.hs @@ -189,65 +189,42 @@ getShelleyBlockTxs era (Ledger.Block _header txs) = -- Block in a consensus mode -- --- | A 'Block' in one of the eras supported by a given protocol mode. --- --- For multi-era modes such as the 'CardanoMode' this type is a sum of the --- different block types for all the eras. It is used in the ChainSync protocol. --- -data BlockInMode mode where +-- | A 'Block' in one of the eras. +-- TODO Rename this to BlockInEra +data BlockInMode where BlockInMode :: CardanoEra era -> Block era - -> EraInMode era mode - -> BlockInMode mode + -> BlockInMode -deriving instance Show (BlockInMode mode) +deriving instance Show BlockInMode fromConsensusBlock :: () => ConsensusBlockForMode CardanoMode ~ block => ConsensusMode CardanoMode -> block - -> BlockInMode CardanoMode + -> BlockInMode fromConsensusBlock CardanoMode = \case - Consensus.BlockByron b' -> - BlockInMode cardanoEra (ByronBlock b') ByronEraInCardanoMode - - Consensus.BlockShelley b' -> - BlockInMode cardanoEra (ShelleyBlock ShelleyBasedEraShelley b') - ShelleyEraInCardanoMode - - Consensus.BlockAllegra b' -> - BlockInMode cardanoEra (ShelleyBlock ShelleyBasedEraAllegra b') - AllegraEraInCardanoMode - - Consensus.BlockMary b' -> - BlockInMode cardanoEra (ShelleyBlock ShelleyBasedEraMary b') - MaryEraInCardanoMode - - Consensus.BlockAlonzo b' -> - BlockInMode cardanoEra (ShelleyBlock ShelleyBasedEraAlonzo b') - AlonzoEraInCardanoMode - - Consensus.BlockBabbage b' -> - BlockInMode cardanoEra (ShelleyBlock ShelleyBasedEraBabbage b') - BabbageEraInCardanoMode - - Consensus.BlockConway b' -> - BlockInMode cardanoEra (ShelleyBlock ShelleyBasedEraConway b') - ConwayEraInCardanoMode + Consensus.BlockByron b' -> BlockInMode cardanoEra $ ByronBlock b' + Consensus.BlockShelley b' -> BlockInMode cardanoEra $ ShelleyBlock ShelleyBasedEraShelley b' + Consensus.BlockAllegra b' -> BlockInMode cardanoEra $ ShelleyBlock ShelleyBasedEraAllegra b' + Consensus.BlockMary b' -> BlockInMode cardanoEra $ ShelleyBlock ShelleyBasedEraMary b' + Consensus.BlockAlonzo b' -> BlockInMode cardanoEra $ ShelleyBlock ShelleyBasedEraAlonzo b' + Consensus.BlockBabbage b' -> BlockInMode cardanoEra $ ShelleyBlock ShelleyBasedEraBabbage b' + Consensus.BlockConway b' -> BlockInMode cardanoEra $ ShelleyBlock ShelleyBasedEraConway b' toConsensusBlock :: () => ConsensusBlockForMode CardanoMode ~ block - => BlockInMode CardanoMode + => BlockInMode -> block toConsensusBlock = \case - BlockInMode _ (ByronBlock b') ByronEraInCardanoMode -> Consensus.BlockByron b' - BlockInMode _ (ShelleyBlock ShelleyBasedEraShelley b') ShelleyEraInCardanoMode -> Consensus.BlockShelley b' - BlockInMode _ (ShelleyBlock ShelleyBasedEraAllegra b') AllegraEraInCardanoMode -> Consensus.BlockAllegra b' - BlockInMode _ (ShelleyBlock ShelleyBasedEraMary b') MaryEraInCardanoMode -> Consensus.BlockMary b' - BlockInMode _ (ShelleyBlock ShelleyBasedEraAlonzo b') AlonzoEraInCardanoMode -> Consensus.BlockAlonzo b' - BlockInMode _ (ShelleyBlock ShelleyBasedEraBabbage b') BabbageEraInCardanoMode -> Consensus.BlockBabbage b' - BlockInMode _ (ShelleyBlock ShelleyBasedEraConway b') ConwayEraInCardanoMode -> Consensus.BlockConway b' + BlockInMode _ (ByronBlock b') -> Consensus.BlockByron b' + BlockInMode _ (ShelleyBlock ShelleyBasedEraShelley b') -> Consensus.BlockShelley b' + BlockInMode _ (ShelleyBlock ShelleyBasedEraAllegra b') -> Consensus.BlockAllegra b' + BlockInMode _ (ShelleyBlock ShelleyBasedEraMary b') -> Consensus.BlockMary b' + BlockInMode _ (ShelleyBlock ShelleyBasedEraAlonzo b') -> Consensus.BlockAlonzo b' + BlockInMode _ (ShelleyBlock ShelleyBasedEraBabbage b') -> Consensus.BlockBabbage b' + BlockInMode _ (ShelleyBlock ShelleyBasedEraConway b') -> Consensus.BlockConway b' -- ---------------------------------------------------------------------------- -- Block headers diff --git a/cardano-api/internal/Cardano/Api/IPC.hs b/cardano-api/internal/Cardano/Api/IPC.hs index c1ca079a0f..138370c2c5 100644 --- a/cardano-api/internal/Cardano/Api/IPC.hs +++ b/cardano-api/internal/Cardano/Api/IPC.hs @@ -160,7 +160,7 @@ data LocalChainSyncClient block point tip m -- public, exported type LocalNodeClientProtocolsInMode = LocalNodeClientProtocols - (BlockInMode CardanoMode) + BlockInMode ChainPoint ChainTip SlotNo @@ -456,7 +456,7 @@ convLocalChainSyncClient => ConsensusBlockForMode CardanoMode ~ block => Functor m => ConsensusMode CardanoMode - -> ChainSyncClient (BlockInMode CardanoMode) ChainPoint ChainTip m a + -> ChainSyncClient BlockInMode ChainPoint ChainTip m a -> ChainSyncClient block (Net.Point block) (Net.Tip block) m a convLocalChainSyncClient mode = Net.Sync.mapChainSyncClient @@ -469,7 +469,7 @@ convLocalChainSyncClientPipelined :: forall block m a. () => ConsensusBlockForMode CardanoMode ~ block => Functor m => ConsensusMode CardanoMode - -> ChainSyncClientPipelined (BlockInMode CardanoMode) ChainPoint ChainTip m a + -> ChainSyncClientPipelined BlockInMode ChainPoint ChainTip m a -> ChainSyncClientPipelined block (Net.Point block) (Net.Tip block) m a convLocalChainSyncClientPipelined mode = mapChainSyncClientPipelined @@ -495,7 +495,7 @@ convLocalStateQueryClient => ConsensusBlockForMode CardanoMode ~ block => Functor m => ConsensusMode CardanoMode - -> LocalStateQueryClient (BlockInMode CardanoMode) ChainPoint (QueryInMode CardanoMode) m a + -> LocalStateQueryClient BlockInMode ChainPoint (QueryInMode CardanoMode) m a -> LocalStateQueryClient block (Consensus.Point block) (Consensus.Query block) m a convLocalStateQueryClient mode = Net.Query.mapLocalStateQueryClient @@ -576,7 +576,7 @@ queryNodeLocalState connctInfo mpoint query = do singleQuery :: Maybe ChainPoint -> TMVar (Either AcquiringFailure result) - -> Net.Query.LocalStateQueryClient (BlockInMode CardanoMode) ChainPoint (QueryInMode CardanoMode) IO () + -> Net.Query.LocalStateQueryClient BlockInMode ChainPoint (QueryInMode CardanoMode) IO () singleQuery mPointVar' resultVar' = LocalStateQueryClient $ do pure $ @@ -759,15 +759,15 @@ getLocalChainTip localNodeConInfo = do chainSyncGetCurrentTip :: () => TMVar ChainTip - -> ChainSyncClient (BlockInMode CardanoMode) ChainPoint ChainTip IO () + -> ChainSyncClient BlockInMode ChainPoint ChainTip IO () chainSyncGetCurrentTip tipVar = ChainSyncClient $ pure clientStIdle where - clientStIdle :: Net.Sync.ClientStIdle (BlockInMode mode) ChainPoint ChainTip IO () + clientStIdle :: Net.Sync.ClientStIdle BlockInMode ChainPoint ChainTip IO () clientStIdle = Net.Sync.SendMsgRequestNext clientStNext (pure clientStNext) - clientStNext :: Net.Sync.ClientStNext (BlockInMode mode) ChainPoint ChainTip IO () + clientStNext :: Net.Sync.ClientStNext BlockInMode ChainPoint ChainTip IO () clientStNext = Net.Sync.ClientStNext { Net.Sync.recvMsgRollForward = \_block tip -> ChainSyncClient $ do void $ atomically $ tryPutTMVar tipVar tip diff --git a/cardano-api/internal/Cardano/Api/IPC/Monad.hs b/cardano-api/internal/Cardano/Api/IPC/Monad.hs index eb2ba5b918..26c269ca4c 100644 --- a/cardano-api/internal/Cardano/Api/IPC/Monad.hs +++ b/cardano-api/internal/Cardano/Api/IPC/Monad.hs @@ -43,7 +43,7 @@ newtype LocalStateQueryExpr block point query r m a = LocalStateQueryExpr executeLocalStateQueryExpr :: () => LocalNodeConnectInfo -> Maybe ChainPoint - -> LocalStateQueryExpr (BlockInMode CardanoMode) ChainPoint (QueryInMode CardanoMode) () IO a + -> LocalStateQueryExpr BlockInMode ChainPoint (QueryInMode CardanoMode) () IO a -> IO (Either AcquiringFailure a) executeLocalStateQueryExpr connectInfo mpoint f = do tmvResultLocalState <- newEmptyTMVarIO @@ -71,8 +71,8 @@ setupLocalStateQueryExpr :: -> Maybe ChainPoint -> TMVar (Either AcquiringFailure a) -> NodeToClientVersion - -> LocalStateQueryExpr (BlockInMode CardanoMode) ChainPoint (QueryInMode CardanoMode) () IO a - -> Net.Query.LocalStateQueryClient (BlockInMode CardanoMode) ChainPoint (QueryInMode CardanoMode) IO () + -> LocalStateQueryExpr BlockInMode ChainPoint (QueryInMode CardanoMode) () IO a + -> Net.Query.LocalStateQueryClient BlockInMode ChainPoint (QueryInMode CardanoMode) IO () setupLocalStateQueryExpr waitDone mPointVar' resultVar' ntcVersion f = LocalStateQueryClient . pure . Net.Query.SendMsgAcquire mPointVar' $ Net.Query.ClientStAcquiring diff --git a/cardano-api/internal/Cardano/Api/LedgerState.hs b/cardano-api/internal/Cardano/Api/LedgerState.hs index 885de8fa72..28ed872310 100644 --- a/cardano-api/internal/Cardano/Api/LedgerState.hs +++ b/cardano-api/internal/Cardano/Api/LedgerState.hs @@ -94,7 +94,7 @@ import Cardano.Api.IPC (ConsensusModeParams (..), LocalNodeConnectInfo (..), connectToLocalNode) import Cardano.Api.Keys.Praos import Cardano.Api.LedgerEvent (LedgerEvent, toLedgerEvent) -import Cardano.Api.Modes (CardanoMode, EpochSlots (..)) +import Cardano.Api.Modes (EpochSlots (..)) import qualified Cardano.Api.Modes as Api import Cardano.Api.NetworkId (NetworkId (..), NetworkMagic (NetworkMagic)) import Cardano.Api.Query (CurrentEpochState (..), PoolDistribution (unPoolDistr), @@ -355,7 +355,7 @@ foldBlocks -> ValidationMode -> a -- ^ The initial accumulator state. - -> (Env -> LedgerState -> [LedgerEvent] -> BlockInMode CardanoMode -> a -> IO a) + -> (Env -> LedgerState -> [LedgerEvent] -> BlockInMode -> a -> IO a) -- ^ Accumulator function Takes: -- -- * Environment (this is a constant over the whole fold). @@ -449,7 +449,7 @@ foldBlocks nodeConfigFilePath socketPath validationMode state0 accumulate = do -> Env -> LedgerState -> CSP.ChainSyncClientPipelined - (BlockInMode CardanoMode) + BlockInMode ChainPoint ChainTip IO () @@ -464,7 +464,7 @@ foldBlocks nodeConfigFilePath socketPath validationMode state0 accumulate = do -> WithOrigin BlockNo -> Nat n -- Number of requests inflight. -> LedgerStateHistory - -> CSP.ClientPipelinedStIdle n (BlockInMode CardanoMode) ChainPoint ChainTip IO () + -> CSP.ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO () clientIdle_RequestMoreN clientTip serverTip n knownLedgerStates = case pipelineDecisionMax pipelineSize n clientTip serverTip of Collect -> case n of @@ -474,10 +474,10 @@ foldBlocks nodeConfigFilePath socketPath validationMode state0 accumulate = do clientNextN :: Nat n -- Number of requests inflight. -> LedgerStateHistory - -> CSP.ClientStNext n (BlockInMode CardanoMode) ChainPoint ChainTip IO () + -> CSP.ClientStNext n BlockInMode ChainPoint ChainTip IO () clientNextN n knownLedgerStates = CSP.ClientStNext { - CSP.recvMsgRollForward = \blockInMode@(BlockInMode _ block@(Block (BlockHeader slotNo _ currBlockNo) _) _era) serverChainTip -> do + CSP.recvMsgRollForward = \blockInMode@(BlockInMode _ block@(Block (BlockHeader slotNo _ currBlockNo) _)) serverChainTip -> do let newLedgerStateE = applyBlock env (maybe @@ -518,7 +518,7 @@ foldBlocks nodeConfigFilePath socketPath validationMode state0 accumulate = do clientIdle_DoneN :: Nat n -- Number of requests inflight. -> Maybe LedgerStateError -- Return value (maybe an error) - -> IO (CSP.ClientPipelinedStIdle n (BlockInMode CardanoMode) ChainPoint ChainTip IO ()) + -> IO (CSP.ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO ()) clientIdle_DoneN n errorMay = case n of Succ predN -> return (CSP.CollectResponse Nothing (clientNext_DoneN predN errorMay)) -- Ignore remaining message responses Zero -> do @@ -528,7 +528,7 @@ foldBlocks nodeConfigFilePath socketPath validationMode state0 accumulate = do clientNext_DoneN :: Nat n -- Number of requests inflight. -> Maybe LedgerStateError -- Return value (maybe an error) - -> CSP.ClientStNext n (BlockInMode CardanoMode) ChainPoint ChainTip IO () + -> CSP.ClientStNext n BlockInMode ChainPoint ChainTip IO () clientNext_DoneN n errorMay = CSP.ClientStNext { CSP.recvMsgRollForward = \_ _ -> clientIdle_DoneN n errorMay @@ -548,7 +548,7 @@ chainSyncClientWithLedgerState -> LedgerState -- ^ Initial ledger state -> ValidationMode - -> CS.ChainSyncClient (BlockInMode CardanoMode, Either LedgerStateError (LedgerState, [LedgerEvent])) + -> CS.ChainSyncClient (BlockInMode, Either LedgerStateError (LedgerState, [LedgerEvent])) ChainPoint ChainTip m @@ -559,7 +559,7 @@ chainSyncClientWithLedgerState -- trust the node, then we generally expect blocks to validate. Also note that -- after a block fails to validate we may still roll back to a validated -- block, in which case the valid 'LedgerState' will be passed here again. - -> CS.ChainSyncClient (BlockInMode CardanoMode) + -> CS.ChainSyncClient BlockInMode ChainPoint ChainTip m @@ -571,8 +571,8 @@ chainSyncClientWithLedgerState env ledgerState0 validationMode (CS.ChainSyncClie where goClientStIdle :: Either LedgerStateError (History (Either LedgerStateError LedgerStateEvents)) - -> CS.ClientStIdle (BlockInMode CardanoMode, Either LedgerStateError (LedgerState, [LedgerEvent])) ChainPoint ChainTip m a - -> CS.ClientStIdle (BlockInMode CardanoMode ) ChainPoint ChainTip m a + -> CS.ClientStIdle (BlockInMode, Either LedgerStateError (LedgerState, [LedgerEvent])) ChainPoint ChainTip m a + -> CS.ClientStIdle BlockInMode ChainPoint ChainTip m a goClientStIdle history client = case client of CS.SendMsgRequestNext a b -> CS.SendMsgRequestNext (goClientStNext history a) (goClientStNext history <$> b) CS.SendMsgFindIntersect ps a -> CS.SendMsgFindIntersect ps (goClientStIntersect history a) @@ -582,8 +582,8 @@ chainSyncClientWithLedgerState env ledgerState0 validationMode (CS.ChainSyncClie -- and use it to maintain the correct ledger state. goClientStNext :: Either LedgerStateError (History (Either LedgerStateError LedgerStateEvents)) - -> CS.ClientStNext (BlockInMode CardanoMode, Either LedgerStateError (LedgerState, [LedgerEvent])) ChainPoint ChainTip m a - -> CS.ClientStNext (BlockInMode CardanoMode ) ChainPoint ChainTip m a + -> CS.ClientStNext (BlockInMode, Either LedgerStateError (LedgerState, [LedgerEvent])) ChainPoint ChainTip m a + -> CS.ClientStNext BlockInMode ChainPoint ChainTip m a goClientStNext (Left err) (CS.ClientStNext recvMsgRollForward recvMsgRollBackward) = CS.ClientStNext (\blkInMode tip -> CS.ChainSyncClient $ goClientStIdle (Left err) <$> CS.runChainSyncClient @@ -593,7 +593,7 @@ chainSyncClientWithLedgerState env ledgerState0 validationMode (CS.ChainSyncClie goClientStIdle (Left err) <$> CS.runChainSyncClient (recvMsgRollBackward point tip) ) goClientStNext (Right history) (CS.ClientStNext recvMsgRollForward recvMsgRollBackward) = CS.ClientStNext - (\blkInMode@(BlockInMode _ blk@(Block (BlockHeader slotNo _ _) _) _) tip -> CS.ChainSyncClient $ let + (\blkInMode@(BlockInMode _ blk@(Block (BlockHeader slotNo _ _) _)) tip -> CS.ChainSyncClient $ let newLedgerStateE = case Seq.lookup 0 history of Nothing -> error "Impossible! History should always be non-empty" Just (_, Left err, _) -> Left err @@ -621,8 +621,8 @@ chainSyncClientWithLedgerState env ledgerState0 validationMode (CS.ChainSyncClie goClientStIntersect :: Either LedgerStateError (History (Either LedgerStateError LedgerStateEvents)) - -> CS.ClientStIntersect (BlockInMode CardanoMode, Either LedgerStateError (LedgerState, [LedgerEvent])) ChainPoint ChainTip m a - -> CS.ClientStIntersect (BlockInMode CardanoMode ) ChainPoint ChainTip m a + -> CS.ClientStIntersect (BlockInMode, Either LedgerStateError (LedgerState, [LedgerEvent])) ChainPoint ChainTip m a + -> CS.ClientStIntersect BlockInMode ChainPoint ChainTip m a goClientStIntersect history (CS.ClientStIntersect recvMsgIntersectFound recvMsgIntersectNotFound) = CS.ClientStIntersect (\point tip -> CS.ChainSyncClient (goClientStIdle history <$> CS.runChainSyncClient (recvMsgIntersectFound point tip))) (\tip -> CS.ChainSyncClient (goClientStIdle history <$> CS.runChainSyncClient (recvMsgIntersectNotFound tip))) @@ -638,13 +638,13 @@ chainSyncClientPipelinedWithLedgerState -> LedgerState -> ValidationMode -> CSP.ChainSyncClientPipelined - (BlockInMode CardanoMode, Either LedgerStateError (LedgerState, [LedgerEvent])) + (BlockInMode, Either LedgerStateError (LedgerState, [LedgerEvent])) ChainPoint ChainTip m a -> CSP.ChainSyncClientPipelined - (BlockInMode CardanoMode) + BlockInMode ChainPoint ChainTip m @@ -655,8 +655,8 @@ chainSyncClientPipelinedWithLedgerState env ledgerState0 validationMode (CSP.Cha goClientPipelinedStIdle :: Either LedgerStateError (History (Either LedgerStateError LedgerStateEvents)) -> Nat n - -> CSP.ClientPipelinedStIdle n (BlockInMode CardanoMode, Either LedgerStateError (LedgerState, [LedgerEvent])) ChainPoint ChainTip m a - -> CSP.ClientPipelinedStIdle n (BlockInMode CardanoMode ) ChainPoint ChainTip m a + -> CSP.ClientPipelinedStIdle n (BlockInMode, Either LedgerStateError (LedgerState, [LedgerEvent])) ChainPoint ChainTip m a + -> CSP.ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip m a goClientPipelinedStIdle history n client = case client of CSP.SendMsgRequestNext a b -> CSP.SendMsgRequestNext (goClientStNext history n a) (goClientStNext history n <$> b) CSP.SendMsgRequestNextPipelined a -> CSP.SendMsgRequestNextPipelined (goClientPipelinedStIdle history (Succ n) a) @@ -670,8 +670,8 @@ chainSyncClientPipelinedWithLedgerState env ledgerState0 validationMode (CSP.Cha goClientStNext :: Either LedgerStateError (History (Either LedgerStateError LedgerStateEvents)) -> Nat n - -> CSP.ClientStNext n (BlockInMode CardanoMode, Either LedgerStateError (LedgerState, [LedgerEvent])) ChainPoint ChainTip m a - -> CSP.ClientStNext n (BlockInMode CardanoMode ) ChainPoint ChainTip m a + -> CSP.ClientStNext n (BlockInMode, Either LedgerStateError (LedgerState, [LedgerEvent])) ChainPoint ChainTip m a + -> CSP.ClientStNext n BlockInMode ChainPoint ChainTip m a goClientStNext (Left err) n (CSP.ClientStNext recvMsgRollForward recvMsgRollBackward) = CSP.ClientStNext (\blkInMode tip -> goClientPipelinedStIdle (Left err) n <$> recvMsgRollForward @@ -681,7 +681,7 @@ chainSyncClientPipelinedWithLedgerState env ledgerState0 validationMode (CSP.Cha goClientPipelinedStIdle (Left err) n <$> recvMsgRollBackward point tip ) goClientStNext (Right history) n (CSP.ClientStNext recvMsgRollForward recvMsgRollBackward) = CSP.ClientStNext - (\blkInMode@(BlockInMode _ blk@(Block (BlockHeader slotNo _ _) _) _) tip -> let + (\blkInMode@(BlockInMode _ blk@(Block (BlockHeader slotNo _ _) _)) tip -> let newLedgerStateE = case Seq.lookup 0 history of Nothing -> error "Impossible! History should always be non-empty" Just (_, Left err, _) -> Left err @@ -710,8 +710,8 @@ chainSyncClientPipelinedWithLedgerState env ledgerState0 validationMode (CSP.Cha goClientPipelinedStIntersect :: Either LedgerStateError (History (Either LedgerStateError LedgerStateEvents)) -> Nat n - -> CSP.ClientPipelinedStIntersect (BlockInMode CardanoMode, Either LedgerStateError (LedgerState, [LedgerEvent])) ChainPoint ChainTip m a - -> CSP.ClientPipelinedStIntersect (BlockInMode CardanoMode ) ChainPoint ChainTip m a + -> CSP.ClientPipelinedStIntersect (BlockInMode, Either LedgerStateError (LedgerState, [LedgerEvent])) ChainPoint ChainTip m a + -> CSP.ClientPipelinedStIntersect BlockInMode ChainPoint ChainTip m a goClientPipelinedStIntersect history _ (CSP.ClientPipelinedStIntersect recvMsgIntersectFound recvMsgIntersectNotFound) = CSP.ClientPipelinedStIntersect (\point tip -> goClientPipelinedStIdle history Zero <$> recvMsgIntersectFound point tip) (\tip -> goClientPipelinedStIdle history Zero <$> recvMsgIntersectNotFound tip) @@ -729,7 +729,7 @@ chainSyncClientPipelinedWithLedgerState env ledgerState0 validationMode (CSP.Cha -- * The new block -- type LedgerStateHistory = History LedgerStateEvents -type History a = Seq (SlotNo, a, WithOrigin (BlockInMode CardanoMode)) +type History a = Seq (SlotNo, a, WithOrigin BlockInMode) -- | Add a new ledger state to the history pushLedgerState @@ -737,7 +737,7 @@ pushLedgerState -> History a -- ^ History of k items. -> SlotNo -- ^ Slot number of the new item. -> a -- ^ New item to add to the history - -> BlockInMode CardanoMode + -> BlockInMode -- ^ The block that (when applied to the previous -- item) resulted in the new item. -> (History a, History a) From d0848d1bc8548da92ccbe5f95d64f51a793cf1b4 Mon Sep 17 00:00:00 2001 From: John Ky Date: Thu, 26 Oct 2023 22:10:26 +1100 Subject: [PATCH 15/37] Deparameterise TxIdInMode --- cardano-api/internal/Cardano/Api/IPC.hs | 16 ++++++------- cardano-api/internal/Cardano/Api/InMode.hs | 26 +++++++++++++--------- 2 files changed, 23 insertions(+), 19 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/IPC.hs b/cardano-api/internal/Cardano/Api/IPC.hs index 138370c2c5..9cee264d2a 100644 --- a/cardano-api/internal/Cardano/Api/IPC.hs +++ b/cardano-api/internal/Cardano/Api/IPC.hs @@ -165,7 +165,7 @@ type LocalNodeClientProtocolsInMode = ChainTip SlotNo TxInMode - (TxIdInMode CardanoMode) + TxIdInMode TxValidationErrorInCardanoMode (QueryInMode CardanoMode) IO @@ -444,7 +444,7 @@ convLocalTxMonitoringClient :: forall block m a. () => ConsensusBlockForMode CardanoMode ~ block => Functor m => ConsensusMode CardanoMode - -> LocalTxMonitorClient (TxIdInMode CardanoMode) TxInMode SlotNo m a + -> LocalTxMonitorClient TxIdInMode TxInMode SlotNo m a -> LocalTxMonitorClient (Consensus.TxId (Consensus.GenTx block)) (Consensus.GenTx block) SlotNo m a convLocalTxMonitoringClient mode = mapLocalTxMonitoringClient @@ -669,7 +669,7 @@ data LocalTxMonitoringQuery -- | Query if a particular tx exists in the mempool. Note that, the absence -- of a transaction does not imply anything about how the transaction was -- processed: it may have been dropped, or inserted in a block. - = LocalTxMonitoringQueryTx (TxIdInMode CardanoMode) + = LocalTxMonitoringQueryTx TxIdInMode -- | The mempool is modeled as an ordered list of transactions and thus, can -- be traversed linearly. 'LocalTxMonitoringSendNextTx' requests the next transaction from the -- current list. This must be a transaction that was not previously sent to @@ -706,10 +706,10 @@ queryTxMonitoringLocal connectInfo localTxMonitoringQuery = do atomically (takeTMVar resultVar) where localTxMonitorClientTxExists :: () - => TxIdInMode CardanoMode + => TxIdInMode -> TMVar LocalTxMonitoringResult - -> LocalTxMonitorClient (TxIdInMode CardanoMode) TxInMode SlotNo IO () - localTxMonitorClientTxExists tIdInMode@(TxIdInMode txid _) resultVar = do + -> LocalTxMonitorClient TxIdInMode TxInMode SlotNo IO () + localTxMonitorClientTxExists tIdInMode@(TxIdInMode _ txid) resultVar = do LocalTxMonitorClient $ return $ CTxMon.SendMsgAcquire $ \slt -> do return $ CTxMon.SendMsgHasTx tIdInMode $ \txPresentBool -> do @@ -720,7 +720,7 @@ queryTxMonitoringLocal connectInfo localTxMonitoringQuery = do localTxMonitorNextTx :: () => TMVar LocalTxMonitoringResult - -> LocalTxMonitorClient (TxIdInMode CardanoMode) TxInMode SlotNo IO () + -> LocalTxMonitorClient TxIdInMode TxInMode SlotNo IO () localTxMonitorNextTx resultVar = LocalTxMonitorClient $ return $ do CTxMon.SendMsgAcquire $ \slt -> do @@ -730,7 +730,7 @@ queryTxMonitoringLocal connectInfo localTxMonitoringQuery = do localTxMonitorMempoolInfo :: () => TMVar LocalTxMonitoringResult - -> LocalTxMonitorClient (TxIdInMode CardanoMode) TxInMode SlotNo IO () + -> LocalTxMonitorClient TxIdInMode TxInMode SlotNo IO () localTxMonitorMempoolInfo resultVar = LocalTxMonitorClient $ return $ do CTxMon.SendMsgAcquire $ \slt -> do diff --git a/cardano-api/internal/Cardano/Api/InMode.hs b/cardano-api/internal/Cardano/Api/InMode.hs index fc6e176cc7..635088e20e 100644 --- a/cardano-api/internal/Cardano/Api/InMode.hs +++ b/cardano-api/internal/Cardano/Api/InMode.hs @@ -162,50 +162,54 @@ toConsensusGenTx (TxInMode (ShelleyTx _ _) ByronEraInCardanoMode) = -- different transaction types for all the eras. It is used in the -- LocalTxMonitoring protocol. -- - -data TxIdInMode mode where - TxIdInMode :: TxId -> EraInMode era mode -> TxIdInMode mode +-- TODO Rename to TxIdInEra +data TxIdInMode where + TxIdInMode + :: CardanoEra era + -> TxId + -> TxIdInMode toConsensusTxId :: () => ConsensusBlockForMode CardanoMode ~ block - => TxIdInMode CardanoMode -> Consensus.TxId (Consensus.GenTx block) -toConsensusTxId (TxIdInMode txid ByronEraInCardanoMode) = + => TxIdInMode + -> Consensus.TxId (Consensus.GenTx block) +toConsensusTxId (TxIdInMode ByronEra txid) = Consensus.HardForkGenTxId . Consensus.OneEraGenTxId . Z $ Consensus.WrapGenTxId txid' where txid' :: Consensus.TxId (Consensus.GenTx Consensus.ByronBlock) txid' = Consensus.ByronTxId $ toByronTxId txid -toConsensusTxId (TxIdInMode txid ShelleyEraInCardanoMode) = +toConsensusTxId (TxIdInMode ShelleyEra txid) = Consensus.HardForkGenTxId (Consensus.OneEraGenTxId (S (Z (Consensus.WrapGenTxId txid')))) where txid' :: Consensus.TxId (Consensus.GenTx Consensus.StandardShelleyBlock) txid' = Consensus.ShelleyTxId $ toShelleyTxId txid -toConsensusTxId (TxIdInMode txid AllegraEraInCardanoMode) = +toConsensusTxId (TxIdInMode AllegraEra txid) = Consensus.HardForkGenTxId (Consensus.OneEraGenTxId (S (S (Z (Consensus.WrapGenTxId txid'))))) where txid' :: Consensus.TxId (Consensus.GenTx Consensus.StandardAllegraBlock) txid' = Consensus.ShelleyTxId $ toShelleyTxId txid -toConsensusTxId (TxIdInMode txid MaryEraInCardanoMode) = +toConsensusTxId (TxIdInMode MaryEra txid) = Consensus.HardForkGenTxId (Consensus.OneEraGenTxId (S (S (S (Z (Consensus.WrapGenTxId txid')))))) where txid' :: Consensus.TxId (Consensus.GenTx Consensus.StandardMaryBlock) txid' = Consensus.ShelleyTxId $ toShelleyTxId txid -toConsensusTxId (TxIdInMode txid AlonzoEraInCardanoMode) = +toConsensusTxId (TxIdInMode AlonzoEra txid) = Consensus.HardForkGenTxId (Consensus.OneEraGenTxId (S (S (S (S (Z (Consensus.WrapGenTxId txid'))))))) where txid' :: Consensus.TxId (Consensus.GenTx Consensus.StandardAlonzoBlock) txid' = Consensus.ShelleyTxId $ toShelleyTxId txid -toConsensusTxId (TxIdInMode txid BabbageEraInCardanoMode) = +toConsensusTxId (TxIdInMode BabbageEra txid) = Consensus.HardForkGenTxId (Consensus.OneEraGenTxId (S (S (S (S (S (Z (Consensus.WrapGenTxId txid')))))))) where txid' :: Consensus.TxId (Consensus.GenTx Consensus.StandardBabbageBlock) txid' = Consensus.ShelleyTxId $ toShelleyTxId txid -toConsensusTxId (TxIdInMode txid ConwayEraInCardanoMode) = +toConsensusTxId (TxIdInMode ConwayEra txid) = Consensus.HardForkGenTxId (Consensus.OneEraGenTxId (S (S (S (S (S (S (Z (Consensus.WrapGenTxId txid'))))))))) where txid' :: Consensus.TxId (Consensus.GenTx Consensus.StandardConwayBlock) From b3b6bc088c944932ce32270a231d5dff830bf5d4 Mon Sep 17 00:00:00 2001 From: John Ky Date: Thu, 26 Oct 2023 22:16:33 +1100 Subject: [PATCH 16/37] Deparameterise EraHistory --- .../internal/Cardano/Api/Convenience/Query.hs | 2 +- cardano-api/internal/Cardano/Api/Query.hs | 30 ++++++++++++------- .../internal/Cardano/Api/Query/Expr.hs | 2 +- 3 files changed, 21 insertions(+), 13 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/Convenience/Query.hs b/cardano-api/internal/Cardano/Api/Convenience/Query.hs index 84f551d624..c303f06ab4 100644 --- a/cardano-api/internal/Cardano/Api/Convenience/Query.hs +++ b/cardano-api/internal/Cardano/Api/Convenience/Query.hs @@ -86,7 +86,7 @@ queryStateForBalancedTx :: () QueryConvenienceError ( UTxO era , LedgerProtocolParameters era - , EraHistory CardanoMode + , EraHistory , SystemStart , Set PoolId , Map StakeCredential Lovelace diff --git a/cardano-api/internal/Cardano/Api/Query.hs b/cardano-api/internal/Cardano/Api/Query.hs index 4a6d470894..dd0655b91c 100644 --- a/cardano-api/internal/Cardano/Api/Query.hs +++ b/cardano-api/internal/Cardano/Api/Query.hs @@ -161,7 +161,7 @@ data QueryInMode mode result where -> QueryInMode mode (Either EraMismatch result) QueryEraHistory - :: QueryInMode mode (EraHistory mode) + :: QueryInMode mode EraHistory QuerySystemStart :: QueryInMode mode SystemStart @@ -182,28 +182,36 @@ instance NodeToClientVersionOf (QueryInMode mode result) where QueryChainBlockNo -> NodeToClientV_10 QueryChainPoint _ -> NodeToClientV_10 -data EraHistory mode where +data EraHistory where EraHistory - :: ConsensusBlockForMode mode ~ Consensus.HardForkBlock xs - => ConsensusMode mode + :: ConsensusBlockForMode CardanoMode ~ Consensus.HardForkBlock xs + => ConsensusMode CardanoMode -> History.Interpreter xs - -> EraHistory mode + -> EraHistory -getProgress :: SlotNo -> EraHistory CardanoMode -> Either Qry.PastHorizonException (RelativeTime, SlotLength) +getProgress :: () + => SlotNo + -> EraHistory + -> Either Qry.PastHorizonException (RelativeTime, SlotLength) getProgress slotNo (EraHistory _ interpreter) = Qry.interpretQuery interpreter (Qry.slotToWallclock slotNo) -- | Returns the slot number for provided relative time from 'SystemStart' -getSlotForRelativeTime :: RelativeTime -> EraHistory CardanoMode -> Either Qry.PastHorizonException SlotNo +getSlotForRelativeTime :: () + => RelativeTime + -> EraHistory + -> Either Qry.PastHorizonException SlotNo getSlotForRelativeTime relTime (EraHistory _ interpreter) = do (slotNo, _, _) <- Qry.interpretQuery interpreter $ Qry.wallclockToSlot relTime pure slotNo newtype LedgerEpochInfo = LedgerEpochInfo { unLedgerEpochInfo :: Consensus.EpochInfo (Either Text) } -toLedgerEpochInfo :: EraHistory CardanoMode -> LedgerEpochInfo +toLedgerEpochInfo :: () + => EraHistory + -> LedgerEpochInfo toLedgerEpochInfo (EraHistory _ interpreter) = - LedgerEpochInfo $ hoistEpochInfo (first (Text.pack . show) . runExcept) $ - Consensus.interpreterToEpochInfo interpreter + LedgerEpochInfo $ hoistEpochInfo (first (Text.pack . show) . runExcept) $ + Consensus.interpreterToEpochInfo interpreter newtype SlotsInEpoch = SlotsInEpoch Word64 @@ -211,7 +219,7 @@ newtype SlotsToEpochEnd = SlotsToEpochEnd Word64 slotToEpoch :: () => SlotNo - -> EraHistory CardanoMode + -> EraHistory -> Either Qry.PastHorizonException (EpochNo, SlotsInEpoch, SlotsToEpochEnd) slotToEpoch slotNo (EraHistory _ interpreter) = case Qry.interpretQuery interpreter (Qry.slotToEpoch slotNo) of Right (epochNumber, slotsInEpoch, slotsToEpochEnd) -> Right (epochNumber, SlotsInEpoch slotsInEpoch, SlotsToEpochEnd slotsToEpochEnd) diff --git a/cardano-api/internal/Cardano/Api/Query/Expr.hs b/cardano-api/internal/Cardano/Api/Query/Expr.hs index fa45734a06..37d6706c2c 100644 --- a/cardano-api/internal/Cardano/Api/Query/Expr.hs +++ b/cardano-api/internal/Cardano/Api/Query/Expr.hs @@ -102,7 +102,7 @@ queryDebugLedgerState eraInMode sbe = queryExpr $ QueryInEra eraInMode $ QueryInShelleyBasedEra sbe QueryDebugLedgerState queryEraHistory :: () - => LocalStateQueryExpr block point (QueryInMode CardanoMode) r IO (Either UnsupportedNtcVersionError (EraHistory CardanoMode)) + => LocalStateQueryExpr block point (QueryInMode CardanoMode) r IO (Either UnsupportedNtcVersionError EraHistory) queryEraHistory = queryExpr QueryEraHistory From f0916a4b153704861544fee7a945d1ddfbf5942e Mon Sep 17 00:00:00 2001 From: John Ky Date: Thu, 26 Oct 2023 22:48:48 +1100 Subject: [PATCH 17/37] Delete EraInMode constructor argument in QueryInEra constructor --- .../internal/Cardano/Api/Convenience/Query.hs | 13 +- .../Cardano/Api/Eon/AllegraEraOnwards.hs | 1 + .../Cardano/Api/Eon/AlonzoEraOnwards.hs | 1 + .../Cardano/Api/Eon/BabbageEraOnwards.hs | 1 + .../Cardano/Api/Eon/ConwayEraOnwards.hs | 1 + .../internal/Cardano/Api/Eon/MaryEraOnly.hs | 1 + .../Cardano/Api/Eon/MaryEraOnwards.hs | 1 + .../Cardano/Api/Eon/ShelleyBasedEra.hs | 1 + .../Cardano/Api/Eon/ShelleyEraOnly.hs | 1 + .../Cardano/Api/Eon/ShelleyToAllegraEra.hs | 1 + .../Cardano/Api/Eon/ShelleyToAlonzoEra.hs | 1 + .../Cardano/Api/Eon/ShelleyToBabbageEra.hs | 1 + .../Cardano/Api/Eon/ShelleyToMaryEra.hs | 1 + cardano-api/internal/Cardano/Api/Fees.hs | 4 +- cardano-api/internal/Cardano/Api/Query.hs | 202 ++++++++---------- .../internal/Cardano/Api/Query/Expr.hs | 151 ++++++------- 16 files changed, 175 insertions(+), 207 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/Convenience/Query.hs b/cardano-api/internal/Cardano/Api/Convenience/Query.hs index c303f06ab4..c17bab5955 100644 --- a/cardano-api/internal/Cardano/Api/Convenience/Query.hs +++ b/cardano-api/internal/Cardano/Api/Convenience/Query.hs @@ -95,18 +95,15 @@ queryStateForBalancedTx era allTxIns certs = runExceptT $ do sbe <- requireShelleyBasedEra era & onNothing (left ByronEraNotSupported) - qeInMode <- pure (toEraInMode era CardanoMode) - & onNothing (left (EraConsensusModeMismatch (AnyConsensusMode CardanoMode) (anyCardanoEra era))) - let stakeCreds = Set.fromList $ mapMaybe filterUnRegCreds certs drepCreds = Set.fromList $ mapMaybe filterUnRegDRepCreds certs -- Query execution - utxo <- lift (queryUtxo qeInMode sbe (QueryUTxOByTxIn (Set.fromList allTxIns))) + utxo <- lift (queryUtxo sbe (QueryUTxOByTxIn (Set.fromList allTxIns))) & onLeft (left . QceUnsupportedNtcVersion) & onLeft (left . QueryEraMismatch) - pparams <- lift (queryProtocolParameters qeInMode sbe) + pparams <- lift (queryProtocolParameters sbe) & onLeft (left . QceUnsupportedNtcVersion) & onLeft (left . QueryEraMismatch) @@ -116,19 +113,19 @@ queryStateForBalancedTx era allTxIns certs = runExceptT $ do systemStart <- lift querySystemStart & onLeft (left . QceUnsupportedNtcVersion) - stakePools <- lift (queryStakePools qeInMode sbe) + stakePools <- lift (queryStakePools sbe) & onLeft (left . QceUnsupportedNtcVersion) & onLeft (left . QueryEraMismatch) stakeDelegDeposits <- - lift (queryStakeDelegDeposits qeInMode sbe stakeCreds) + lift (queryStakeDelegDeposits sbe stakeCreds) & onLeft (left . QceUnsupportedNtcVersion) & onLeft (left . QueryEraMismatch) drepDelegDeposits <- forEraInEon @ConwayEraOnwards era (pure mempty) $ \_ -> Map.map (fromShelleyLovelace . drepDeposit) <$> - (lift (queryDRepState qeInMode sbe drepCreds) + (lift (queryDRepState sbe drepCreds) & onLeft (left . QceUnsupportedNtcVersion) & onLeft (left . QueryEraMismatch)) diff --git a/cardano-api/internal/Cardano/Api/Eon/AllegraEraOnwards.hs b/cardano-api/internal/Cardano/Api/Eon/AllegraEraOnwards.hs index 358711f6d8..11b153d1a7 100644 --- a/cardano-api/internal/Cardano/Api/Eon/AllegraEraOnwards.hs +++ b/cardano-api/internal/Cardano/Api/Eon/AllegraEraOnwards.hs @@ -69,6 +69,7 @@ type AllegraEraOnwardsConstraints era = ( C.HashAlgorithm (L.HASH (L.EraCrypto (ShelleyLedgerEra era))) , C.Signable (L.VRF (L.EraCrypto (ShelleyLedgerEra era))) L.Seed , Consensus.PraosProtocolSupportsNode (ConsensusProtocol era) + , Consensus.ShelleyBlock (ConsensusProtocol era) (ShelleyLedgerEra era) ~ ConsensusBlockForEra era , Consensus.ShelleyCompatible (ConsensusProtocol era) (ShelleyLedgerEra era) , L.ADDRHASH (Consensus.PraosProtocolSupportsNodeCrypto (ConsensusProtocol era)) ~ Blake2b.Blake2b_224 , L.Crypto (L.EraCrypto (ShelleyLedgerEra era)) diff --git a/cardano-api/internal/Cardano/Api/Eon/AlonzoEraOnwards.hs b/cardano-api/internal/Cardano/Api/Eon/AlonzoEraOnwards.hs index 471c5d0800..bb498cc749 100644 --- a/cardano-api/internal/Cardano/Api/Eon/AlonzoEraOnwards.hs +++ b/cardano-api/internal/Cardano/Api/Eon/AlonzoEraOnwards.hs @@ -73,6 +73,7 @@ type AlonzoEraOnwardsConstraints era = ( C.HashAlgorithm (L.HASH (L.EraCrypto (ShelleyLedgerEra era))) , C.Signable (L.VRF (L.EraCrypto (ShelleyLedgerEra era))) L.Seed , Consensus.PraosProtocolSupportsNode (ConsensusProtocol era) + , Consensus.ShelleyBlock (ConsensusProtocol era) (ShelleyLedgerEra era) ~ ConsensusBlockForEra era , Consensus.ShelleyCompatible (ConsensusProtocol era) (ShelleyLedgerEra era) , L.ADDRHASH (Consensus.PraosProtocolSupportsNodeCrypto (ConsensusProtocol era)) ~ Blake2b.Blake2b_224 , L.AlonzoEraPParams (ShelleyLedgerEra era) diff --git a/cardano-api/internal/Cardano/Api/Eon/BabbageEraOnwards.hs b/cardano-api/internal/Cardano/Api/Eon/BabbageEraOnwards.hs index f8c41c4299..a1c4e5611e 100644 --- a/cardano-api/internal/Cardano/Api/Eon/BabbageEraOnwards.hs +++ b/cardano-api/internal/Cardano/Api/Eon/BabbageEraOnwards.hs @@ -70,6 +70,7 @@ type BabbageEraOnwardsConstraints era = ( C.HashAlgorithm (L.HASH (L.EraCrypto (ShelleyLedgerEra era))) , C.Signable (L.VRF (L.EraCrypto (ShelleyLedgerEra era))) L.Seed , Consensus.PraosProtocolSupportsNode (ConsensusProtocol era) + , Consensus.ShelleyBlock (ConsensusProtocol era) (ShelleyLedgerEra era) ~ ConsensusBlockForEra era , Consensus.ShelleyCompatible (ConsensusProtocol era) (ShelleyLedgerEra era) , L.ADDRHASH (Consensus.PraosProtocolSupportsNodeCrypto (ConsensusProtocol era)) ~ Blake2b.Blake2b_224 , L.AlonzoEraTxOut (ShelleyLedgerEra era) diff --git a/cardano-api/internal/Cardano/Api/Eon/ConwayEraOnwards.hs b/cardano-api/internal/Cardano/Api/Eon/ConwayEraOnwards.hs index d10a88420b..1595ce3f88 100644 --- a/cardano-api/internal/Cardano/Api/Eon/ConwayEraOnwards.hs +++ b/cardano-api/internal/Cardano/Api/Eon/ConwayEraOnwards.hs @@ -70,6 +70,7 @@ type ConwayEraOnwardsConstraints era = ( C.HashAlgorithm (L.HASH (L.EraCrypto (ShelleyLedgerEra era))) , C.Signable (L.VRF (L.EraCrypto (ShelleyLedgerEra era))) L.Seed , Consensus.PraosProtocolSupportsNode (ConsensusProtocol era) + , Consensus.ShelleyBlock (ConsensusProtocol era) (ShelleyLedgerEra era) ~ ConsensusBlockForEra era , Consensus.ShelleyCompatible (ConsensusProtocol era) (ShelleyLedgerEra era) , L.ADDRHASH (Consensus.PraosProtocolSupportsNodeCrypto (ConsensusProtocol era)) ~ Blake2b.Blake2b_224 , L.AlonzoEraTxOut (ShelleyLedgerEra era) diff --git a/cardano-api/internal/Cardano/Api/Eon/MaryEraOnly.hs b/cardano-api/internal/Cardano/Api/Eon/MaryEraOnly.hs index 640fd20469..2609fc5e01 100644 --- a/cardano-api/internal/Cardano/Api/Eon/MaryEraOnly.hs +++ b/cardano-api/internal/Cardano/Api/Eon/MaryEraOnly.hs @@ -63,6 +63,7 @@ type MaryEraOnlyConstraints era = ( C.HashAlgorithm (L.HASH (L.EraCrypto (ShelleyLedgerEra era))) , C.Signable (L.VRF (L.EraCrypto (ShelleyLedgerEra era))) L.Seed , Consensus.PraosProtocolSupportsNode (ConsensusProtocol era) + , Consensus.ShelleyBlock (ConsensusProtocol era) (ShelleyLedgerEra era) ~ ConsensusBlockForEra era , Consensus.ShelleyCompatible (ConsensusProtocol era) (ShelleyLedgerEra era) , L.ADDRHASH (Consensus.PraosProtocolSupportsNodeCrypto (ConsensusProtocol era)) ~ Blake2b.Blake2b_224 , L.Crypto (L.EraCrypto (ShelleyLedgerEra era)) diff --git a/cardano-api/internal/Cardano/Api/Eon/MaryEraOnwards.hs b/cardano-api/internal/Cardano/Api/Eon/MaryEraOnwards.hs index 217f3fcc25..1a40f0a631 100644 --- a/cardano-api/internal/Cardano/Api/Eon/MaryEraOnwards.hs +++ b/cardano-api/internal/Cardano/Api/Eon/MaryEraOnwards.hs @@ -69,6 +69,7 @@ type MaryEraOnwardsConstraints era = ( C.HashAlgorithm (L.HASH (L.EraCrypto (ShelleyLedgerEra era))) , C.Signable (L.VRF (L.EraCrypto (ShelleyLedgerEra era))) L.Seed , Consensus.PraosProtocolSupportsNode (ConsensusProtocol era) + , Consensus.ShelleyBlock (ConsensusProtocol era) (ShelleyLedgerEra era) ~ ConsensusBlockForEra era , Consensus.ShelleyCompatible (ConsensusProtocol era) (ShelleyLedgerEra era) , L.ADDRHASH (Consensus.PraosProtocolSupportsNodeCrypto (ConsensusProtocol era)) ~ Blake2b.Blake2b_224 , L.Crypto (L.EraCrypto (ShelleyLedgerEra era)) diff --git a/cardano-api/internal/Cardano/Api/Eon/ShelleyBasedEra.hs b/cardano-api/internal/Cardano/Api/Eon/ShelleyBasedEra.hs index 3bbe6cac6a..f0384cbfc8 100644 --- a/cardano-api/internal/Cardano/Api/Eon/ShelleyBasedEra.hs +++ b/cardano-api/internal/Cardano/Api/Eon/ShelleyBasedEra.hs @@ -195,6 +195,7 @@ type ShelleyBasedEraConstraints era = ( C.HashAlgorithm (L.HASH (L.EraCrypto (ShelleyLedgerEra era))) , C.Signable (L.VRF (L.EraCrypto (ShelleyLedgerEra era))) L.Seed , Consensus.PraosProtocolSupportsNode (ConsensusProtocol era) + , Consensus.ShelleyBlock (ConsensusProtocol era) (ShelleyLedgerEra era) ~ ConsensusBlockForEra era , Consensus.ShelleyCompatible (ConsensusProtocol era) (ShelleyLedgerEra era) , L.ADDRHASH (Consensus.PraosProtocolSupportsNodeCrypto (ConsensusProtocol era)) ~ Blake2b.Blake2b_224 , L.Crypto (L.EraCrypto (ShelleyLedgerEra era)) diff --git a/cardano-api/internal/Cardano/Api/Eon/ShelleyEraOnly.hs b/cardano-api/internal/Cardano/Api/Eon/ShelleyEraOnly.hs index b5673857c8..7a1c579fea 100644 --- a/cardano-api/internal/Cardano/Api/Eon/ShelleyEraOnly.hs +++ b/cardano-api/internal/Cardano/Api/Eon/ShelleyEraOnly.hs @@ -63,6 +63,7 @@ type ShelleyEraOnlyConstraints era = ( C.HashAlgorithm (L.HASH (L.EraCrypto (ShelleyLedgerEra era))) , C.Signable (L.VRF (L.EraCrypto (ShelleyLedgerEra era))) L.Seed , Consensus.PraosProtocolSupportsNode (ConsensusProtocol era) + , Consensus.ShelleyBlock (ConsensusProtocol era) (ShelleyLedgerEra era) ~ ConsensusBlockForEra era , Consensus.ShelleyCompatible (ConsensusProtocol era) (ShelleyLedgerEra era) , L.ADDRHASH (Consensus.PraosProtocolSupportsNodeCrypto (ConsensusProtocol era)) ~ Blake2b.Blake2b_224 , L.Crypto (L.EraCrypto (ShelleyLedgerEra era)) diff --git a/cardano-api/internal/Cardano/Api/Eon/ShelleyToAllegraEra.hs b/cardano-api/internal/Cardano/Api/Eon/ShelleyToAllegraEra.hs index 916f170078..5115b73a4f 100644 --- a/cardano-api/internal/Cardano/Api/Eon/ShelleyToAllegraEra.hs +++ b/cardano-api/internal/Cardano/Api/Eon/ShelleyToAllegraEra.hs @@ -66,6 +66,7 @@ type ShelleyToAllegraEraConstraints era = ( C.HashAlgorithm (L.HASH (L.EraCrypto (ShelleyLedgerEra era))) , C.Signable (L.VRF (L.EraCrypto (ShelleyLedgerEra era))) L.Seed , Consensus.PraosProtocolSupportsNode (ConsensusProtocol era) + , Consensus.ShelleyBlock (ConsensusProtocol era) (ShelleyLedgerEra era) ~ ConsensusBlockForEra era , Consensus.ShelleyCompatible (ConsensusProtocol era) (ShelleyLedgerEra era) , L.ADDRHASH (Consensus.PraosProtocolSupportsNodeCrypto (ConsensusProtocol era)) ~ Blake2b.Blake2b_224 , L.Crypto (L.EraCrypto (ShelleyLedgerEra era)) diff --git a/cardano-api/internal/Cardano/Api/Eon/ShelleyToAlonzoEra.hs b/cardano-api/internal/Cardano/Api/Eon/ShelleyToAlonzoEra.hs index d1409ecfa6..5b910df0d2 100644 --- a/cardano-api/internal/Cardano/Api/Eon/ShelleyToAlonzoEra.hs +++ b/cardano-api/internal/Cardano/Api/Eon/ShelleyToAlonzoEra.hs @@ -68,6 +68,7 @@ type ShelleyToAlonzoEraConstraints era = ( C.HashAlgorithm (L.HASH (L.EraCrypto (ShelleyLedgerEra era))) , C.Signable (L.VRF (L.EraCrypto (ShelleyLedgerEra era))) L.Seed , Consensus.PraosProtocolSupportsNode (ConsensusProtocol era) + , Consensus.ShelleyBlock (ConsensusProtocol era) (ShelleyLedgerEra era) ~ ConsensusBlockForEra era , Consensus.ShelleyCompatible (ConsensusProtocol era) (ShelleyLedgerEra era) , L.ADDRHASH (Consensus.PraosProtocolSupportsNodeCrypto (ConsensusProtocol era)) ~ Blake2b.Blake2b_224 , L.Crypto (L.EraCrypto (ShelleyLedgerEra era)) diff --git a/cardano-api/internal/Cardano/Api/Eon/ShelleyToBabbageEra.hs b/cardano-api/internal/Cardano/Api/Eon/ShelleyToBabbageEra.hs index ba76e9573f..fa96be8607 100644 --- a/cardano-api/internal/Cardano/Api/Eon/ShelleyToBabbageEra.hs +++ b/cardano-api/internal/Cardano/Api/Eon/ShelleyToBabbageEra.hs @@ -70,6 +70,7 @@ type ShelleyToBabbageEraConstraints era = ( C.HashAlgorithm (L.HASH (L.EraCrypto (ShelleyLedgerEra era))) , C.Signable (L.VRF (L.EraCrypto (ShelleyLedgerEra era))) L.Seed , Consensus.PraosProtocolSupportsNode (ConsensusProtocol era) + , Consensus.ShelleyBlock (ConsensusProtocol era) (ShelleyLedgerEra era) ~ ConsensusBlockForEra era , Consensus.ShelleyCompatible (ConsensusProtocol era) (ShelleyLedgerEra era) , L.ADDRHASH (Consensus.PraosProtocolSupportsNodeCrypto (ConsensusProtocol era)) ~ Blake2b.Blake2b_224 , L.Crypto (L.EraCrypto (ShelleyLedgerEra era)) diff --git a/cardano-api/internal/Cardano/Api/Eon/ShelleyToMaryEra.hs b/cardano-api/internal/Cardano/Api/Eon/ShelleyToMaryEra.hs index b9d6f00803..81c5d149f2 100644 --- a/cardano-api/internal/Cardano/Api/Eon/ShelleyToMaryEra.hs +++ b/cardano-api/internal/Cardano/Api/Eon/ShelleyToMaryEra.hs @@ -66,6 +66,7 @@ type ShelleyToMaryEraConstraints era = ( C.HashAlgorithm (L.HASH (L.EraCrypto (ShelleyLedgerEra era))) , C.Signable (L.VRF (L.EraCrypto (ShelleyLedgerEra era))) L.Seed , Consensus.PraosProtocolSupportsNode (ConsensusProtocol era) + , Consensus.ShelleyBlock (ConsensusProtocol era) (ShelleyLedgerEra era) ~ ConsensusBlockForEra era , Consensus.ShelleyCompatible (ConsensusProtocol era) (ShelleyLedgerEra era) , L.ADDRHASH (Consensus.PraosProtocolSupportsNodeCrypto (ConsensusProtocol era)) ~ Blake2b.Blake2b_224 , L.Crypto (L.EraCrypto (ShelleyLedgerEra era)) diff --git a/cardano-api/internal/Cardano/Api/Fees.hs b/cardano-api/internal/Cardano/Api/Fees.hs index bb9a7ae876..14099e9c51 100644 --- a/cardano-api/internal/Cardano/Api/Fees.hs +++ b/cardano-api/internal/Cardano/Api/Fees.hs @@ -219,9 +219,7 @@ evaluateTransactionFee _ _ _ _ byronwitcount | byronwitcount > 0 = evaluateTransactionFee sbe pp txbody keywitcount _byronwitcount = shelleyBasedEraConstraints sbe $ case makeSignedTransaction [] txbody of - ByronTx ByronEraOnlyByron _ -> case sbe of {} - --TODO: we could actually support Byron here, it'd be different but simpler - + ByronTx w _ -> disjointByronEraOnlyAndShelleyBasedEra w sbe ShelleyTx _ tx -> fromShelleyLovelace $ Ledger.evaluateTransactionFee pp tx keywitcount -- | Give an approximate count of the number of key witnesses (i.e. signatures) diff --git a/cardano-api/internal/Cardano/Api/Query.hs b/cardano-api/internal/Cardano/Api/Query.hs index dd0655b91c..27a9d1290c 100644 --- a/cardano-api/internal/Cardano/Api/Query.hs +++ b/cardano-api/internal/Cardano/Api/Query.hs @@ -156,8 +156,7 @@ data QueryInMode mode result where :: QueryInMode mode AnyCardanoEra QueryInEra - :: EraInMode era mode - -> QueryInEra era result + :: QueryInEra era result -> QueryInMode mode (Either EraMismatch result) QueryEraHistory @@ -176,7 +175,7 @@ data QueryInMode mode result where instance NodeToClientVersionOf (QueryInMode mode result) where nodeToClientVersionOf = \case QueryCurrentEra -> NodeToClientV_9 - QueryInEra _ q -> nodeToClientVersionOf q + QueryInEra q -> nodeToClientVersionOf q QueryEraHistory -> NodeToClientV_9 QuerySystemStart -> NodeToClientV_9 QueryChainBlockNo -> NodeToClientV_10 @@ -572,115 +571,111 @@ toConsensusQuery QueryChainBlockNo = Some Consensus.GetChainBlockNo toConsensusQuery (QueryChainPoint _) = Some Consensus.GetChainPoint -toConsensusQuery (QueryInEra ByronEraInCardanoMode QueryByronUpdateState) = - Some $ Consensus.BlockQuery $ - Consensus.QueryIfCurrentByron - Consensus.GetUpdateInterfaceState - -toConsensusQuery (QueryInEra erainmode (QueryInShelleyBasedEra sbe q)) = - case erainmode of - ByronEraInCardanoMode -> case sbe of {} - ShelleyEraInCardanoMode -> toConsensusQueryShelleyBased erainmode q - AllegraEraInCardanoMode -> toConsensusQueryShelleyBased erainmode q - MaryEraInCardanoMode -> toConsensusQueryShelleyBased erainmode q - AlonzoEraInCardanoMode -> toConsensusQueryShelleyBased erainmode q - BabbageEraInCardanoMode -> toConsensusQueryShelleyBased erainmode q - ConwayEraInCardanoMode -> toConsensusQueryShelleyBased erainmode q +toConsensusQuery (QueryInEra QueryByronUpdateState) = + Some $ Consensus.BlockQuery $ + Consensus.QueryIfCurrentByron + Consensus.GetUpdateInterfaceState +toConsensusQuery (QueryInEra (QueryInShelleyBasedEra sbe q)) = + shelleyBasedEraConstraints sbe $ toConsensusQueryShelleyBased sbe q toConsensusQueryShelleyBased :: forall era protocol block result. () => ConsensusBlockForEra era ~ Consensus.ShelleyBlock protocol (ShelleyLedgerEra era) => Core.EraCrypto (ShelleyLedgerEra era) ~ Consensus.StandardCrypto => ConsensusBlockForMode CardanoMode ~ block - => EraInMode era CardanoMode + => ShelleyBasedEra era -> QueryInShelleyBasedEra era result -> Some (Consensus.Query block) -toConsensusQueryShelleyBased erainmode QueryEpoch = - Some (consensusQueryInEraInMode erainmode Consensus.GetEpochNo) +toConsensusQueryShelleyBased sbe = \case + QueryEpoch -> + Some (consensusQueryInEraInMode era Consensus.GetEpochNo) -toConsensusQueryShelleyBased erainmode QueryConstitution = - Some (consensusQueryInEraInMode erainmode Consensus.GetConstitution) + QueryConstitution -> + Some (consensusQueryInEraInMode era Consensus.GetConstitution) -toConsensusQueryShelleyBased erainmode QueryGenesisParameters = - Some (consensusQueryInEraInMode erainmode Consensus.GetGenesisConfig) + QueryGenesisParameters -> + Some (consensusQueryInEraInMode era Consensus.GetGenesisConfig) -toConsensusQueryShelleyBased erainmode QueryProtocolParameters = - Some (consensusQueryInEraInMode erainmode Consensus.GetCurrentPParams) + QueryProtocolParameters -> + Some (consensusQueryInEraInMode era Consensus.GetCurrentPParams) -toConsensusQueryShelleyBased erainmode QueryProtocolParametersUpdate = - Some (consensusQueryInEraInMode erainmode Consensus.GetProposedPParamsUpdates) + QueryProtocolParametersUpdate -> + Some (consensusQueryInEraInMode era Consensus.GetProposedPParamsUpdates) -toConsensusQueryShelleyBased erainmode QueryStakeDistribution = - Some (consensusQueryInEraInMode erainmode Consensus.GetStakeDistribution) + QueryStakeDistribution -> + Some (consensusQueryInEraInMode era Consensus.GetStakeDistribution) -toConsensusQueryShelleyBased erainmode (QueryUTxO QueryUTxOWhole) = - Some (consensusQueryInEraInMode erainmode Consensus.GetUTxOWhole) + QueryUTxO QueryUTxOWhole -> + Some (consensusQueryInEraInMode era Consensus.GetUTxOWhole) -toConsensusQueryShelleyBased erainmode (QueryUTxO (QueryUTxOByAddress addrs)) = - Some (consensusQueryInEraInMode erainmode (Consensus.GetUTxOByAddress addrs')) - where - addrs' :: Set (Shelley.Addr Consensus.StandardCrypto) - addrs' = toShelleyAddrSet (eraInModeToEra erainmode) addrs + QueryUTxO (QueryUTxOByAddress addrs) -> + Some (consensusQueryInEraInMode era (Consensus.GetUTxOByAddress addrs')) + where + addrs' :: Set (Shelley.Addr Consensus.StandardCrypto) + addrs' = toShelleyAddrSet era addrs -toConsensusQueryShelleyBased erainmode (QueryUTxO (QueryUTxOByTxIn txins)) = - Some (consensusQueryInEraInMode erainmode (Consensus.GetUTxOByTxIn txins')) - where - txins' :: Set (Shelley.TxIn Consensus.StandardCrypto) - txins' = Set.map toShelleyTxIn txins + QueryUTxO (QueryUTxOByTxIn txins) -> + Some (consensusQueryInEraInMode era (Consensus.GetUTxOByTxIn txins')) + where + txins' :: Set (Shelley.TxIn Consensus.StandardCrypto) + txins' = Set.map toShelleyTxIn txins -toConsensusQueryShelleyBased erainmode (QueryStakeAddresses creds _nId) = - Some (consensusQueryInEraInMode erainmode + QueryStakeAddresses creds _nId -> + Some (consensusQueryInEraInMode era (Consensus.GetFilteredDelegationsAndRewardAccounts creds')) - where - creds' :: Set (Shelley.Credential Shelley.Staking StandardCrypto) - creds' = Set.map toShelleyStakeCredential creds + where + creds' :: Set (Shelley.Credential Shelley.Staking StandardCrypto) + creds' = Set.map toShelleyStakeCredential creds -toConsensusQueryShelleyBased erainmode QueryStakePools = - Some (consensusQueryInEraInMode erainmode Consensus.GetStakePools) + QueryStakePools -> + Some (consensusQueryInEraInMode era Consensus.GetStakePools) -toConsensusQueryShelleyBased erainmode (QueryStakePoolParameters poolids) = - Some (consensusQueryInEraInMode erainmode (Consensus.GetStakePoolParams poolids')) - where - poolids' :: Set (Shelley.KeyHash Shelley.StakePool Consensus.StandardCrypto) - poolids' = Set.map unStakePoolKeyHash poolids + QueryStakePoolParameters poolids -> + Some (consensusQueryInEraInMode era (Consensus.GetStakePoolParams poolids')) + where + poolids' :: Set (Shelley.KeyHash Shelley.StakePool Consensus.StandardCrypto) + poolids' = Set.map unStakePoolKeyHash poolids -toConsensusQueryShelleyBased erainmode QueryDebugLedgerState = - Some (consensusQueryInEraInMode erainmode (Consensus.GetCBOR Consensus.DebugNewEpochState)) + QueryDebugLedgerState -> + Some (consensusQueryInEraInMode era (Consensus.GetCBOR Consensus.DebugNewEpochState)) -toConsensusQueryShelleyBased erainmode QueryProtocolState = - Some (consensusQueryInEraInMode erainmode (Consensus.GetCBOR Consensus.DebugChainDepState)) + QueryProtocolState -> + Some (consensusQueryInEraInMode era (Consensus.GetCBOR Consensus.DebugChainDepState)) -toConsensusQueryShelleyBased erainmode QueryCurrentEpochState = - Some (consensusQueryInEraInMode erainmode (Consensus.GetCBOR Consensus.DebugEpochState)) + QueryCurrentEpochState -> + Some (consensusQueryInEraInMode era (Consensus.GetCBOR Consensus.DebugEpochState)) -toConsensusQueryShelleyBased erainmode (QueryPoolState poolIds) = - Some (consensusQueryInEraInMode erainmode (Consensus.GetCBOR (Consensus.GetPoolState (Set.map unStakePoolKeyHash <$> poolIds)))) + QueryPoolState poolIds -> + Some (consensusQueryInEraInMode era (Consensus.GetCBOR (Consensus.GetPoolState (Set.map unStakePoolKeyHash <$> poolIds)))) -toConsensusQueryShelleyBased erainmode (QueryStakeSnapshot mPoolIds) = - Some (consensusQueryInEraInMode erainmode (Consensus.GetCBOR (Consensus.GetStakeSnapshots (fmap (Set.map unStakePoolKeyHash) mPoolIds)))) + QueryStakeSnapshot mPoolIds -> + Some (consensusQueryInEraInMode era (Consensus.GetCBOR (Consensus.GetStakeSnapshots (fmap (Set.map unStakePoolKeyHash) mPoolIds)))) -toConsensusQueryShelleyBased erainmode (QueryPoolDistribution poolIds) = - Some (consensusQueryInEraInMode erainmode (Consensus.GetCBOR (Consensus.GetPoolDistr (getPoolIds <$> poolIds)))) - where - getPoolIds :: Set PoolId -> Set (Shelley.KeyHash Shelley.StakePool Consensus.StandardCrypto) - getPoolIds = Set.map (\(StakePoolKeyHash kh) -> kh) + QueryPoolDistribution poolIds -> + Some (consensusQueryInEraInMode era (Consensus.GetCBOR (Consensus.GetPoolDistr (getPoolIds <$> poolIds)))) + where + getPoolIds :: Set PoolId -> Set (Shelley.KeyHash Shelley.StakePool Consensus.StandardCrypto) + getPoolIds = Set.map (\(StakePoolKeyHash kh) -> kh) -toConsensusQueryShelleyBased erainmode (QueryStakeDelegDeposits creds) = - Some (consensusQueryInEraInMode erainmode (Consensus.GetStakeDelegDeposits creds')) - where - creds' = Set.map toShelleyStakeCredential creds + QueryStakeDelegDeposits creds -> + Some (consensusQueryInEraInMode era (Consensus.GetStakeDelegDeposits creds')) + where + creds' = Set.map toShelleyStakeCredential creds -toConsensusQueryShelleyBased erainmode QueryGovState = - Some (consensusQueryInEraInMode erainmode Consensus.GetGovState) + QueryGovState -> + Some (consensusQueryInEraInMode era Consensus.GetGovState) -toConsensusQueryShelleyBased erainmode (QueryDRepState creds) = - Some (consensusQueryInEraInMode erainmode (Consensus.GetDRepState creds)) + QueryDRepState creds -> + Some (consensusQueryInEraInMode era (Consensus.GetDRepState creds)) -toConsensusQueryShelleyBased erainmode (QueryDRepStakeDistr dreps) = - Some (consensusQueryInEraInMode erainmode (Consensus.GetDRepStakeDistr dreps)) + QueryDRepStakeDistr dreps -> + Some (consensusQueryInEraInMode era (Consensus.GetDRepStakeDistr dreps)) -toConsensusQueryShelleyBased erainmode (QueryCommitteeMembersState coldCreds hotCreds statuses) = - Some (consensusQueryInEraInMode erainmode (Consensus.GetCommitteeMembersState coldCreds hotCreds statuses)) + QueryCommitteeMembersState coldCreds hotCreds statuses -> + Some (consensusQueryInEraInMode era (Consensus.GetCommitteeMembersState coldCreds hotCreds statuses)) + + where + era = shelleyBasedToCardanoEra sbe consensusQueryInEraInMode :: forall era erablock modeblock result result' xs. @@ -688,19 +683,19 @@ consensusQueryInEraInMode => ConsensusBlockForMode CardanoMode ~ modeblock => modeblock ~ Consensus.HardForkBlock xs => Consensus.HardForkQueryResult xs result ~ result' - => EraInMode era CardanoMode + => CardanoEra era -> Consensus.BlockQuery erablock result -> Consensus.Query modeblock result' -consensusQueryInEraInMode erainmode = +consensusQueryInEraInMode era = Consensus.BlockQuery - . case erainmode of - ByronEraInCardanoMode -> Consensus.QueryIfCurrentByron - ShelleyEraInCardanoMode -> Consensus.QueryIfCurrentShelley - AllegraEraInCardanoMode -> Consensus.QueryIfCurrentAllegra - MaryEraInCardanoMode -> Consensus.QueryIfCurrentMary - AlonzoEraInCardanoMode -> Consensus.QueryIfCurrentAlonzo - BabbageEraInCardanoMode -> Consensus.QueryIfCurrentBabbage - ConwayEraInCardanoMode -> Consensus.QueryIfCurrentConway + . case era of + ByronEra -> Consensus.QueryIfCurrentByron + ShelleyEra -> Consensus.QueryIfCurrentShelley + AllegraEra -> Consensus.QueryIfCurrentAllegra + MaryEra -> Consensus.QueryIfCurrentMary + AlonzoEra -> Consensus.QueryIfCurrentAlonzo + BabbageEra -> Consensus.QueryIfCurrentBabbage + ConwayEra -> Consensus.QueryIfCurrentConway -- ---------------------------------------------------------------------------- -- Conversions of query results from the consensus types. @@ -743,20 +738,14 @@ fromConsensusQueryResult QueryCurrentEra q' r' = -> fromConsensusEraIndex CardanoMode r' _ -> fromConsensusQueryResultMismatch -fromConsensusQueryResult (QueryInEra ByronEraInCardanoMode - QueryByronUpdateState) q' r' = +fromConsensusQueryResult (QueryInEra QueryByronUpdateState) q' r' = case q' of Consensus.BlockQuery (Consensus.QueryIfCurrentByron Consensus.GetUpdateInterfaceState) -> bimap fromConsensusEraMismatch ByronUpdateState r' _ -> fromConsensusQueryResultMismatch -fromConsensusQueryResult (QueryInEra ByronEraInCardanoMode - (QueryInShelleyBasedEra sbe _)) _ _ = - case sbe of {} - -fromConsensusQueryResult (QueryInEra ShelleyEraInCardanoMode - (QueryInShelleyBasedEra _sbe q)) q' r' = +fromConsensusQueryResult (QueryInEra (QueryInShelleyBasedEra ShelleyBasedEraShelley q)) q' r' = case q' of Consensus.BlockQuery (Consensus.QueryIfCurrentShelley q'') -> bimap fromConsensusEraMismatch @@ -765,8 +754,7 @@ fromConsensusQueryResult (QueryInEra ShelleyEraInCardanoMode r' _ -> fromConsensusQueryResultMismatch -fromConsensusQueryResult (QueryInEra AllegraEraInCardanoMode - (QueryInShelleyBasedEra _era q)) q' r' = +fromConsensusQueryResult (QueryInEra (QueryInShelleyBasedEra ShelleyBasedEraAllegra q)) q' r' = case q' of Consensus.BlockQuery (Consensus.QueryIfCurrentAllegra q'') -> bimap fromConsensusEraMismatch @@ -775,8 +763,7 @@ fromConsensusQueryResult (QueryInEra AllegraEraInCardanoMode r' _ -> fromConsensusQueryResultMismatch -fromConsensusQueryResult (QueryInEra MaryEraInCardanoMode - (QueryInShelleyBasedEra _era q)) q' r' = +fromConsensusQueryResult (QueryInEra (QueryInShelleyBasedEra ShelleyBasedEraMary q)) q' r' = case q' of Consensus.BlockQuery (Consensus.QueryIfCurrentMary q'') -> bimap fromConsensusEraMismatch @@ -785,8 +772,7 @@ fromConsensusQueryResult (QueryInEra MaryEraInCardanoMode r' _ -> fromConsensusQueryResultMismatch -fromConsensusQueryResult (QueryInEra AlonzoEraInCardanoMode - (QueryInShelleyBasedEra _era q)) q' r' = +fromConsensusQueryResult (QueryInEra (QueryInShelleyBasedEra ShelleyBasedEraAlonzo q)) q' r' = case q' of Consensus.BlockQuery (Consensus.QueryIfCurrentAlonzo q'') -> bimap fromConsensusEraMismatch @@ -795,8 +781,7 @@ fromConsensusQueryResult (QueryInEra AlonzoEraInCardanoMode r' _ -> fromConsensusQueryResultMismatch -fromConsensusQueryResult (QueryInEra BabbageEraInCardanoMode - (QueryInShelleyBasedEra _era q)) q' r' = +fromConsensusQueryResult (QueryInEra (QueryInShelleyBasedEra ShelleyBasedEraBabbage q)) q' r' = case q' of Consensus.BlockQuery (Consensus.QueryIfCurrentBabbage q'') -> bimap fromConsensusEraMismatch @@ -805,8 +790,7 @@ fromConsensusQueryResult (QueryInEra BabbageEraInCardanoMode r' _ -> fromConsensusQueryResultMismatch -fromConsensusQueryResult (QueryInEra ConwayEraInCardanoMode - (QueryInShelleyBasedEra _era q)) q' r' = +fromConsensusQueryResult (QueryInEra (QueryInShelleyBasedEra ShelleyBasedEraConway q)) q' r' = case q' of Consensus.BlockQuery (Consensus.QueryIfCurrentConway q'') -> bimap fromConsensusEraMismatch diff --git a/cardano-api/internal/Cardano/Api/Query/Expr.hs b/cardano-api/internal/Cardano/Api/Query/Expr.hs index 37d6706c2c..4132f94608 100644 --- a/cardano-api/internal/Cardano/Api/Query/Expr.hs +++ b/cardano-api/internal/Cardano/Api/Query/Expr.hs @@ -43,7 +43,6 @@ import Cardano.Api.GenesisParameters import Cardano.Api.IPC import Cardano.Api.IPC.Monad import Cardano.Api.Keys.Shelley -import Cardano.Api.Modes import Cardano.Api.NetworkId import Cardano.Api.ProtocolParameters import Cardano.Api.Query @@ -81,25 +80,22 @@ queryCurrentEra = queryExpr QueryCurrentEra queryCurrentEpochState :: () - => EraInMode era CardanoMode - -> ShelleyBasedEra era + => ShelleyBasedEra era -> LocalStateQueryExpr block point (QueryInMode CardanoMode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch (SerialisedCurrentEpochState era))) -queryCurrentEpochState eraInMode sbe = - queryExpr $ QueryInEra eraInMode $ QueryInShelleyBasedEra sbe QueryCurrentEpochState +queryCurrentEpochState sbe = + queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe QueryCurrentEpochState queryEpoch :: () - => EraInMode era CardanoMode - -> ShelleyBasedEra era + => ShelleyBasedEra era -> LocalStateQueryExpr block point (QueryInMode CardanoMode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch EpochNo)) -queryEpoch eraInMode sbe = - queryExpr $ QueryInEra eraInMode $ QueryInShelleyBasedEra sbe QueryEpoch +queryEpoch sbe = + queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe QueryEpoch queryDebugLedgerState :: () - => EraInMode era CardanoMode - -> ShelleyBasedEra era + => ShelleyBasedEra era -> LocalStateQueryExpr block point (QueryInMode CardanoMode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch (SerialisedDebugLedgerState era))) -queryDebugLedgerState eraInMode sbe = - queryExpr $ QueryInEra eraInMode $ QueryInShelleyBasedEra sbe QueryDebugLedgerState +queryDebugLedgerState sbe = + queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe QueryDebugLedgerState queryEraHistory :: () => LocalStateQueryExpr block point (QueryInMode CardanoMode) r IO (Either UnsupportedNtcVersionError EraHistory) @@ -107,105 +103,92 @@ queryEraHistory = queryExpr QueryEraHistory queryGenesisParameters :: () - => EraInMode era CardanoMode - -> ShelleyBasedEra era + => ShelleyBasedEra era -> LocalStateQueryExpr block point (QueryInMode CardanoMode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch (GenesisParameters ShelleyEra))) -queryGenesisParameters eraInMode sbe = - queryExpr $ QueryInEra eraInMode $ QueryInShelleyBasedEra sbe QueryGenesisParameters +queryGenesisParameters sbe = + queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe QueryGenesisParameters queryPoolDistribution :: () - => EraInMode era CardanoMode - -> ShelleyBasedEra era + => ShelleyBasedEra era -> Maybe (Set PoolId) -> LocalStateQueryExpr block point (QueryInMode CardanoMode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch (SerialisedPoolDistribution era))) -queryPoolDistribution eraInMode sbe mPoolIds = - queryExpr $ QueryInEra eraInMode $ QueryInShelleyBasedEra sbe $ QueryPoolDistribution mPoolIds +queryPoolDistribution sbe mPoolIds = + queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe $ QueryPoolDistribution mPoolIds queryPoolState :: () - => EraInMode era CardanoMode - -> ShelleyBasedEra era + => ShelleyBasedEra era -> Maybe (Set PoolId) -> LocalStateQueryExpr block point (QueryInMode CardanoMode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch (SerialisedPoolState era))) -queryPoolState eraInMode sbe mPoolIds = - queryExpr $ QueryInEra eraInMode $ QueryInShelleyBasedEra sbe $ QueryPoolState mPoolIds +queryPoolState sbe mPoolIds = + queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe $ QueryPoolState mPoolIds queryProtocolParameters :: () - => EraInMode era CardanoMode - -> ShelleyBasedEra era + => ShelleyBasedEra era -> LocalStateQueryExpr block point (QueryInMode CardanoMode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch (Ledger.PParams (ShelleyLedgerEra era)))) -queryProtocolParameters eraInMode sbe = - queryExpr $ QueryInEra eraInMode $ QueryInShelleyBasedEra sbe QueryProtocolParameters +queryProtocolParameters sbe = + queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe QueryProtocolParameters queryConstitutionHash :: () - => EraInMode era CardanoMode - -> ShelleyBasedEra era + => ShelleyBasedEra era -> LocalStateQueryExpr block point (QueryInMode CardanoMode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch (Maybe (SafeHash (EraCrypto (ShelleyLedgerEra era)) L.AnchorData)))) -queryConstitutionHash eraInMode sbe = +queryConstitutionHash sbe = (fmap . fmap . fmap . fmap) (L.anchorDataHash . L.constitutionAnchor) - $ queryExpr $ QueryInEra eraInMode $ QueryInShelleyBasedEra sbe QueryConstitution + $ queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe QueryConstitution queryProtocolParametersUpdate :: () - => EraInMode era CardanoMode - -> ShelleyBasedEra era + => ShelleyBasedEra era -> LocalStateQueryExpr block point (QueryInMode CardanoMode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch (Map (Hash GenesisKey) ProtocolParametersUpdate))) -queryProtocolParametersUpdate eraInMode sbe = - queryExpr $ QueryInEra eraInMode $ QueryInShelleyBasedEra sbe QueryProtocolParametersUpdate +queryProtocolParametersUpdate sbe = + queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe QueryProtocolParametersUpdate queryProtocolState :: () - => EraInMode era CardanoMode - -> ShelleyBasedEra era + => ShelleyBasedEra era -> LocalStateQueryExpr block point (QueryInMode CardanoMode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch (ProtocolState era))) -queryProtocolState eraInMode sbe = - queryExpr $ QueryInEra eraInMode $ QueryInShelleyBasedEra sbe QueryProtocolState +queryProtocolState sbe = + queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe QueryProtocolState queryStakeAddresses :: () - => EraInMode era CardanoMode - -> ShelleyBasedEra era + => ShelleyBasedEra era -> Set StakeCredential -> NetworkId -> LocalStateQueryExpr block point (QueryInMode CardanoMode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch (Map StakeAddress Lovelace, Map StakeAddress PoolId))) -queryStakeAddresses eraInMode sbe stakeCredentials networkId = - queryExpr $ QueryInEra eraInMode $ QueryInShelleyBasedEra sbe $ QueryStakeAddresses stakeCredentials networkId +queryStakeAddresses sbe stakeCredentials networkId = + queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe $ QueryStakeAddresses stakeCredentials networkId queryStakeDelegDeposits :: () - => EraInMode era CardanoMode - -> ShelleyBasedEra era + => ShelleyBasedEra era -> Set StakeCredential -> LocalStateQueryExpr block point (QueryInMode CardanoMode) r IO (Either UnsupportedNtcVersionError (Either Consensus.EraMismatch (Map StakeCredential Lovelace))) -queryStakeDelegDeposits eraInMode sbe stakeCreds +queryStakeDelegDeposits sbe stakeCreds | S.null stakeCreds = pure . pure $ pure mempty - | otherwise = queryExpr $ QueryInEra eraInMode . QueryInShelleyBasedEra sbe $ QueryStakeDelegDeposits stakeCreds + | otherwise = queryExpr $ QueryInEra . QueryInShelleyBasedEra sbe $ QueryStakeDelegDeposits stakeCreds queryStakeDistribution :: () - => EraInMode era CardanoMode - -> ShelleyBasedEra era + => ShelleyBasedEra era -> LocalStateQueryExpr block point (QueryInMode CardanoMode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch (Map (Hash StakePoolKey) Rational))) -queryStakeDistribution eraInMode sbe = - queryExpr $ QueryInEra eraInMode $ QueryInShelleyBasedEra sbe QueryStakeDistribution +queryStakeDistribution sbe = + queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe QueryStakeDistribution queryStakePoolParameters :: () - => EraInMode era CardanoMode - -> ShelleyBasedEra era + => ShelleyBasedEra era -> Set PoolId -> LocalStateQueryExpr block point (QueryInMode CardanoMode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch (Map PoolId StakePoolParameters))) -queryStakePoolParameters eraInMode sbe poolIds +queryStakePoolParameters sbe poolIds | S.null poolIds = pure . pure $ pure mempty - | otherwise = queryExpr $ QueryInEra eraInMode $ QueryInShelleyBasedEra sbe $ QueryStakePoolParameters poolIds + | otherwise = queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe $ QueryStakePoolParameters poolIds queryStakePools :: () - => EraInMode era CardanoMode - -> ShelleyBasedEra era + => ShelleyBasedEra era -> LocalStateQueryExpr block point (QueryInMode CardanoMode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch (Set PoolId))) -queryStakePools eraInMode sbe = - queryExpr $ QueryInEra eraInMode . QueryInShelleyBasedEra sbe $ QueryStakePools +queryStakePools sbe = + queryExpr $ QueryInEra . QueryInShelleyBasedEra sbe $ QueryStakePools queryStakeSnapshot :: () - => EraInMode era CardanoMode - -> ShelleyBasedEra era + => ShelleyBasedEra era -> Maybe (Set PoolId) -> LocalStateQueryExpr block point (QueryInMode CardanoMode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch (SerialisedStakeSnapshots era))) -queryStakeSnapshot eraInMode sbe mPoolIds = - queryExpr $ QueryInEra eraInMode $ QueryInShelleyBasedEra sbe $ QueryStakeSnapshot mPoolIds +queryStakeSnapshot sbe mPoolIds = + queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe $ QueryStakeSnapshot mPoolIds querySystemStart :: () => LocalStateQueryExpr block point (QueryInMode CardanoMode) r IO (Either UnsupportedNtcVersionError SystemStart) @@ -213,12 +196,11 @@ querySystemStart = queryExpr QuerySystemStart queryUtxo :: () - => EraInMode era CardanoMode - -> ShelleyBasedEra era + => ShelleyBasedEra era -> QueryUTxOFilter -> LocalStateQueryExpr block point (QueryInMode CardanoMode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch (UTxO era))) -queryUtxo eraInMode sbe utxoFilter = - queryExpr $ QueryInEra eraInMode $ QueryInShelleyBasedEra sbe $ QueryUTxO utxoFilter +queryUtxo sbe utxoFilter = + queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe $ QueryUTxO utxoFilter -- | A monad expression that determines what era the node is in. determineEraExpr :: () @@ -229,43 +211,38 @@ determineEraExpr cModeParams = runExceptT $ CardanoMode -> ExceptT queryCurrentEra queryConstitution :: () - => EraInMode era CardanoMode - -> ShelleyBasedEra era + => ShelleyBasedEra era -> LocalStateQueryExpr block point (QueryInMode CardanoMode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch (Maybe (L.Constitution (ShelleyLedgerEra era))))) -queryConstitution eraInMode sbe = - queryExpr $ QueryInEra eraInMode $ QueryInShelleyBasedEra sbe QueryConstitution +queryConstitution sbe = + queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe QueryConstitution queryGovState :: () - => EraInMode era CardanoMode - -> ShelleyBasedEra era + => ShelleyBasedEra era -> LocalStateQueryExpr block point (QueryInMode CardanoMode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch (L.GovState (ShelleyLedgerEra era)))) -queryGovState eraInMode sbe = - queryExpr $ QueryInEra eraInMode $ QueryInShelleyBasedEra sbe QueryGovState +queryGovState sbe = + queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe QueryGovState queryDRepState :: () - => EraInMode era CardanoMode - -> ShelleyBasedEra era + => ShelleyBasedEra era -> Set (L.Credential L.DRepRole L.StandardCrypto) -- ^ An empty credentials set means that states for all DReps will be returned -> LocalStateQueryExpr block point (QueryInMode CardanoMode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch (Map (L.Credential L.DRepRole L.StandardCrypto) (L.DRepState L.StandardCrypto)))) -queryDRepState eraInMode sbe drepCreds = queryExpr $ QueryInEra eraInMode $ QueryInShelleyBasedEra sbe $ QueryDRepState drepCreds +queryDRepState sbe drepCreds = queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe $ QueryDRepState drepCreds queryDRepStakeDistribution :: () - => EraInMode era CardanoMode - -> ShelleyBasedEra era + => ShelleyBasedEra era -> Set (L.DRep L.StandardCrypto) -- ^ An empty DRep set means that distributions for all DReps will be returned -> LocalStateQueryExpr block point (QueryInMode CardanoMode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch (Map (L.DRep L.StandardCrypto) Lovelace))) -queryDRepStakeDistribution eraInMode sbe dreps = queryExpr $ QueryInEra eraInMode $ QueryInShelleyBasedEra sbe $ QueryDRepStakeDistr dreps +queryDRepStakeDistribution sbe dreps = queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe $ QueryDRepStakeDistr dreps -- | Returns info about committee members filtered by: cold credentials, hot credentials and statuses. -- If empty sets are passed as filters, then no filtering is done. queryCommitteeMembersState :: () - => EraInMode era CardanoMode - -> ShelleyBasedEra era + => ShelleyBasedEra era -> Set (L.Credential L.ColdCommitteeRole L.StandardCrypto) -> Set (L.Credential L.HotCommitteeRole L.StandardCrypto) -> Set L.MemberStatus -> LocalStateQueryExpr block point (QueryInMode CardanoMode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch (Maybe (L.CommitteeMembersState L.StandardCrypto)))) -queryCommitteeMembersState eraInMode sbe coldCreds hotCreds statuses = - queryExpr $ QueryInEra eraInMode $ QueryInShelleyBasedEra sbe (QueryCommitteeMembersState coldCreds hotCreds statuses) +queryCommitteeMembersState sbe coldCreds hotCreds statuses = + queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe (QueryCommitteeMembersState coldCreds hotCreds statuses) From 26cd16665e07af4ff5529961c4145b5827d6717d Mon Sep 17 00:00:00 2001 From: John Ky Date: Fri, 27 Oct 2023 18:54:55 +1100 Subject: [PATCH 18/37] Delete ConsensusBlockForMode type family --- cardano-api/internal/Cardano/Api/Block.hs | 23 ++++++++++++---------- cardano-api/internal/Cardano/Api/IPC.hs | 17 ++++++++-------- cardano-api/internal/Cardano/Api/InMode.hs | 9 +++++---- cardano-api/internal/Cardano/Api/Modes.hs | 6 ++---- cardano-api/internal/Cardano/Api/Query.hs | 10 +++++----- cardano-api/src/Cardano/Api.hs | 1 - 6 files changed, 34 insertions(+), 32 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/Block.hs b/cardano-api/internal/Cardano/Api/Block.hs index e6a2010857..90e3e23ff3 100644 --- a/cardano-api/internal/Cardano/Api/Block.hs +++ b/cardano-api/internal/Cardano/Api/Block.hs @@ -66,6 +66,7 @@ import qualified Cardano.Chain.Block as Byron import qualified Cardano.Chain.UTxO as Byron import qualified Cardano.Crypto.Hash.Class as Crypto import qualified Cardano.Crypto.Hashing +import qualified Cardano.Ledger.Api as L import qualified Cardano.Ledger.Block as Ledger import qualified Cardano.Ledger.Era as Ledger import Cardano.Slotting.Block (BlockNo) @@ -200,7 +201,7 @@ data BlockInMode where deriving instance Show BlockInMode fromConsensusBlock :: () - => ConsensusBlockForMode CardanoMode ~ block + => Consensus.CardanoBlock L.StandardCrypto ~ block => ConsensusMode CardanoMode -> block -> BlockInMode @@ -214,7 +215,7 @@ fromConsensusBlock CardanoMode = \case Consensus.BlockConway b' -> BlockInMode cardanoEra $ ShelleyBlock ShelleyBasedEraConway b' toConsensusBlock :: () - => ConsensusBlockForMode CardanoMode ~ block + => Consensus.CardanoBlock L.StandardCrypto ~ block => BlockInMode -> block toConsensusBlock = \case @@ -313,17 +314,19 @@ instance FromJSON ChainPoint where "ChainPoint" -> ChainPoint <$> o .: "slot" <*> o .: "blockHash" _ -> fail "Expected tag to be ChainPointAtGenesis | ChainPoint" -toConsensusPointInMode :: ConsensusMode mode - -> ChainPoint - -> Consensus.Point (ConsensusBlockForMode mode) +toConsensusPointInMode :: () + => ConsensusMode CardanoMode + -> ChainPoint + -> Consensus.Point (Consensus.CardanoBlock L.StandardCrypto) -- It's the same concrete impl in all cases, but we have to show -- individually for each case that we satisfy the type equality constraint -- HeaderHash block ~ OneEraHash xs toConsensusPointInMode CardanoMode = toConsensusPointHF -fromConsensusPointInMode :: ConsensusMode mode - -> Consensus.Point (ConsensusBlockForMode mode) - -> ChainPoint +fromConsensusPointInMode :: () + => ConsensusMode CardanoMode + -> Consensus.Point (Consensus.CardanoBlock L.StandardCrypto) + -> ChainPoint fromConsensusPointInMode CardanoMode = fromConsensusPointHF @@ -410,8 +413,8 @@ makeChainTip woBlockNo chainPoint = case woBlockNo of ChainPointAtGenesis -> ChainTipAtGenesis ChainPoint slotNo headerHash -> ChainTip slotNo headerHash blockNo -fromConsensusTip :: ConsensusBlockForMode mode ~ block - => ConsensusMode mode +fromConsensusTip :: Consensus.CardanoBlock L.StandardCrypto ~ block + => ConsensusMode CardanoMode -> Consensus.Tip block -> ChainTip fromConsensusTip CardanoMode = conv diff --git a/cardano-api/internal/Cardano/Api/IPC.hs b/cardano-api/internal/Cardano/Api/IPC.hs index 9cee264d2a..3cc9b3781d 100644 --- a/cardano-api/internal/Cardano/Api/IPC.hs +++ b/cardano-api/internal/Cardano/Api/IPC.hs @@ -92,7 +92,9 @@ import Cardano.Api.Query import Cardano.Api.Tx (getTxBody) import Cardano.Api.TxBody +import qualified Cardano.Ledger.Api as L import qualified Ouroboros.Consensus.Block as Consensus +import qualified Ouroboros.Consensus.Cardano.Block as Consensus import Ouroboros.Consensus.Cardano.CanHardFork import qualified Ouroboros.Consensus.Ledger.Query as Consensus import qualified Ouroboros.Consensus.Ledger.SupportsMempool as Consensus @@ -101,7 +103,6 @@ import qualified Ouroboros.Consensus.Network.NodeToClient as Consensus import qualified Ouroboros.Consensus.Node.NetworkProtocolVersion as Consensus import qualified Ouroboros.Consensus.Node.ProtocolInfo as Consensus import qualified Ouroboros.Consensus.Protocol.TPraos as Consensus -import qualified Ouroboros.Consensus.Shelley.Eras as Consensus import qualified Ouroboros.Consensus.Shelley.Ledger.Block as Consensus import Ouroboros.Consensus.Shelley.Ledger.SupportsProtocol () import qualified Ouroboros.Network.Block as Net @@ -393,7 +394,7 @@ data LocalNodeClientProtocolsForBlock block = -- | Convert from the mode-parametrised style to the block-parametrised style. -- mkLocalNodeClientParams :: forall block. () - => ConsensusBlockForMode CardanoMode ~ block + => Consensus.CardanoBlock L.StandardCrypto ~ block => ConsensusModeParams CardanoMode -> (NodeToClientVersion -> LocalNodeClientProtocolsInMode) -> LocalNodeClientParams @@ -417,7 +418,7 @@ mkLocalNodeClientParams modeparams clients = convLocalNodeClientProtocols :: forall block. () - => ConsensusBlockForMode CardanoMode ~ block + => Consensus.CardanoBlock L.StandardCrypto ~ block => ConsensusMode CardanoMode -> LocalNodeClientProtocolsInMode -> LocalNodeClientProtocolsForBlock block @@ -441,7 +442,7 @@ convLocalNodeClientProtocols } convLocalTxMonitoringClient :: forall block m a. () - => ConsensusBlockForMode CardanoMode ~ block + => Consensus.CardanoBlock L.StandardCrypto ~ block => Functor m => ConsensusMode CardanoMode -> LocalTxMonitorClient TxIdInMode TxInMode SlotNo m a @@ -453,7 +454,7 @@ convLocalTxMonitoringClient mode = convLocalChainSyncClient :: forall block m a. () - => ConsensusBlockForMode CardanoMode ~ block + => Consensus.CardanoBlock L.StandardCrypto ~ block => Functor m => ConsensusMode CardanoMode -> ChainSyncClient BlockInMode ChainPoint ChainTip m a @@ -466,7 +467,7 @@ convLocalChainSyncClient mode = (fromConsensusTip mode) convLocalChainSyncClientPipelined :: forall block m a. () - => ConsensusBlockForMode CardanoMode ~ block + => Consensus.CardanoBlock L.StandardCrypto ~ block => Functor m => ConsensusMode CardanoMode -> ChainSyncClientPipelined BlockInMode ChainPoint ChainTip m a @@ -479,7 +480,7 @@ convLocalChainSyncClientPipelined mode = (fromConsensusTip mode) convLocalTxSubmissionClient :: forall block m a. () - => ConsensusBlockForMode CardanoMode ~ block + => Consensus.CardanoBlock L.StandardCrypto ~ block => Functor m => ConsensusMode CardanoMode -> LocalTxSubmissionClient TxInMode TxValidationErrorInCardanoMode m a @@ -492,7 +493,7 @@ convLocalTxSubmissionClient mode = convLocalStateQueryClient :: forall block m a. () - => ConsensusBlockForMode CardanoMode ~ block + => Consensus.CardanoBlock L.StandardCrypto ~ block => Functor m => ConsensusMode CardanoMode -> LocalStateQueryClient BlockInMode ChainPoint (QueryInMode CardanoMode) m a diff --git a/cardano-api/internal/Cardano/Api/InMode.hs b/cardano-api/internal/Cardano/Api/InMode.hs index 635088e20e..ed16ea2257 100644 --- a/cardano-api/internal/Cardano/Api/InMode.hs +++ b/cardano-api/internal/Cardano/Api/InMode.hs @@ -32,6 +32,7 @@ import Cardano.Api.Modes import Cardano.Api.Tx import Cardano.Api.TxBody +import qualified Cardano.Ledger.Api as L import qualified Ouroboros.Consensus.Byron.Ledger as Consensus import qualified Ouroboros.Consensus.Cardano.Block as Consensus import qualified Ouroboros.Consensus.HardFork.Combinator as Consensus @@ -74,7 +75,7 @@ data TxInMode where deriving instance Show TxInMode fromConsensusGenTx :: () - => ConsensusBlockForMode CardanoMode ~ block + => Consensus.CardanoBlock L.StandardCrypto ~ block => ConsensusMode CardanoMode -> Consensus.GenTx block -> TxInMode @@ -106,7 +107,7 @@ fromConsensusGenTx CardanoMode (Consensus.HardForkGenTx (Consensus.OneEraGenTx ( in TxInMode (ShelleyTx ShelleyBasedEraConway shelleyEraTx) ConwayEraInCardanoMode toConsensusGenTx :: () - => ConsensusBlockForMode CardanoMode ~ block + => Consensus.CardanoBlock L.StandardCrypto ~ block => TxInMode -> Consensus.GenTx block toConsensusGenTx (TxInMode (ByronTx ByronEraOnlyByron tx) ByronEraInCardanoMode) = @@ -170,7 +171,7 @@ data TxIdInMode where -> TxIdInMode toConsensusTxId :: () - => ConsensusBlockForMode CardanoMode ~ block + => Consensus.CardanoBlock L.StandardCrypto ~ block => TxIdInMode -> Consensus.TxId (Consensus.GenTx block) toConsensusTxId (TxIdInMode ByronEra txid) = @@ -296,7 +297,7 @@ deriving instance Show TxValidationErrorInCardanoMode fromConsensusApplyTxErr :: () - => ConsensusBlockForMode CardanoMode ~ block + => Consensus.CardanoBlock L.StandardCrypto ~ block => ConsensusMode CardanoMode -> Consensus.ApplyTxErr block -> TxValidationErrorInCardanoMode diff --git a/cardano-api/internal/Cardano/Api/Modes.hs b/cardano-api/internal/Cardano/Api/Modes.hs index 4f95953f24..37f6da45d5 100644 --- a/cardano-api/internal/Cardano/Api/Modes.hs +++ b/cardano-api/internal/Cardano/Api/Modes.hs @@ -35,7 +35,6 @@ module Cardano.Api.Modes ( -- * Conversions to and from types in the consensus library ConsensusCryptoForBlock, - ConsensusBlockForMode, ConsensusBlockForEra, toConsensusEraIndex, fromConsensusEraIndex, @@ -44,6 +43,7 @@ module Cardano.Api.Modes ( import Cardano.Api.Eras.Core import qualified Cardano.Chain.Slotting as Byron (EpochSlots (..)) +import qualified Cardano.Ledger.Api as L import Cardano.Ledger.Crypto (StandardCrypto) import qualified Ouroboros.Consensus.Byron.Ledger as Consensus import qualified Ouroboros.Consensus.Cardano.Block as Consensus @@ -220,8 +220,6 @@ deriving instance Show (ConsensusModeParams mode) -- | A closed type family that maps between the consensus mode (from this API) -- and the block type used by the consensus libraries. -- -type family ConsensusBlockForMode mode where - ConsensusBlockForMode CardanoMode = Consensus.CardanoBlock StandardCrypto type family ConsensusBlockForEra era where ConsensusBlockForEra ByronEra = Consensus.ByronBlock @@ -275,7 +273,7 @@ eraIndex6 :: Consensus.EraIndex (x6 : x5 : x4 : x3 : x2 : x1 : x0 : xs) eraIndex6 = eraIndexSucc eraIndex5 toConsensusEraIndex :: () - => ConsensusBlockForMode CardanoMode ~ Consensus.HardForkBlock xs + => Consensus.CardanoBlock L.StandardCrypto ~ Consensus.HardForkBlock xs => CardanoEra era -> Consensus.EraIndex xs toConsensusEraIndex = \case diff --git a/cardano-api/internal/Cardano/Api/Query.hs b/cardano-api/internal/Cardano/Api/Query.hs index 27a9d1290c..4e800dfdcc 100644 --- a/cardano-api/internal/Cardano/Api/Query.hs +++ b/cardano-api/internal/Cardano/Api/Query.hs @@ -183,7 +183,7 @@ instance NodeToClientVersionOf (QueryInMode mode result) where data EraHistory where EraHistory - :: ConsensusBlockForMode CardanoMode ~ Consensus.HardForkBlock xs + :: Consensus.CardanoBlock L.StandardCrypto ~ Consensus.HardForkBlock xs => ConsensusMode CardanoMode -> History.Interpreter xs -> EraHistory @@ -552,7 +552,7 @@ fromShelleyRewardAccounts = -- toConsensusQuery :: forall block result. () - => ConsensusBlockForMode CardanoMode ~ block + => Consensus.CardanoBlock L.StandardCrypto ~ block => QueryInMode CardanoMode result -> Some (Consensus.Query block) toConsensusQuery QueryCurrentEra = @@ -582,7 +582,7 @@ toConsensusQuery (QueryInEra (QueryInShelleyBasedEra sbe q)) = toConsensusQueryShelleyBased :: forall era protocol block result. () => ConsensusBlockForEra era ~ Consensus.ShelleyBlock protocol (ShelleyLedgerEra era) => Core.EraCrypto (ShelleyLedgerEra era) ~ Consensus.StandardCrypto - => ConsensusBlockForMode CardanoMode ~ block + => Consensus.CardanoBlock L.StandardCrypto ~ block => ShelleyBasedEra era -> QueryInShelleyBasedEra era result -> Some (Consensus.Query block) @@ -680,7 +680,7 @@ toConsensusQueryShelleyBased sbe = \case consensusQueryInEraInMode :: forall era erablock modeblock result result' xs. ConsensusBlockForEra era ~ erablock - => ConsensusBlockForMode CardanoMode ~ modeblock + => Consensus.CardanoBlock L.StandardCrypto ~ modeblock => modeblock ~ Consensus.HardForkBlock xs => Consensus.HardForkQueryResult xs result ~ result' => CardanoEra era @@ -703,7 +703,7 @@ consensusQueryInEraInMode era = fromConsensusQueryResult :: forall block result result'. () => HasCallStack - => ConsensusBlockForMode CardanoMode ~ block + => Consensus.CardanoBlock L.StandardCrypto ~ block => QueryInMode CardanoMode result -> Consensus.Query block result' -> result' diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs index 5b15056a52..a046d33af2 100644 --- a/cardano-api/src/Cardano/Api.hs +++ b/cardano-api/src/Cardano/Api.hs @@ -794,7 +794,6 @@ module Cardano.Api ( ConsensusModeParams(..), ConsensusProtocol, ChainDepStateProtocol, - ConsensusBlockForMode, ConsensusBlockForEra, EraInMode(..), toEraInMode, From 98db317615b7a64db857b55702ca20e4f854ef65 Mon Sep 17 00:00:00 2001 From: John Ky Date: Fri, 27 Oct 2023 19:04:26 +1100 Subject: [PATCH 19/37] Replace EraInMode era CardanoMode in TxInMode with CardanoEra --- cardano-api/internal/Cardano/Api/IPC.hs | 2 +- cardano-api/internal/Cardano/Api/InMode.hs | 35 +++++++++++----------- 2 files changed, 19 insertions(+), 18 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/IPC.hs b/cardano-api/internal/Cardano/Api/IPC.hs index 3cc9b3781d..01838f3acf 100644 --- a/cardano-api/internal/Cardano/Api/IPC.hs +++ b/cardano-api/internal/Cardano/Api/IPC.hs @@ -656,7 +656,7 @@ instance ToJSON LocalTxMonitoringResult where ] where txId = case txInMode of - Just (TxInMode tx _) -> Just $ getTxId $ getTxBody tx + Just (TxInMode _ tx) -> Just $ getTxId $ getTxBody tx -- TODO: support fetching the ID of a Byron Era transaction _ -> Nothing LocalTxMonitoringMempoolSizeAndCapacity mempool slot -> diff --git a/cardano-api/internal/Cardano/Api/InMode.hs b/cardano-api/internal/Cardano/Api/InMode.hs index ed16ea2257..b5e22dc7a4 100644 --- a/cardano-api/internal/Cardano/Api/InMode.hs +++ b/cardano-api/internal/Cardano/Api/InMode.hs @@ -59,8 +59,8 @@ data TxInMode where -- | Everything we consider a normal transaction. -- TxInMode - :: Tx era - -> EraInMode era CardanoMode + :: CardanoEra era + -> Tx era -> TxInMode -- | Byron has various things we can post to the chain which are not @@ -84,34 +84,35 @@ fromConsensusGenTx CardanoMode (Consensus.HardForkGenTx (Consensus.OneEraGenTx ( fromConsensusGenTx CardanoMode (Consensus.HardForkGenTx (Consensus.OneEraGenTx (S (Z tx')))) = let Consensus.ShelleyTx _txid shelleyEraTx = tx' - in TxInMode (ShelleyTx ShelleyBasedEraShelley shelleyEraTx) ShelleyEraInCardanoMode + in TxInMode ShelleyEra (ShelleyTx ShelleyBasedEraShelley shelleyEraTx) fromConsensusGenTx CardanoMode (Consensus.HardForkGenTx (Consensus.OneEraGenTx (S (S (Z tx'))))) = let Consensus.ShelleyTx _txid shelleyEraTx = tx' - in TxInMode (ShelleyTx ShelleyBasedEraAllegra shelleyEraTx) AllegraEraInCardanoMode + in TxInMode AllegraEra (ShelleyTx ShelleyBasedEraAllegra shelleyEraTx) fromConsensusGenTx CardanoMode (Consensus.HardForkGenTx (Consensus.OneEraGenTx (S (S (S (Z tx')))))) = let Consensus.ShelleyTx _txid shelleyEraTx = tx' - in TxInMode (ShelleyTx ShelleyBasedEraMary shelleyEraTx) MaryEraInCardanoMode + in TxInMode MaryEra (ShelleyTx ShelleyBasedEraMary shelleyEraTx) fromConsensusGenTx CardanoMode (Consensus.HardForkGenTx (Consensus.OneEraGenTx (S (S (S (S (Z tx'))))))) = let Consensus.ShelleyTx _txid shelleyEraTx = tx' - in TxInMode (ShelleyTx ShelleyBasedEraAlonzo shelleyEraTx) AlonzoEraInCardanoMode + in TxInMode AlonzoEra (ShelleyTx ShelleyBasedEraAlonzo shelleyEraTx) fromConsensusGenTx CardanoMode (Consensus.HardForkGenTx (Consensus.OneEraGenTx (S (S (S (S (S (Z tx')))))))) = let Consensus.ShelleyTx _txid shelleyEraTx = tx' - in TxInMode (ShelleyTx ShelleyBasedEraBabbage shelleyEraTx) BabbageEraInCardanoMode + in TxInMode BabbageEra (ShelleyTx ShelleyBasedEraBabbage shelleyEraTx) fromConsensusGenTx CardanoMode (Consensus.HardForkGenTx (Consensus.OneEraGenTx (S (S (S (S (S (S (Z tx'))))))))) = let Consensus.ShelleyTx _txid shelleyEraTx = tx' - in TxInMode (ShelleyTx ShelleyBasedEraConway shelleyEraTx) ConwayEraInCardanoMode + in TxInMode ConwayEra (ShelleyTx ShelleyBasedEraConway shelleyEraTx) toConsensusGenTx :: () => Consensus.CardanoBlock L.StandardCrypto ~ block => TxInMode -> Consensus.GenTx block -toConsensusGenTx (TxInMode (ByronTx ByronEraOnlyByron tx) ByronEraInCardanoMode) = - Consensus.HardForkGenTx (Consensus.OneEraGenTx (Z tx')) +toConsensusGenTx (TxInMode w (ByronTx ByronEraOnlyByron tx)) = + case w of + ByronEra -> Consensus.HardForkGenTx (Consensus.OneEraGenTx (Z tx')) where tx' = Consensus.ByronTx (Consensus.byronIdTx tx) tx --TODO: add the above as mkByronTx to the consensus code, @@ -120,37 +121,37 @@ toConsensusGenTx (TxInMode (ByronTx ByronEraOnlyByron tx) ByronEraInCardanoMode) toConsensusGenTx (TxInByronSpecial gtx ByronEraInCardanoMode) = Consensus.HardForkGenTx (Consensus.OneEraGenTx (Z gtx)) -toConsensusGenTx (TxInMode (ShelleyTx _ tx) ShelleyEraInCardanoMode) = +toConsensusGenTx (TxInMode ShelleyEra (ShelleyTx _ tx)) = Consensus.HardForkGenTx (Consensus.OneEraGenTx (S (Z tx'))) where tx' = Consensus.mkShelleyTx tx -toConsensusGenTx (TxInMode (ShelleyTx _ tx) AllegraEraInCardanoMode) = +toConsensusGenTx (TxInMode AllegraEra (ShelleyTx _ tx)) = Consensus.HardForkGenTx (Consensus.OneEraGenTx (S (S (Z tx')))) where tx' = Consensus.mkShelleyTx tx -toConsensusGenTx (TxInMode (ShelleyTx _ tx) MaryEraInCardanoMode) = +toConsensusGenTx (TxInMode MaryEra (ShelleyTx _ tx)) = Consensus.HardForkGenTx (Consensus.OneEraGenTx (S (S (S (Z tx'))))) where tx' = Consensus.mkShelleyTx tx -toConsensusGenTx (TxInMode (ShelleyTx _ tx) AlonzoEraInCardanoMode) = +toConsensusGenTx (TxInMode AlonzoEra (ShelleyTx _ tx)) = Consensus.HardForkGenTx (Consensus.OneEraGenTx (S (S (S (S (Z tx')))))) where tx' = Consensus.mkShelleyTx tx -toConsensusGenTx (TxInMode (ShelleyTx _ tx) BabbageEraInCardanoMode) = +toConsensusGenTx (TxInMode BabbageEra (ShelleyTx _ tx)) = Consensus.HardForkGenTx (Consensus.OneEraGenTx (S (S (S (S (S (Z tx'))))))) where tx' = Consensus.mkShelleyTx tx -toConsensusGenTx (TxInMode (ShelleyTx _ tx) ConwayEraInCardanoMode) = +toConsensusGenTx (TxInMode ConwayEra (ShelleyTx _ tx)) = Consensus.HardForkGenTx (Consensus.OneEraGenTx (S (S (S (S (S (S (Z tx')))))))) where tx' = Consensus.mkShelleyTx tx -toConsensusGenTx (TxInMode (ShelleyTx _ _) ByronEraInCardanoMode) = +toConsensusGenTx (TxInMode ByronEra (ShelleyTx _ _)) = error "Cardano.Api.InMode.toConsensusGenTx: ShelleyTx In Byron era" -- ---------------------------------------------------------------------------- From 4748a57bb1f094e85b4cce5f2a0b4420ffed74ed Mon Sep 17 00:00:00 2001 From: John Ky Date: Fri, 27 Oct 2023 19:10:30 +1100 Subject: [PATCH 20/37] Remove EraInMode era CardanoMode from TxValidationErrorInCardanoMode type --- cardano-api/internal/Cardano/Api/IPC.hs | 12 ++--- cardano-api/internal/Cardano/Api/InMode.hs | 57 +++++++--------------- 2 files changed, 22 insertions(+), 47 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/IPC.hs b/cardano-api/internal/Cardano/Api/IPC.hs index 01838f3acf..ae87ed0751 100644 --- a/cardano-api/internal/Cardano/Api/IPC.hs +++ b/cardano-api/internal/Cardano/Api/IPC.hs @@ -436,7 +436,7 @@ convLocalNodeClientProtocols LocalChainSyncClientPipelined clientPipelined -> LocalChainSyncClientPipelined $ convLocalChainSyncClientPipelined mode clientPipelined LocalChainSyncClient client -> LocalChainSyncClient $ convLocalChainSyncClient mode client, - localTxSubmissionClientForBlock = convLocalTxSubmissionClient mode <$> localTxSubmissionClient, + localTxSubmissionClientForBlock = convLocalTxSubmissionClient <$> localTxSubmissionClient, localStateQueryClientForBlock = convLocalStateQueryClient mode <$> localStateQueryClient, localTxMonitoringClientForBlock = convLocalTxMonitoringClient mode <$> localTxMonitoringClient } @@ -482,14 +482,10 @@ convLocalChainSyncClientPipelined mode = convLocalTxSubmissionClient :: forall block m a. () => Consensus.CardanoBlock L.StandardCrypto ~ block => Functor m - => ConsensusMode CardanoMode - -> LocalTxSubmissionClient TxInMode TxValidationErrorInCardanoMode m a + => LocalTxSubmissionClient TxInMode TxValidationErrorInCardanoMode m a -> LocalTxSubmissionClient (Consensus.GenTx block) (Consensus.ApplyTxErr block) m a -convLocalTxSubmissionClient mode = - Net.Tx.mapLocalTxSubmissionClient - toConsensusGenTx - (fromConsensusApplyTxErr mode) - +convLocalTxSubmissionClient = + Net.Tx.mapLocalTxSubmissionClient toConsensusGenTx fromConsensusApplyTxErr convLocalStateQueryClient :: forall block m a. () diff --git a/cardano-api/internal/Cardano/Api/InMode.hs b/cardano-api/internal/Cardano/Api/InMode.hs index b5e22dc7a4..903921dd02 100644 --- a/cardano-api/internal/Cardano/Api/InMode.hs +++ b/cardano-api/internal/Cardano/Api/InMode.hs @@ -1,6 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeOperators #-} @@ -287,7 +288,6 @@ instance Show (TxValidationError era) where data TxValidationErrorInCardanoMode where TxValidationErrorInCardanoMode :: () => TxValidationError era - -> EraInMode era CardanoMode -> TxValidationErrorInCardanoMode TxValidationEraMismatch :: () @@ -299,43 +299,22 @@ deriving instance Show TxValidationErrorInCardanoMode fromConsensusApplyTxErr :: () => Consensus.CardanoBlock L.StandardCrypto ~ block - => ConsensusMode CardanoMode - -> Consensus.ApplyTxErr block + => Consensus.ApplyTxErr block -> TxValidationErrorInCardanoMode -fromConsensusApplyTxErr CardanoMode (Consensus.ApplyTxErrByron err) = - TxValidationErrorInCardanoMode - (ByronTxValidationError err) - ByronEraInCardanoMode - -fromConsensusApplyTxErr CardanoMode (Consensus.ApplyTxErrShelley err) = - TxValidationErrorInCardanoMode - (ShelleyTxValidationError ShelleyBasedEraShelley err) - ShelleyEraInCardanoMode - -fromConsensusApplyTxErr CardanoMode (Consensus.ApplyTxErrAllegra err) = - TxValidationErrorInCardanoMode - (ShelleyTxValidationError ShelleyBasedEraAllegra err) - AllegraEraInCardanoMode - -fromConsensusApplyTxErr CardanoMode (Consensus.ApplyTxErrMary err) = - TxValidationErrorInCardanoMode - (ShelleyTxValidationError ShelleyBasedEraMary err) - MaryEraInCardanoMode - -fromConsensusApplyTxErr CardanoMode (Consensus.ApplyTxErrAlonzo err) = - TxValidationErrorInCardanoMode - (ShelleyTxValidationError ShelleyBasedEraAlonzo err) - AlonzoEraInCardanoMode - -fromConsensusApplyTxErr CardanoMode (Consensus.ApplyTxErrBabbage err) = - TxValidationErrorInCardanoMode - (ShelleyTxValidationError ShelleyBasedEraBabbage err) - BabbageEraInCardanoMode - -fromConsensusApplyTxErr CardanoMode (Consensus.ApplyTxErrConway err) = - TxValidationErrorInCardanoMode - (ShelleyTxValidationError ShelleyBasedEraConway err) - ConwayEraInCardanoMode - -fromConsensusApplyTxErr CardanoMode (Consensus.ApplyTxErrWrongEra err) = +fromConsensusApplyTxErr = \case + Consensus.ApplyTxErrByron err -> + TxValidationErrorInCardanoMode $ ByronTxValidationError err + Consensus.ApplyTxErrShelley err -> + TxValidationErrorInCardanoMode $ ShelleyTxValidationError ShelleyBasedEraShelley err + Consensus.ApplyTxErrAllegra err -> + TxValidationErrorInCardanoMode $ ShelleyTxValidationError ShelleyBasedEraAllegra err + Consensus.ApplyTxErrMary err -> + TxValidationErrorInCardanoMode $ ShelleyTxValidationError ShelleyBasedEraMary err + Consensus.ApplyTxErrAlonzo err -> + TxValidationErrorInCardanoMode $ ShelleyTxValidationError ShelleyBasedEraAlonzo err + Consensus.ApplyTxErrBabbage err -> + TxValidationErrorInCardanoMode $ ShelleyTxValidationError ShelleyBasedEraBabbage err + Consensus.ApplyTxErrConway err -> + TxValidationErrorInCardanoMode $ ShelleyTxValidationError ShelleyBasedEraConway err + Consensus.ApplyTxErrWrongEra err -> TxValidationEraMismatch err From a957b69d6ddb9c26f5eb62a5a79429f4f8ab670d Mon Sep 17 00:00:00 2001 From: John Ky Date: Fri, 27 Oct 2023 19:14:16 +1100 Subject: [PATCH 21/37] Delete EraInMode, eraInModeToEra and toEraInMode --- cardano-api/internal/Cardano/Api/Modes.hs | 104 ------------------ cardano-api/src/Cardano/Api.hs | 2 - .../cardano-api-test/Test/Cardano/Api/Json.hs | 29 +---- 3 files changed, 1 insertion(+), 134 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/Modes.hs b/cardano-api/internal/Cardano/Api/Modes.hs index 37f6da45d5..da14929bea 100644 --- a/cardano-api/internal/Cardano/Api/Modes.hs +++ b/cardano-api/internal/Cardano/Api/Modes.hs @@ -19,11 +19,6 @@ module Cardano.Api.Modes ( AnyConsensusMode(..), renderMode, - -- * The eras supported by each mode - EraInMode(..), - eraInModeToEra, - toEraInMode, - -- * The protocols supported in each era ConsensusProtocol, ChainDepStateProtocol, @@ -55,8 +50,6 @@ import qualified Ouroboros.Consensus.Protocol.TPraos as Consensus import qualified Ouroboros.Consensus.Shelley.HFEras as Consensus import qualified Ouroboros.Consensus.Shelley.ShelleyHFC as Consensus -import Data.Aeson (FromJSON (parseJSON), ToJSON (toJSON), Value) -import Data.Aeson.Types (Parser, prependFailure, typeMismatch) import Data.SOP (K (K)) import Data.SOP.Strict (NS (S, Z)) import Data.Text (Text) @@ -96,103 +89,6 @@ deriving instance Show AnyConsensusMode renderMode :: AnyConsensusMode -> Text renderMode (AnyConsensusMode CardanoMode) = "CardanoMode" -toEraInMode :: CardanoEra era -> ConsensusMode CardanoMode -> Maybe (EraInMode era CardanoMode) -toEraInMode ByronEra CardanoMode = Just ByronEraInCardanoMode -toEraInMode ShelleyEra CardanoMode = Just ShelleyEraInCardanoMode -toEraInMode AllegraEra CardanoMode = Just AllegraEraInCardanoMode -toEraInMode MaryEra CardanoMode = Just MaryEraInCardanoMode -toEraInMode AlonzoEra CardanoMode = Just AlonzoEraInCardanoMode -toEraInMode BabbageEra CardanoMode = Just BabbageEraInCardanoMode -toEraInMode ConwayEra CardanoMode = Just ConwayEraInCardanoMode - --- | A representation of which 'CardanoEra's are included in each --- 'ConsensusMode'. --- -data EraInMode era mode where - ByronEraInCardanoMode :: EraInMode ByronEra CardanoMode - ShelleyEraInCardanoMode :: EraInMode ShelleyEra CardanoMode - AllegraEraInCardanoMode :: EraInMode AllegraEra CardanoMode - MaryEraInCardanoMode :: EraInMode MaryEra CardanoMode - AlonzoEraInCardanoMode :: EraInMode AlonzoEra CardanoMode - BabbageEraInCardanoMode :: EraInMode BabbageEra CardanoMode - ConwayEraInCardanoMode :: EraInMode ConwayEra CardanoMode - -deriving instance Show (EraInMode era mode) - -deriving instance Eq (EraInMode era mode) - -instance FromJSON (EraInMode ByronEra CardanoMode) where - parseJSON "ByronEraInCardanoMode" = pure ByronEraInCardanoMode - parseJSON invalid = - invalidJSONFailure "ByronEraInCardanoMode" - "parsing 'EraInMode ByronEra CardanoMode' failed, " - invalid - -instance FromJSON (EraInMode ShelleyEra CardanoMode) where - parseJSON "ShelleyEraInCardanoMode" = pure ShelleyEraInCardanoMode - parseJSON invalid = - invalidJSONFailure "ShelleyEraInCardanoMode" - "parsing 'EraInMode ShelleyEra CardanoMode' failed, " - invalid - -instance FromJSON (EraInMode AllegraEra CardanoMode) where - parseJSON "AllegraEraInCardanoMode" = pure AllegraEraInCardanoMode - parseJSON invalid = - invalidJSONFailure "AllegraEraInCardanoMode" - "parsing 'EraInMode AllegraEra CardanoMode' failed, " - invalid - -instance FromJSON (EraInMode MaryEra CardanoMode) where - parseJSON "MaryEraInCardanoMode" = pure MaryEraInCardanoMode - parseJSON invalid = - invalidJSONFailure "MaryEraInCardanoMode" - "parsing 'EraInMode MaryEra CardanoMode' failed, " - invalid - -instance FromJSON (EraInMode AlonzoEra CardanoMode) where - parseJSON "AlonzoEraInCardanoMode" = pure AlonzoEraInCardanoMode - parseJSON invalid = - invalidJSONFailure "AlonzoEraInCardanoMode" - "parsing 'EraInMode AlonzoEra CardanoMode' failed, " - invalid - -instance FromJSON (EraInMode BabbageEra CardanoMode) where - parseJSON "BabbageEraInCardanoMode" = pure BabbageEraInCardanoMode - parseJSON invalid = - invalidJSONFailure "BabbageEraInCardanoMode" - "parsing 'EraInMode Babbage CardanoMode' failed, " - invalid - -instance FromJSON (EraInMode ConwayEra CardanoMode) where - parseJSON "ConwayEraInCardanoMode" = pure ConwayEraInCardanoMode - parseJSON invalid = - invalidJSONFailure "ConwayEraInCardanoMode" - "parsing 'EraInMode Conway CardanoMode' failed, " - invalid - -invalidJSONFailure :: String -> String -> Value -> Parser a -invalidJSONFailure expectedType errorMsg invalidValue = - prependFailure errorMsg - (typeMismatch expectedType invalidValue) - -instance ToJSON (EraInMode era mode) where - toJSON ByronEraInCardanoMode = "ByronEraInCardanoMode" - toJSON ShelleyEraInCardanoMode = "ShelleyEraInCardanoMode" - toJSON AllegraEraInCardanoMode = "AllegraEraInCardanoMode" - toJSON MaryEraInCardanoMode = "MaryEraInCardanoMode" - toJSON AlonzoEraInCardanoMode = "AlonzoEraInCardanoMode" - toJSON BabbageEraInCardanoMode = "BabbageEraInCardanoMode" - toJSON ConwayEraInCardanoMode = "ConwayEraInCardanoMode" - -eraInModeToEra :: EraInMode era mode -> CardanoEra era -eraInModeToEra ByronEraInCardanoMode = ByronEra -eraInModeToEra ShelleyEraInCardanoMode = ShelleyEra -eraInModeToEra AllegraEraInCardanoMode = AllegraEra -eraInModeToEra MaryEraInCardanoMode = MaryEra -eraInModeToEra AlonzoEraInCardanoMode = AlonzoEra -eraInModeToEra BabbageEraInCardanoMode = BabbageEra -eraInModeToEra ConwayEraInCardanoMode = ConwayEra - -- | The consensus-mode-specific parameters needed to connect to a local node -- that is using each consensus mode. -- diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs index a046d33af2..434048fc56 100644 --- a/cardano-api/src/Cardano/Api.hs +++ b/cardano-api/src/Cardano/Api.hs @@ -795,8 +795,6 @@ module Cardano.Api ( ConsensusProtocol, ChainDepStateProtocol, ConsensusBlockForEra, - EraInMode(..), - toEraInMode, LocalNodeClientProtocols(..), LocalNodeClientParams(..), mkLocalNodeClientParams, diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Json.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Json.hs index e73cbe8a2f..704bea3d79 100644 --- a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Json.hs +++ b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Json.hs @@ -1,6 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} module Test.Cardano.Api.Json ( tests @@ -9,8 +8,7 @@ module Test.Cardano.Api.Json import Cardano.Api.Orphans () import Cardano.Api.Shelley -import Data.Aeson (FromJSON (parseJSON), ToJSON (toJSON), eitherDecode, encode) -import Data.Aeson.Types (Parser, parseEither) +import Data.Aeson (eitherDecode, encode) import Test.Gen.Cardano.Api (genAlonzoGenesis) import Test.Gen.Cardano.Api.Typed @@ -52,30 +50,6 @@ prop_json_roundtrip_txout_utxo_context = H.property $ do txOut <- forAll $ genTxOutUTxOContext BabbageEra tripping txOut encode eitherDecode -prop_json_roundtrip_eraInMode :: Property -prop_json_roundtrip_eraInMode = H.property $ do - H.assert $ parseEither rountripEraInModeParser ByronEraInCardanoMode == Right ByronEraInCardanoMode - H.assert $ parseEither rountripEraInModeParser ShelleyEraInCardanoMode == Right ShelleyEraInCardanoMode - H.assert $ parseEither rountripEraInModeParser AllegraEraInCardanoMode == Right AllegraEraInCardanoMode - H.assert $ parseEither rountripEraInModeParser MaryEraInCardanoMode == Right MaryEraInCardanoMode - H.assert $ parseEither rountripEraInModeParser AlonzoEraInCardanoMode == Right AlonzoEraInCardanoMode - H.assert $ parseEither rountripEraInModeParser BabbageEraInCardanoMode == Right BabbageEraInCardanoMode - H.assert $ parseEither rountripEraInModeParser ConwayEraInCardanoMode == Right ConwayEraInCardanoMode - - where - -- Defined this way instead of using 'tripping' in order to warn the - -- developer if there's ever a new constructor in 'EraInMode' and we would - -- need to add a new 'FromJSON' instance. - rountripEraInModeParser :: EraInMode era CardanoMode -> Parser (EraInMode era CardanoMode) - rountripEraInModeParser = \case - ByronEraInCardanoMode -> parseJSON $ toJSON ByronEraInCardanoMode - ShelleyEraInCardanoMode -> parseJSON $ toJSON ShelleyEraInCardanoMode - AllegraEraInCardanoMode -> parseJSON $ toJSON AllegraEraInCardanoMode - MaryEraInCardanoMode -> parseJSON $ toJSON MaryEraInCardanoMode - AlonzoEraInCardanoMode -> parseJSON $ toJSON AlonzoEraInCardanoMode - BabbageEraInCardanoMode -> parseJSON $ toJSON BabbageEraInCardanoMode - ConwayEraInCardanoMode -> parseJSON $ toJSON ConwayEraInCardanoMode - prop_json_roundtrip_scriptdata_detailed_json :: Property prop_json_roundtrip_scriptdata_detailed_json = H.property $ do sData <- forAll genHashableScriptData @@ -89,6 +63,5 @@ tests = testGroup "Test.Cardano.Api.Json" , testProperty "json roundtrip txoutvalue" prop_json_roundtrip_txoutvalue , testProperty "json roundtrip txout tx context" prop_json_roundtrip_txout_tx_context , testProperty "json roundtrip txout utxo context" prop_json_roundtrip_txout_utxo_context - , testProperty "json roundtrip eraInMode" prop_json_roundtrip_eraInMode , testProperty "json roundtrip scriptdata detailed json" prop_json_roundtrip_scriptdata_detailed_json ] From 2e98f75429c5fdf89dd590d6a641614a92ca618f Mon Sep 17 00:00:00 2001 From: John Ky Date: Fri, 27 Oct 2023 19:18:55 +1100 Subject: [PATCH 22/37] Inline fromConsensusPointInMode --- cardano-api/internal/Cardano/Api/Block.hs | 8 -------- cardano-api/internal/Cardano/Api/IPC.hs | 4 ++-- cardano-api/internal/Cardano/Api/Query.hs | 4 ++-- cardano-api/src/Cardano/Api/Shelley.hs | 1 - 4 files changed, 4 insertions(+), 13 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/Block.hs b/cardano-api/internal/Cardano/Api/Block.hs index 90e3e23ff3..6f9f239d02 100644 --- a/cardano-api/internal/Cardano/Api/Block.hs +++ b/cardano-api/internal/Cardano/Api/Block.hs @@ -34,7 +34,6 @@ module Cardano.Api.Block ( fromConsensusPoint, fromConsensusPointHF, toConsensusPointInMode, - fromConsensusPointInMode, toConsensusPointHF, -- * Tip of the chain @@ -323,13 +322,6 @@ toConsensusPointInMode :: () -- HeaderHash block ~ OneEraHash xs toConsensusPointInMode CardanoMode = toConsensusPointHF -fromConsensusPointInMode :: () - => ConsensusMode CardanoMode - -> Consensus.Point (Consensus.CardanoBlock L.StandardCrypto) - -> ChainPoint -fromConsensusPointInMode CardanoMode = fromConsensusPointHF - - -- | Convert a 'Consensus.Point' for multi-era block type -- toConsensusPointHF :: Consensus.HeaderHash block ~ Consensus.OneEraHash xs diff --git a/cardano-api/internal/Cardano/Api/IPC.hs b/cardano-api/internal/Cardano/Api/IPC.hs index ae87ed0751..9ed2282b85 100644 --- a/cardano-api/internal/Cardano/Api/IPC.hs +++ b/cardano-api/internal/Cardano/Api/IPC.hs @@ -462,7 +462,7 @@ convLocalChainSyncClient convLocalChainSyncClient mode = Net.Sync.mapChainSyncClient (toConsensusPointInMode mode) - (fromConsensusPointInMode mode) + fromConsensusPointHF (fromConsensusBlock mode) (fromConsensusTip mode) @@ -475,7 +475,7 @@ convLocalChainSyncClientPipelined :: forall block m a. () convLocalChainSyncClientPipelined mode = mapChainSyncClientPipelined (toConsensusPointInMode mode) - (fromConsensusPointInMode mode) + fromConsensusPointHF (fromConsensusBlock mode) (fromConsensusTip mode) diff --git a/cardano-api/internal/Cardano/Api/Query.hs b/cardano-api/internal/Cardano/Api/Query.hs index 4e800dfdcc..ede195f414 100644 --- a/cardano-api/internal/Cardano/Api/Query.hs +++ b/cardano-api/internal/Cardano/Api/Query.hs @@ -726,10 +726,10 @@ fromConsensusQueryResult QueryChainBlockNo q' r' = -> r' _ -> fromConsensusQueryResultMismatch -fromConsensusQueryResult (QueryChainPoint mode) q' r' = +fromConsensusQueryResult (QueryChainPoint _) q' r' = case q' of Consensus.GetChainPoint - -> fromConsensusPointInMode mode r' + -> fromConsensusPointHF r' _ -> fromConsensusQueryResultMismatch fromConsensusQueryResult QueryCurrentEra q' r' = diff --git a/cardano-api/src/Cardano/Api/Shelley.hs b/cardano-api/src/Cardano/Api/Shelley.hs index 0096c76acc..bb89ba1f10 100644 --- a/cardano-api/src/Cardano/Api/Shelley.hs +++ b/cardano-api/src/Cardano/Api/Shelley.hs @@ -97,7 +97,6 @@ module Cardano.Api.Shelley fromConsensusBlock, toConsensusBlock, fromConsensusTip, - fromConsensusPointInMode, fromConsensusPointHF, toConsensusPointInMode, toConsensusPointHF, From 713b8e45be968b910d1bf69525370cac746b481a Mon Sep 17 00:00:00 2001 From: John Ky Date: Fri, 27 Oct 2023 19:20:54 +1100 Subject: [PATCH 23/37] Inline toConsensusPointInMode --- cardano-api/internal/Cardano/Api/Block.hs | 10 ---------- cardano-api/internal/Cardano/Api/IPC.hs | 14 ++++++-------- cardano-api/src/Cardano/Api/Shelley.hs | 1 - 3 files changed, 6 insertions(+), 19 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/Block.hs b/cardano-api/internal/Cardano/Api/Block.hs index 6f9f239d02..a2c4e6d6ed 100644 --- a/cardano-api/internal/Cardano/Api/Block.hs +++ b/cardano-api/internal/Cardano/Api/Block.hs @@ -33,7 +33,6 @@ module Cardano.Api.Block ( toConsensusPoint, fromConsensusPoint, fromConsensusPointHF, - toConsensusPointInMode, toConsensusPointHF, -- * Tip of the chain @@ -313,15 +312,6 @@ instance FromJSON ChainPoint where "ChainPoint" -> ChainPoint <$> o .: "slot" <*> o .: "blockHash" _ -> fail "Expected tag to be ChainPointAtGenesis | ChainPoint" -toConsensusPointInMode :: () - => ConsensusMode CardanoMode - -> ChainPoint - -> Consensus.Point (Consensus.CardanoBlock L.StandardCrypto) --- It's the same concrete impl in all cases, but we have to show --- individually for each case that we satisfy the type equality constraint --- HeaderHash block ~ OneEraHash xs -toConsensusPointInMode CardanoMode = toConsensusPointHF - -- | Convert a 'Consensus.Point' for multi-era block type -- toConsensusPointHF :: Consensus.HeaderHash block ~ Consensus.OneEraHash xs diff --git a/cardano-api/internal/Cardano/Api/IPC.hs b/cardano-api/internal/Cardano/Api/IPC.hs index 9ed2282b85..11363d2631 100644 --- a/cardano-api/internal/Cardano/Api/IPC.hs +++ b/cardano-api/internal/Cardano/Api/IPC.hs @@ -437,7 +437,7 @@ convLocalNodeClientProtocols LocalChainSyncClient client -> LocalChainSyncClient $ convLocalChainSyncClient mode client, localTxSubmissionClientForBlock = convLocalTxSubmissionClient <$> localTxSubmissionClient, - localStateQueryClientForBlock = convLocalStateQueryClient mode <$> localStateQueryClient, + localStateQueryClientForBlock = convLocalStateQueryClient <$> localStateQueryClient, localTxMonitoringClientForBlock = convLocalTxMonitoringClient mode <$> localTxMonitoringClient } @@ -461,7 +461,7 @@ convLocalChainSyncClient -> ChainSyncClient block (Net.Point block) (Net.Tip block) m a convLocalChainSyncClient mode = Net.Sync.mapChainSyncClient - (toConsensusPointInMode mode) + toConsensusPointHF fromConsensusPointHF (fromConsensusBlock mode) (fromConsensusTip mode) @@ -474,7 +474,7 @@ convLocalChainSyncClientPipelined :: forall block m a. () -> ChainSyncClientPipelined block (Net.Point block) (Net.Tip block) m a convLocalChainSyncClientPipelined mode = mapChainSyncClientPipelined - (toConsensusPointInMode mode) + toConsensusPointHF fromConsensusPointHF (fromConsensusBlock mode) (fromConsensusTip mode) @@ -491,16 +491,14 @@ convLocalStateQueryClient :: forall block m a. () => Consensus.CardanoBlock L.StandardCrypto ~ block => Functor m - => ConsensusMode CardanoMode - -> LocalStateQueryClient BlockInMode ChainPoint (QueryInMode CardanoMode) m a + => LocalStateQueryClient BlockInMode ChainPoint (QueryInMode CardanoMode) m a -> LocalStateQueryClient block (Consensus.Point block) (Consensus.Query block) m a -convLocalStateQueryClient mode = +convLocalStateQueryClient = Net.Query.mapLocalStateQueryClient - (toConsensusPointInMode mode) + toConsensusPointHF toConsensusQuery fromConsensusQueryResult - --TODO: Move to consensus mapLocalTxMonitoringClient :: forall txid txid' tx tx' m a. () => Functor m diff --git a/cardano-api/src/Cardano/Api/Shelley.hs b/cardano-api/src/Cardano/Api/Shelley.hs index bb89ba1f10..7fbd21c305 100644 --- a/cardano-api/src/Cardano/Api/Shelley.hs +++ b/cardano-api/src/Cardano/Api/Shelley.hs @@ -98,7 +98,6 @@ module Cardano.Api.Shelley toConsensusBlock, fromConsensusTip, fromConsensusPointHF, - toConsensusPointInMode, toConsensusPointHF, -- * Transaction metadata From 7b6e6a383514403ad5913418e2828dbebd5d1b47 Mon Sep 17 00:00:00 2001 From: John Ky Date: Fri, 27 Oct 2023 19:25:15 +1100 Subject: [PATCH 24/37] Remove ConsensusMode argument from fromConsensusBlock --- cardano-api/internal/Cardano/Api/Block.hs | 5 ++--- cardano-api/internal/Cardano/Api/IPC.hs | 4 ++-- 2 files changed, 4 insertions(+), 5 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/Block.hs b/cardano-api/internal/Cardano/Api/Block.hs index a2c4e6d6ed..73b934cf48 100644 --- a/cardano-api/internal/Cardano/Api/Block.hs +++ b/cardano-api/internal/Cardano/Api/Block.hs @@ -200,10 +200,9 @@ deriving instance Show BlockInMode fromConsensusBlock :: () => Consensus.CardanoBlock L.StandardCrypto ~ block - => ConsensusMode CardanoMode - -> block + => block -> BlockInMode -fromConsensusBlock CardanoMode = \case +fromConsensusBlock = \case Consensus.BlockByron b' -> BlockInMode cardanoEra $ ByronBlock b' Consensus.BlockShelley b' -> BlockInMode cardanoEra $ ShelleyBlock ShelleyBasedEraShelley b' Consensus.BlockAllegra b' -> BlockInMode cardanoEra $ ShelleyBlock ShelleyBasedEraAllegra b' diff --git a/cardano-api/internal/Cardano/Api/IPC.hs b/cardano-api/internal/Cardano/Api/IPC.hs index 11363d2631..2aaa37d67e 100644 --- a/cardano-api/internal/Cardano/Api/IPC.hs +++ b/cardano-api/internal/Cardano/Api/IPC.hs @@ -463,7 +463,7 @@ convLocalChainSyncClient mode = Net.Sync.mapChainSyncClient toConsensusPointHF fromConsensusPointHF - (fromConsensusBlock mode) + fromConsensusBlock (fromConsensusTip mode) convLocalChainSyncClientPipelined :: forall block m a. () @@ -476,7 +476,7 @@ convLocalChainSyncClientPipelined mode = mapChainSyncClientPipelined toConsensusPointHF fromConsensusPointHF - (fromConsensusBlock mode) + fromConsensusBlock (fromConsensusTip mode) convLocalTxSubmissionClient :: forall block m a. () From 9551d05c3f6ebc42ef00ab247b2f34fe57e725f0 Mon Sep 17 00:00:00 2001 From: John Ky Date: Fri, 27 Oct 2023 19:33:05 +1100 Subject: [PATCH 25/37] Remove ConsensusMode argument from: * convLocalChainSyncClient * convLocalChainSyncClientPipelined * convLocalNodeClientProtocols * convLocalTxMonitoringClient * fromConsensusGenTx * fromConsensusTip --- cardano-api/internal/Cardano/Api/Block.hs | 10 ++-- cardano-api/internal/Cardano/Api/IPC.hs | 39 +++++++-------- cardano-api/internal/Cardano/Api/InMode.hs | 56 ++++++++++------------ 3 files changed, 47 insertions(+), 58 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/Block.hs b/cardano-api/internal/Cardano/Api/Block.hs index 73b934cf48..f354b58cab 100644 --- a/cardano-api/internal/Cardano/Api/Block.hs +++ b/cardano-api/internal/Cardano/Api/Block.hs @@ -394,11 +394,11 @@ makeChainTip woBlockNo chainPoint = case woBlockNo of ChainPointAtGenesis -> ChainTipAtGenesis ChainPoint slotNo headerHash -> ChainTip slotNo headerHash blockNo -fromConsensusTip :: Consensus.CardanoBlock L.StandardCrypto ~ block - => ConsensusMode CardanoMode - -> Consensus.Tip block - -> ChainTip -fromConsensusTip CardanoMode = conv +fromConsensusTip :: () + => Consensus.CardanoBlock L.StandardCrypto ~ block + => Consensus.Tip block + -> ChainTip +fromConsensusTip = conv where conv :: Consensus.Tip (Consensus.CardanoBlock Consensus.StandardCrypto) -> ChainTip diff --git a/cardano-api/internal/Cardano/Api/IPC.hs b/cardano-api/internal/Cardano/Api/IPC.hs index 2aaa37d67e..dc7420f082 100644 --- a/cardano-api/internal/Cardano/Api/IPC.hs +++ b/cardano-api/internal/Cardano/Api/IPC.hs @@ -414,16 +414,14 @@ mkLocalNodeClientParams modeparams clients = CardanoModeParams epochSlots -> LocalNodeClientParamsCardano (ProtocolClientInfoArgsCardano epochSlots) - (convLocalNodeClientProtocols CardanoMode . clients) + (convLocalNodeClientProtocols . clients) -convLocalNodeClientProtocols :: forall block. () +convLocalNodeClientProtocols :: () => Consensus.CardanoBlock L.StandardCrypto ~ block - => ConsensusMode CardanoMode - -> LocalNodeClientProtocolsInMode + => LocalNodeClientProtocolsInMode -> LocalNodeClientProtocolsForBlock block convLocalNodeClientProtocols - mode LocalNodeClientProtocols { localChainSyncClient, localTxSubmissionClient, @@ -433,51 +431,48 @@ convLocalNodeClientProtocols LocalNodeClientProtocolsForBlock { localChainSyncClientForBlock = case localChainSyncClient of NoLocalChainSyncClient -> NoLocalChainSyncClient - LocalChainSyncClientPipelined clientPipelined -> LocalChainSyncClientPipelined $ convLocalChainSyncClientPipelined mode clientPipelined - LocalChainSyncClient client -> LocalChainSyncClient $ convLocalChainSyncClient mode client, + LocalChainSyncClientPipelined clientPipelined -> LocalChainSyncClientPipelined $ convLocalChainSyncClientPipelined clientPipelined + LocalChainSyncClient client -> LocalChainSyncClient $ convLocalChainSyncClient client, - localTxSubmissionClientForBlock = convLocalTxSubmissionClient <$> localTxSubmissionClient, - localStateQueryClientForBlock = convLocalStateQueryClient <$> localStateQueryClient, - localTxMonitoringClientForBlock = convLocalTxMonitoringClient mode <$> localTxMonitoringClient + localTxSubmissionClientForBlock = convLocalTxSubmissionClient <$> localTxSubmissionClient, + localStateQueryClientForBlock = convLocalStateQueryClient <$> localStateQueryClient, + localTxMonitoringClientForBlock = convLocalTxMonitoringClient <$> localTxMonitoringClient } convLocalTxMonitoringClient :: forall block m a. () => Consensus.CardanoBlock L.StandardCrypto ~ block => Functor m - => ConsensusMode CardanoMode - -> LocalTxMonitorClient TxIdInMode TxInMode SlotNo m a + => LocalTxMonitorClient TxIdInMode TxInMode SlotNo m a -> LocalTxMonitorClient (Consensus.TxId (Consensus.GenTx block)) (Consensus.GenTx block) SlotNo m a -convLocalTxMonitoringClient mode = +convLocalTxMonitoringClient = mapLocalTxMonitoringClient toConsensusTxId - (fromConsensusGenTx mode) + fromConsensusGenTx convLocalChainSyncClient :: forall block m a. () => Consensus.CardanoBlock L.StandardCrypto ~ block => Functor m - => ConsensusMode CardanoMode - -> ChainSyncClient BlockInMode ChainPoint ChainTip m a + => ChainSyncClient BlockInMode ChainPoint ChainTip m a -> ChainSyncClient block (Net.Point block) (Net.Tip block) m a -convLocalChainSyncClient mode = +convLocalChainSyncClient = Net.Sync.mapChainSyncClient toConsensusPointHF fromConsensusPointHF fromConsensusBlock - (fromConsensusTip mode) + fromConsensusTip convLocalChainSyncClientPipelined :: forall block m a. () => Consensus.CardanoBlock L.StandardCrypto ~ block => Functor m - => ConsensusMode CardanoMode - -> ChainSyncClientPipelined BlockInMode ChainPoint ChainTip m a + => ChainSyncClientPipelined BlockInMode ChainPoint ChainTip m a -> ChainSyncClientPipelined block (Net.Point block) (Net.Tip block) m a -convLocalChainSyncClientPipelined mode = +convLocalChainSyncClientPipelined = mapChainSyncClientPipelined toConsensusPointHF fromConsensusPointHF fromConsensusBlock - (fromConsensusTip mode) + fromConsensusTip convLocalTxSubmissionClient :: forall block m a. () => Consensus.CardanoBlock L.StandardCrypto ~ block diff --git a/cardano-api/internal/Cardano/Api/InMode.hs b/cardano-api/internal/Cardano/Api/InMode.hs index 903921dd02..d37d0dc035 100644 --- a/cardano-api/internal/Cardano/Api/InMode.hs +++ b/cardano-api/internal/Cardano/Api/InMode.hs @@ -69,43 +69,37 @@ data TxInMode where -- delegation certs. -- TxInByronSpecial - :: Consensus.GenTx Consensus.ByronBlock - -> EraInMode ByronEra CardanoMode + :: ByronEraOnly era + -> Consensus.GenTx Consensus.ByronBlock -> TxInMode deriving instance Show TxInMode fromConsensusGenTx :: () => Consensus.CardanoBlock L.StandardCrypto ~ block - => ConsensusMode CardanoMode - -> Consensus.GenTx block + => Consensus.GenTx block -> TxInMode -fromConsensusGenTx CardanoMode (Consensus.HardForkGenTx (Consensus.OneEraGenTx (Z tx'))) = - TxInByronSpecial tx' ByronEraInCardanoMode - -fromConsensusGenTx CardanoMode (Consensus.HardForkGenTx (Consensus.OneEraGenTx (S (Z tx')))) = - let Consensus.ShelleyTx _txid shelleyEraTx = tx' - in TxInMode ShelleyEra (ShelleyTx ShelleyBasedEraShelley shelleyEraTx) - -fromConsensusGenTx CardanoMode (Consensus.HardForkGenTx (Consensus.OneEraGenTx (S (S (Z tx'))))) = - let Consensus.ShelleyTx _txid shelleyEraTx = tx' - in TxInMode AllegraEra (ShelleyTx ShelleyBasedEraAllegra shelleyEraTx) - -fromConsensusGenTx CardanoMode (Consensus.HardForkGenTx (Consensus.OneEraGenTx (S (S (S (Z tx')))))) = - let Consensus.ShelleyTx _txid shelleyEraTx = tx' - in TxInMode MaryEra (ShelleyTx ShelleyBasedEraMary shelleyEraTx) - -fromConsensusGenTx CardanoMode (Consensus.HardForkGenTx (Consensus.OneEraGenTx (S (S (S (S (Z tx'))))))) = - let Consensus.ShelleyTx _txid shelleyEraTx = tx' - in TxInMode AlonzoEra (ShelleyTx ShelleyBasedEraAlonzo shelleyEraTx) - -fromConsensusGenTx CardanoMode (Consensus.HardForkGenTx (Consensus.OneEraGenTx (S (S (S (S (S (Z tx')))))))) = - let Consensus.ShelleyTx _txid shelleyEraTx = tx' - in TxInMode BabbageEra (ShelleyTx ShelleyBasedEraBabbage shelleyEraTx) - -fromConsensusGenTx CardanoMode (Consensus.HardForkGenTx (Consensus.OneEraGenTx (S (S (S (S (S (S (Z tx'))))))))) = - let Consensus.ShelleyTx _txid shelleyEraTx = tx' - in TxInMode ConwayEra (ShelleyTx ShelleyBasedEraConway shelleyEraTx) +fromConsensusGenTx = \case + Consensus.HardForkGenTx (Consensus.OneEraGenTx (Z tx')) -> + TxInByronSpecial ByronEraOnlyByron tx' + Consensus.HardForkGenTx (Consensus.OneEraGenTx (S (Z tx'))) -> + let Consensus.ShelleyTx _txid shelleyEraTx = tx' + in TxInMode ShelleyEra (ShelleyTx ShelleyBasedEraShelley shelleyEraTx) + Consensus.HardForkGenTx (Consensus.OneEraGenTx (S (S (Z tx')))) -> + let Consensus.ShelleyTx _txid shelleyEraTx = tx' + in TxInMode AllegraEra (ShelleyTx ShelleyBasedEraAllegra shelleyEraTx) + Consensus.HardForkGenTx (Consensus.OneEraGenTx (S (S (S (Z tx'))))) -> + let Consensus.ShelleyTx _txid shelleyEraTx = tx' + in TxInMode MaryEra (ShelleyTx ShelleyBasedEraMary shelleyEraTx) + Consensus.HardForkGenTx (Consensus.OneEraGenTx (S (S (S (S (Z tx')))))) -> + let Consensus.ShelleyTx _txid shelleyEraTx = tx' + in TxInMode AlonzoEra (ShelleyTx ShelleyBasedEraAlonzo shelleyEraTx) + Consensus.HardForkGenTx (Consensus.OneEraGenTx (S (S (S (S (S (Z tx'))))))) -> + let Consensus.ShelleyTx _txid shelleyEraTx = tx' + in TxInMode BabbageEra (ShelleyTx ShelleyBasedEraBabbage shelleyEraTx) + Consensus.HardForkGenTx (Consensus.OneEraGenTx (S (S (S (S (S (S (Z tx')))))))) -> + let Consensus.ShelleyTx _txid shelleyEraTx = tx' + in TxInMode ConwayEra (ShelleyTx ShelleyBasedEraConway shelleyEraTx) toConsensusGenTx :: () => Consensus.CardanoBlock L.StandardCrypto ~ block @@ -119,7 +113,7 @@ toConsensusGenTx (TxInMode w (ByronTx ByronEraOnlyByron tx)) = --TODO: add the above as mkByronTx to the consensus code, -- matching mkShelleyTx below -toConsensusGenTx (TxInByronSpecial gtx ByronEraInCardanoMode) = +toConsensusGenTx (TxInByronSpecial ByronEraOnlyByron gtx) = Consensus.HardForkGenTx (Consensus.OneEraGenTx (Z gtx)) toConsensusGenTx (TxInMode ShelleyEra (ShelleyTx _ tx)) = From aa6123c2963def7ab1bfd7f6fc955df77e8acb0b Mon Sep 17 00:00:00 2001 From: John Ky Date: Fri, 27 Oct 2023 19:34:28 +1100 Subject: [PATCH 26/37] Delete ConsensusModeParams argument from ConsensusModeParams --- cardano-api/internal/Cardano/Api/Convenience/Query.hs | 9 +++------ 1 file changed, 3 insertions(+), 6 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/Convenience/Query.hs b/cardano-api/internal/Cardano/Api/Convenience/Query.hs index c17bab5955..38664a364f 100644 --- a/cardano-api/internal/Cardano/Api/Convenience/Query.hs +++ b/cardano-api/internal/Cardano/Api/Convenience/Query.hs @@ -133,13 +133,10 @@ queryStateForBalancedTx era allTxIns certs = runExceptT $ do -- | Query the node to determine which era it is in. determineEra :: () - => ConsensusModeParams CardanoMode - -> LocalNodeConnectInfo + => LocalNodeConnectInfo -> IO (Either AcquiringFailure AnyCardanoEra) -determineEra cModeParams localNodeConnInfo = - case consensusModeOnly cModeParams of - CardanoMode -> - queryNodeLocalState localNodeConnInfo Nothing QueryCurrentEra +determineEra localNodeConnInfo = + queryNodeLocalState localNodeConnInfo Nothing QueryCurrentEra -- | Execute a query against the local node. The local -- node must be in CardanoMode. From 918bcc28d3d7eb97d2834fdb673a7e335ec269d6 Mon Sep 17 00:00:00 2001 From: John Ky Date: Fri, 27 Oct 2023 19:37:36 +1100 Subject: [PATCH 27/37] Delete determineEraExpr --- cardano-api/internal/Cardano/Api/Query/Expr.hs | 10 ---------- cardano-api/src/Cardano/Api.hs | 1 - 2 files changed, 11 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/Query/Expr.hs b/cardano-api/internal/Cardano/Api/Query/Expr.hs index 4132f94608..26ab09b2f9 100644 --- a/cardano-api/internal/Cardano/Api/Query/Expr.hs +++ b/cardano-api/internal/Cardano/Api/Query/Expr.hs @@ -25,7 +25,6 @@ module Cardano.Api.Query.Expr , queryStakeSnapshot , querySystemStart , queryUtxo - , determineEraExpr , L.MemberStatus (..) , L.CommitteeMembersState (..) , queryCommitteeMembersState @@ -59,7 +58,6 @@ import Cardano.Ledger.SafeHash import Cardano.Slotting.Slot import Ouroboros.Consensus.HardFork.Combinator.AcrossEras as Consensus -import Control.Monad.Trans.Except (ExceptT (..), runExceptT) import Data.Map (Map) import Data.Set (Set) import qualified Data.Set as S @@ -202,14 +200,6 @@ queryUtxo :: () queryUtxo sbe utxoFilter = queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe $ QueryUTxO utxoFilter --- | A monad expression that determines what era the node is in. -determineEraExpr :: () - => ConsensusModeParams CardanoMode - -> LocalStateQueryExpr block point (QueryInMode CardanoMode) r IO (Either UnsupportedNtcVersionError AnyCardanoEra) -determineEraExpr cModeParams = runExceptT $ - case consensusModeOnly cModeParams of - CardanoMode -> ExceptT queryCurrentEra - queryConstitution :: () => ShelleyBasedEra era -> LocalStateQueryExpr block point (QueryInMode CardanoMode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch (Maybe (L.Constitution (ShelleyLedgerEra era))))) diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs index 434048fc56..b51f338c14 100644 --- a/cardano-api/src/Cardano/Api.hs +++ b/cardano-api/src/Cardano/Api.hs @@ -983,7 +983,6 @@ module Cardano.Api ( queryStakeSnapshot, querySystemStart, queryUtxo, - determineEraExpr, queryConstitution, queryGovState, queryDRepState, From 757742199cc592a4e7db71eb5fa0b17f2a87d410 Mon Sep 17 00:00:00 2001 From: John Ky Date: Fri, 27 Oct 2023 19:38:20 +1100 Subject: [PATCH 28/37] Delete obsolete TODO --- cardano-api/internal/Cardano/Api/Block.hs | 18 ------------------ 1 file changed, 18 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/Block.hs b/cardano-api/internal/Cardano/Api/Block.hs index f354b58cab..0b39791a91 100644 --- a/cardano-api/internal/Cardano/Api/Block.hs +++ b/cardano-api/internal/Cardano/Api/Block.hs @@ -405,21 +405,3 @@ fromConsensusTip = conv conv Consensus.TipGenesis = ChainTipAtGenesis conv (Consensus.Tip slot (Consensus.OneEraHash h) block) = ChainTip slot (HeaderHash h) block - -{- -TODO: In principle we should be able to use this common implementation rather - than repeating it for each mode above. It does actually type-check. The - problem is that (at least with ghc-8.10.x) ghc's pattern match warning - mechanism cannot see that the OneEraHash is a complete pattern match. - I'm guessing that while the type checker can use the type equality to - see that OneEraHash is a valid pattern, the exhaustiveness checker is for - some reason not able to use it to see that it is indeed the only pattern. -fromConsensusTip = - \mode -> case mode of - CardanoMode -> conv - where - conv :: HeaderHash block ~ OneEraHash xs - => Tip block -> ChainTip - conv TipGenesis = ChainTipAtGenesis - conv (Tip slot (OneEraHash h) block) = ChainTip slot (HeaderHash h) block --} From c0191e7fca6108e3cc13a728b9b1a68f2fa5bae5 Mon Sep 17 00:00:00 2001 From: John Ky Date: Fri, 27 Oct 2023 19:43:22 +1100 Subject: [PATCH 29/37] Deparameterise QueryInMode --- .../internal/Cardano/Api/Convenience/Query.hs | 6 +- cardano-api/internal/Cardano/Api/IPC.hs | 8 +-- cardano-api/internal/Cardano/Api/IPC/Monad.hs | 10 ++-- cardano-api/internal/Cardano/Api/Query.hs | 29 +++++----- .../internal/Cardano/Api/Query/Expr.hs | 56 +++++++++---------- 5 files changed, 54 insertions(+), 55 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/Convenience/Query.hs b/cardano-api/internal/Cardano/Api/Convenience/Query.hs index 38664a364f..b4c5e41f31 100644 --- a/cardano-api/internal/Cardano/Api/Convenience/Query.hs +++ b/cardano-api/internal/Cardano/Api/Convenience/Query.hs @@ -81,7 +81,7 @@ queryStateForBalancedTx :: () => CardanoEra era -> [TxIn] -> [Certificate era] - -> LocalStateQueryExpr block point (QueryInMode CardanoMode) r IO + -> LocalStateQueryExpr block point QueryInMode r IO ( Either QueryConvenienceError ( UTxO era @@ -143,7 +143,7 @@ determineEra localNodeConnInfo = executeQueryCardanoMode :: () => SocketPath -> NetworkId - -> QueryInMode CardanoMode (Either EraMismatch result) + -> QueryInMode (Either EraMismatch result) -> IO (Either QueryConvenienceError result) executeQueryCardanoMode socketPath nid q = runExceptT $ do let localNodeConnInfo = @@ -158,7 +158,7 @@ executeQueryCardanoMode socketPath nid q = runExceptT $ do -- | Execute a query against the local node in any mode. executeQueryAnyMode :: forall result. () => LocalNodeConnectInfo - -> QueryInMode CardanoMode (Either EraMismatch result) + -> QueryInMode (Either EraMismatch result) -> IO (Either QueryConvenienceError result) executeQueryAnyMode localNodeConnInfo q = runExceptT $ do lift (queryNodeLocalState localNodeConnInfo Nothing q) diff --git a/cardano-api/internal/Cardano/Api/IPC.hs b/cardano-api/internal/Cardano/Api/IPC.hs index dc7420f082..cc4693cdde 100644 --- a/cardano-api/internal/Cardano/Api/IPC.hs +++ b/cardano-api/internal/Cardano/Api/IPC.hs @@ -168,7 +168,7 @@ type LocalNodeClientProtocolsInMode = TxInMode TxIdInMode TxValidationErrorInCardanoMode - (QueryInMode CardanoMode) + QueryInMode IO data LocalNodeConnectInfo = @@ -486,7 +486,7 @@ convLocalStateQueryClient :: forall block m a. () => Consensus.CardanoBlock L.StandardCrypto ~ block => Functor m - => LocalStateQueryClient BlockInMode ChainPoint (QueryInMode CardanoMode) m a + => LocalStateQueryClient BlockInMode ChainPoint QueryInMode m a -> LocalStateQueryClient block (Consensus.Point block) (Consensus.Query block) m a convLocalStateQueryClient = Net.Query.mapLocalStateQueryClient @@ -549,7 +549,7 @@ toAcquiringFailure AcquireFailurePointNotOnChain = AFPointNotOnChain queryNodeLocalState :: forall result. () => LocalNodeConnectInfo -> Maybe ChainPoint - -> QueryInMode CardanoMode result + -> QueryInMode result -> IO (Either AcquiringFailure result) queryNodeLocalState connctInfo mpoint query = do resultVar <- newEmptyTMVarIO @@ -566,7 +566,7 @@ queryNodeLocalState connctInfo mpoint query = do singleQuery :: Maybe ChainPoint -> TMVar (Either AcquiringFailure result) - -> Net.Query.LocalStateQueryClient BlockInMode ChainPoint (QueryInMode CardanoMode) IO () + -> Net.Query.LocalStateQueryClient BlockInMode ChainPoint QueryInMode IO () singleQuery mPointVar' resultVar' = LocalStateQueryClient $ do pure $ diff --git a/cardano-api/internal/Cardano/Api/IPC/Monad.hs b/cardano-api/internal/Cardano/Api/IPC/Monad.hs index 26c269ca4c..dfe2c71151 100644 --- a/cardano-api/internal/Cardano/Api/IPC/Monad.hs +++ b/cardano-api/internal/Cardano/Api/IPC/Monad.hs @@ -43,7 +43,7 @@ newtype LocalStateQueryExpr block point query r m a = LocalStateQueryExpr executeLocalStateQueryExpr :: () => LocalNodeConnectInfo -> Maybe ChainPoint - -> LocalStateQueryExpr BlockInMode ChainPoint (QueryInMode CardanoMode) () IO a + -> LocalStateQueryExpr BlockInMode ChainPoint QueryInMode () IO a -> IO (Either AcquiringFailure a) executeLocalStateQueryExpr connectInfo mpoint f = do tmvResultLocalState <- newEmptyTMVarIO @@ -71,8 +71,8 @@ setupLocalStateQueryExpr :: -> Maybe ChainPoint -> TMVar (Either AcquiringFailure a) -> NodeToClientVersion - -> LocalStateQueryExpr BlockInMode ChainPoint (QueryInMode CardanoMode) () IO a - -> Net.Query.LocalStateQueryClient BlockInMode ChainPoint (QueryInMode CardanoMode) IO () + -> LocalStateQueryExpr BlockInMode ChainPoint QueryInMode () IO a + -> Net.Query.LocalStateQueryClient BlockInMode ChainPoint QueryInMode IO () setupLocalStateQueryExpr waitDone mPointVar' resultVar' ntcVersion f = LocalStateQueryClient . pure . Net.Query.SendMsgAcquire mPointVar' $ Net.Query.ClientStAcquiring @@ -88,11 +88,11 @@ setupLocalStateQueryExpr waitDone mPointVar' resultVar' ntcVersion f = } -- | Get the node server's Node-to-Client version. -getNtcVersion :: LocalStateQueryExpr block point (QueryInMode CardanoMode) r IO NodeToClientVersion +getNtcVersion :: LocalStateQueryExpr block point QueryInMode r IO NodeToClientVersion getNtcVersion = LocalStateQueryExpr ask -- | Use 'queryExpr' in a do block to construct monadic local state queries. -queryExpr :: QueryInMode CardanoMode a -> LocalStateQueryExpr block point (QueryInMode CardanoMode) r IO (Either UnsupportedNtcVersionError a) +queryExpr :: QueryInMode a -> LocalStateQueryExpr block point QueryInMode r IO (Either UnsupportedNtcVersionError a) queryExpr q = do let minNtcVersion = nodeToClientVersionOf q ntcVersion <- getNtcVersion diff --git a/cardano-api/internal/Cardano/Api/Query.hs b/cardano-api/internal/Cardano/Api/Query.hs index ede195f414..3479f1bdf0 100644 --- a/cardano-api/internal/Cardano/Api/Query.hs +++ b/cardano-api/internal/Cardano/Api/Query.hs @@ -151,35 +151,34 @@ import GHC.Stack -- Queries -- -data QueryInMode mode result where +data QueryInMode result where QueryCurrentEra - :: QueryInMode mode AnyCardanoEra + :: QueryInMode AnyCardanoEra QueryInEra :: QueryInEra era result - -> QueryInMode mode (Either EraMismatch result) + -> QueryInMode (Either EraMismatch result) QueryEraHistory - :: QueryInMode mode EraHistory + :: QueryInMode EraHistory QuerySystemStart - :: QueryInMode mode SystemStart + :: QueryInMode SystemStart QueryChainBlockNo - :: QueryInMode mode (WithOrigin BlockNo) + :: QueryInMode (WithOrigin BlockNo) QueryChainPoint - :: ConsensusMode mode - -> QueryInMode mode ChainPoint + :: QueryInMode ChainPoint -instance NodeToClientVersionOf (QueryInMode mode result) where +instance NodeToClientVersionOf (QueryInMode result) where nodeToClientVersionOf = \case QueryCurrentEra -> NodeToClientV_9 QueryInEra q -> nodeToClientVersionOf q QueryEraHistory -> NodeToClientV_9 QuerySystemStart -> NodeToClientV_9 QueryChainBlockNo -> NodeToClientV_10 - QueryChainPoint _ -> NodeToClientV_10 + QueryChainPoint -> NodeToClientV_10 data EraHistory where EraHistory @@ -224,7 +223,7 @@ slotToEpoch slotNo (EraHistory _ interpreter) = case Qry.interpretQuery interpre Right (epochNumber, slotsInEpoch, slotsToEpochEnd) -> Right (epochNumber, SlotsInEpoch slotsInEpoch, SlotsToEpochEnd slotsToEpochEnd) Left e -> Left e -deriving instance Show (QueryInMode CardanoMode result) +deriving instance Show (QueryInMode result) data QueryInEra era result where QueryByronUpdateState :: QueryInEra ByronEra ByronUpdateState @@ -553,7 +552,7 @@ fromShelleyRewardAccounts = toConsensusQuery :: forall block result. () => Consensus.CardanoBlock L.StandardCrypto ~ block - => QueryInMode CardanoMode result + => QueryInMode result -> Some (Consensus.Query block) toConsensusQuery QueryCurrentEra = Some $ Consensus.BlockQuery $ @@ -569,7 +568,7 @@ toConsensusQuery QuerySystemStart = Some Consensus.GetSystemStart toConsensusQuery QueryChainBlockNo = Some Consensus.GetChainBlockNo -toConsensusQuery (QueryChainPoint _) = Some Consensus.GetChainPoint +toConsensusQuery QueryChainPoint = Some Consensus.GetChainPoint toConsensusQuery (QueryInEra QueryByronUpdateState) = Some $ Consensus.BlockQuery $ @@ -704,7 +703,7 @@ consensusQueryInEraInMode era = fromConsensusQueryResult :: forall block result result'. () => HasCallStack => Consensus.CardanoBlock L.StandardCrypto ~ block - => QueryInMode CardanoMode result + => QueryInMode result -> Consensus.Query block result' -> result' -> result @@ -726,7 +725,7 @@ fromConsensusQueryResult QueryChainBlockNo q' r' = -> r' _ -> fromConsensusQueryResultMismatch -fromConsensusQueryResult (QueryChainPoint _) q' r' = +fromConsensusQueryResult QueryChainPoint q' r' = case q' of Consensus.GetChainPoint -> fromConsensusPointHF r' diff --git a/cardano-api/internal/Cardano/Api/Query/Expr.hs b/cardano-api/internal/Cardano/Api/Query/Expr.hs index 26ab09b2f9..20b82e492d 100644 --- a/cardano-api/internal/Cardano/Api/Query/Expr.hs +++ b/cardano-api/internal/Cardano/Api/Query/Expr.hs @@ -63,85 +63,85 @@ import Data.Set (Set) import qualified Data.Set as S queryChainBlockNo :: () - => LocalStateQueryExpr block point (QueryInMode CardanoMode) r IO (Either UnsupportedNtcVersionError (WithOrigin BlockNo)) + => LocalStateQueryExpr block point QueryInMode r IO (Either UnsupportedNtcVersionError (WithOrigin BlockNo)) queryChainBlockNo = queryExpr QueryChainBlockNo queryChainPoint :: () - => LocalStateQueryExpr block point (QueryInMode CardanoMode) r IO (Either UnsupportedNtcVersionError ChainPoint) + => LocalStateQueryExpr block point QueryInMode r IO (Either UnsupportedNtcVersionError ChainPoint) queryChainPoint = - queryExpr $ QueryChainPoint CardanoMode + queryExpr QueryChainPoint queryCurrentEra :: () - => LocalStateQueryExpr block point (QueryInMode CardanoMode) r IO (Either UnsupportedNtcVersionError AnyCardanoEra) + => LocalStateQueryExpr block point QueryInMode r IO (Either UnsupportedNtcVersionError AnyCardanoEra) queryCurrentEra = queryExpr QueryCurrentEra queryCurrentEpochState :: () => ShelleyBasedEra era - -> LocalStateQueryExpr block point (QueryInMode CardanoMode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch (SerialisedCurrentEpochState era))) + -> LocalStateQueryExpr block point QueryInMode r IO (Either UnsupportedNtcVersionError (Either EraMismatch (SerialisedCurrentEpochState era))) queryCurrentEpochState sbe = queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe QueryCurrentEpochState queryEpoch :: () => ShelleyBasedEra era - -> LocalStateQueryExpr block point (QueryInMode CardanoMode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch EpochNo)) + -> LocalStateQueryExpr block point QueryInMode r IO (Either UnsupportedNtcVersionError (Either EraMismatch EpochNo)) queryEpoch sbe = queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe QueryEpoch queryDebugLedgerState :: () => ShelleyBasedEra era - -> LocalStateQueryExpr block point (QueryInMode CardanoMode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch (SerialisedDebugLedgerState era))) + -> LocalStateQueryExpr block point QueryInMode r IO (Either UnsupportedNtcVersionError (Either EraMismatch (SerialisedDebugLedgerState era))) queryDebugLedgerState sbe = queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe QueryDebugLedgerState queryEraHistory :: () - => LocalStateQueryExpr block point (QueryInMode CardanoMode) r IO (Either UnsupportedNtcVersionError EraHistory) + => LocalStateQueryExpr block point QueryInMode r IO (Either UnsupportedNtcVersionError EraHistory) queryEraHistory = queryExpr QueryEraHistory queryGenesisParameters :: () => ShelleyBasedEra era - -> LocalStateQueryExpr block point (QueryInMode CardanoMode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch (GenesisParameters ShelleyEra))) + -> LocalStateQueryExpr block point QueryInMode r IO (Either UnsupportedNtcVersionError (Either EraMismatch (GenesisParameters ShelleyEra))) queryGenesisParameters sbe = queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe QueryGenesisParameters queryPoolDistribution :: () => ShelleyBasedEra era -> Maybe (Set PoolId) - -> LocalStateQueryExpr block point (QueryInMode CardanoMode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch (SerialisedPoolDistribution era))) + -> LocalStateQueryExpr block point QueryInMode r IO (Either UnsupportedNtcVersionError (Either EraMismatch (SerialisedPoolDistribution era))) queryPoolDistribution sbe mPoolIds = queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe $ QueryPoolDistribution mPoolIds queryPoolState :: () => ShelleyBasedEra era -> Maybe (Set PoolId) - -> LocalStateQueryExpr block point (QueryInMode CardanoMode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch (SerialisedPoolState era))) + -> LocalStateQueryExpr block point QueryInMode r IO (Either UnsupportedNtcVersionError (Either EraMismatch (SerialisedPoolState era))) queryPoolState sbe mPoolIds = queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe $ QueryPoolState mPoolIds queryProtocolParameters :: () => ShelleyBasedEra era - -> LocalStateQueryExpr block point (QueryInMode CardanoMode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch (Ledger.PParams (ShelleyLedgerEra era)))) + -> LocalStateQueryExpr block point QueryInMode r IO (Either UnsupportedNtcVersionError (Either EraMismatch (Ledger.PParams (ShelleyLedgerEra era)))) queryProtocolParameters sbe = queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe QueryProtocolParameters queryConstitutionHash :: () => ShelleyBasedEra era - -> LocalStateQueryExpr block point (QueryInMode CardanoMode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch (Maybe (SafeHash (EraCrypto (ShelleyLedgerEra era)) L.AnchorData)))) + -> LocalStateQueryExpr block point QueryInMode r IO (Either UnsupportedNtcVersionError (Either EraMismatch (Maybe (SafeHash (EraCrypto (ShelleyLedgerEra era)) L.AnchorData)))) queryConstitutionHash sbe = (fmap . fmap . fmap . fmap) (L.anchorDataHash . L.constitutionAnchor) $ queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe QueryConstitution queryProtocolParametersUpdate :: () => ShelleyBasedEra era - -> LocalStateQueryExpr block point (QueryInMode CardanoMode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch (Map (Hash GenesisKey) ProtocolParametersUpdate))) + -> LocalStateQueryExpr block point QueryInMode r IO (Either UnsupportedNtcVersionError (Either EraMismatch (Map (Hash GenesisKey) ProtocolParametersUpdate))) queryProtocolParametersUpdate sbe = queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe QueryProtocolParametersUpdate queryProtocolState :: () => ShelleyBasedEra era - -> LocalStateQueryExpr block point (QueryInMode CardanoMode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch (ProtocolState era))) + -> LocalStateQueryExpr block point QueryInMode r IO (Either UnsupportedNtcVersionError (Either EraMismatch (ProtocolState era))) queryProtocolState sbe = queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe QueryProtocolState @@ -149,66 +149,66 @@ queryStakeAddresses :: () => ShelleyBasedEra era -> Set StakeCredential -> NetworkId - -> LocalStateQueryExpr block point (QueryInMode CardanoMode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch (Map StakeAddress Lovelace, Map StakeAddress PoolId))) + -> LocalStateQueryExpr block point QueryInMode r IO (Either UnsupportedNtcVersionError (Either EraMismatch (Map StakeAddress Lovelace, Map StakeAddress PoolId))) queryStakeAddresses sbe stakeCredentials networkId = queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe $ QueryStakeAddresses stakeCredentials networkId queryStakeDelegDeposits :: () => ShelleyBasedEra era -> Set StakeCredential - -> LocalStateQueryExpr block point (QueryInMode CardanoMode) r IO (Either UnsupportedNtcVersionError (Either Consensus.EraMismatch (Map StakeCredential Lovelace))) + -> LocalStateQueryExpr block point QueryInMode r IO (Either UnsupportedNtcVersionError (Either Consensus.EraMismatch (Map StakeCredential Lovelace))) queryStakeDelegDeposits sbe stakeCreds | S.null stakeCreds = pure . pure $ pure mempty | otherwise = queryExpr $ QueryInEra . QueryInShelleyBasedEra sbe $ QueryStakeDelegDeposits stakeCreds queryStakeDistribution :: () => ShelleyBasedEra era - -> LocalStateQueryExpr block point (QueryInMode CardanoMode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch (Map (Hash StakePoolKey) Rational))) + -> LocalStateQueryExpr block point QueryInMode r IO (Either UnsupportedNtcVersionError (Either EraMismatch (Map (Hash StakePoolKey) Rational))) queryStakeDistribution sbe = queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe QueryStakeDistribution queryStakePoolParameters :: () => ShelleyBasedEra era -> Set PoolId - -> LocalStateQueryExpr block point (QueryInMode CardanoMode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch (Map PoolId StakePoolParameters))) + -> LocalStateQueryExpr block point QueryInMode r IO (Either UnsupportedNtcVersionError (Either EraMismatch (Map PoolId StakePoolParameters))) queryStakePoolParameters sbe poolIds | S.null poolIds = pure . pure $ pure mempty | otherwise = queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe $ QueryStakePoolParameters poolIds queryStakePools :: () => ShelleyBasedEra era - -> LocalStateQueryExpr block point (QueryInMode CardanoMode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch (Set PoolId))) + -> LocalStateQueryExpr block point QueryInMode r IO (Either UnsupportedNtcVersionError (Either EraMismatch (Set PoolId))) queryStakePools sbe = queryExpr $ QueryInEra . QueryInShelleyBasedEra sbe $ QueryStakePools queryStakeSnapshot :: () => ShelleyBasedEra era -> Maybe (Set PoolId) - -> LocalStateQueryExpr block point (QueryInMode CardanoMode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch (SerialisedStakeSnapshots era))) + -> LocalStateQueryExpr block point QueryInMode r IO (Either UnsupportedNtcVersionError (Either EraMismatch (SerialisedStakeSnapshots era))) queryStakeSnapshot sbe mPoolIds = queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe $ QueryStakeSnapshot mPoolIds querySystemStart :: () - => LocalStateQueryExpr block point (QueryInMode CardanoMode) r IO (Either UnsupportedNtcVersionError SystemStart) + => LocalStateQueryExpr block point QueryInMode r IO (Either UnsupportedNtcVersionError SystemStart) querySystemStart = queryExpr QuerySystemStart queryUtxo :: () => ShelleyBasedEra era -> QueryUTxOFilter - -> LocalStateQueryExpr block point (QueryInMode CardanoMode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch (UTxO era))) + -> LocalStateQueryExpr block point QueryInMode r IO (Either UnsupportedNtcVersionError (Either EraMismatch (UTxO era))) queryUtxo sbe utxoFilter = queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe $ QueryUTxO utxoFilter queryConstitution :: () => ShelleyBasedEra era - -> LocalStateQueryExpr block point (QueryInMode CardanoMode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch (Maybe (L.Constitution (ShelleyLedgerEra era))))) + -> LocalStateQueryExpr block point QueryInMode r IO (Either UnsupportedNtcVersionError (Either EraMismatch (Maybe (L.Constitution (ShelleyLedgerEra era))))) queryConstitution sbe = queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe QueryConstitution queryGovState :: () => ShelleyBasedEra era - -> LocalStateQueryExpr block point (QueryInMode CardanoMode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch (L.GovState (ShelleyLedgerEra era)))) + -> LocalStateQueryExpr block point QueryInMode r IO (Either UnsupportedNtcVersionError (Either EraMismatch (L.GovState (ShelleyLedgerEra era)))) queryGovState sbe = queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe QueryGovState @@ -216,14 +216,14 @@ queryDRepState :: () => ShelleyBasedEra era -> Set (L.Credential L.DRepRole L.StandardCrypto) -- ^ An empty credentials set means that states for all DReps will be returned - -> LocalStateQueryExpr block point (QueryInMode CardanoMode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch (Map (L.Credential L.DRepRole L.StandardCrypto) (L.DRepState L.StandardCrypto)))) + -> LocalStateQueryExpr block point QueryInMode r IO (Either UnsupportedNtcVersionError (Either EraMismatch (Map (L.Credential L.DRepRole L.StandardCrypto) (L.DRepState L.StandardCrypto)))) queryDRepState sbe drepCreds = queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe $ QueryDRepState drepCreds queryDRepStakeDistribution :: () => ShelleyBasedEra era -> Set (L.DRep L.StandardCrypto) -- ^ An empty DRep set means that distributions for all DReps will be returned - -> LocalStateQueryExpr block point (QueryInMode CardanoMode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch (Map (L.DRep L.StandardCrypto) Lovelace))) + -> LocalStateQueryExpr block point QueryInMode r IO (Either UnsupportedNtcVersionError (Either EraMismatch (Map (L.DRep L.StandardCrypto) Lovelace))) queryDRepStakeDistribution sbe dreps = queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe $ QueryDRepStakeDistr dreps -- | Returns info about committee members filtered by: cold credentials, hot credentials and statuses. @@ -233,6 +233,6 @@ queryCommitteeMembersState :: () -> Set (L.Credential L.ColdCommitteeRole L.StandardCrypto) -> Set (L.Credential L.HotCommitteeRole L.StandardCrypto) -> Set L.MemberStatus - -> LocalStateQueryExpr block point (QueryInMode CardanoMode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch (Maybe (L.CommitteeMembersState L.StandardCrypto)))) + -> LocalStateQueryExpr block point QueryInMode r IO (Either UnsupportedNtcVersionError (Either EraMismatch (Maybe (L.CommitteeMembersState L.StandardCrypto)))) queryCommitteeMembersState sbe coldCreds hotCreds statuses = queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe (QueryCommitteeMembersState coldCreds hotCreds statuses) From beefcbf03d84bc0c041edef492f943e6d3c39626 Mon Sep 17 00:00:00 2001 From: John Ky Date: Fri, 27 Oct 2023 20:08:45 +1100 Subject: [PATCH 30/37] Deparameterise ConsensusModeParams --- cardano-api/internal/Cardano/Api/IPC.hs | 14 +++++++------- cardano-api/internal/Cardano/Api/Modes.hs | 17 +++++------------ cardano-api/src/Cardano/Api.hs | 1 - 3 files changed, 12 insertions(+), 20 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/IPC.hs b/cardano-api/internal/Cardano/Api/IPC.hs index cc4693cdde..a4171eecc9 100644 --- a/cardano-api/internal/Cardano/Api/IPC.hs +++ b/cardano-api/internal/Cardano/Api/IPC.hs @@ -172,11 +172,11 @@ type LocalNodeClientProtocolsInMode = IO data LocalNodeConnectInfo = - LocalNodeConnectInfo { - localConsensusModeParams :: ConsensusModeParams CardanoMode, - localNodeNetworkId :: NetworkId, - localNodeSocketPath :: SocketPath - } + LocalNodeConnectInfo + { localConsensusModeParams :: ConsensusModeParams + , localNodeNetworkId :: NetworkId + , localNodeSocketPath :: SocketPath + } localConsensusMode :: () => LocalNodeConnectInfo @@ -185,7 +185,7 @@ localConsensusMode LocalNodeConnectInfo {localConsensusModeParams} = consensusModeOnly localConsensusModeParams consensusModeOnly :: () - => ConsensusModeParams CardanoMode + => ConsensusModeParams -> ConsensusMode CardanoMode consensusModeOnly CardanoModeParams{} = CardanoMode @@ -395,7 +395,7 @@ data LocalNodeClientProtocolsForBlock block = -- mkLocalNodeClientParams :: forall block. () => Consensus.CardanoBlock L.StandardCrypto ~ block - => ConsensusModeParams CardanoMode + => ConsensusModeParams -> (NodeToClientVersion -> LocalNodeClientProtocolsInMode) -> LocalNodeClientParams mkLocalNodeClientParams modeparams clients = diff --git a/cardano-api/internal/Cardano/Api/Modes.hs b/cardano-api/internal/Cardano/Api/Modes.hs index da14929bea..db70b48962 100644 --- a/cardano-api/internal/Cardano/Api/Modes.hs +++ b/cardano-api/internal/Cardano/Api/Modes.hs @@ -25,7 +25,6 @@ module Cardano.Api.Modes ( -- * Connection parameters for each mode ConsensusModeParams(..), - AnyConsensusModeParams(..), Byron.EpochSlots(..), -- * Conversions to and from types in the consensus library @@ -66,11 +65,6 @@ import Data.Text (Text) -- data CardanoMode -data AnyConsensusModeParams where - AnyConsensusModeParams :: ConsensusModeParams mode -> AnyConsensusModeParams - -deriving instance Show AnyConsensusModeParams - -- | This GADT provides a value-level representation of all the consensus modes. -- This enables pattern matching on the era to allow them to be treated in a -- non-uniform way. @@ -101,13 +95,12 @@ renderMode (AnyConsensusMode CardanoMode) = "CardanoMode" -- It is possible in future that we may be able to eliminate this parameter by -- discovering it from the node during the initial handshake. -- -data ConsensusModeParams mode where - - CardanoModeParams - :: Byron.EpochSlots - -> ConsensusModeParams CardanoMode +data ConsensusModeParams where + CardanoModeParams + :: Byron.EpochSlots + -> ConsensusModeParams -deriving instance Show (ConsensusModeParams mode) +deriving instance Show ConsensusModeParams -- ---------------------------------------------------------------------------- -- Consensus conversion functions diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs index b51f338c14..03c06f7b20 100644 --- a/cardano-api/src/Cardano/Api.hs +++ b/cardano-api/src/Cardano/Api.hs @@ -790,7 +790,6 @@ module Cardano.Api ( renderMode, ConsensusMode(CardanoMode), consensusModeOnly, - AnyConsensusModeParams(..), ConsensusModeParams(..), ConsensusProtocol, ChainDepStateProtocol, From 104369f3b237dab6b22d27268797f3de9d9bb932 Mon Sep 17 00:00:00 2001 From: John Ky Date: Fri, 27 Oct 2023 20:10:58 +1100 Subject: [PATCH 31/37] Remove ConsensusMode constructor argument from EraHistory constructor --- cardano-api/internal/Cardano/Api/Query.hs | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/Query.hs b/cardano-api/internal/Cardano/Api/Query.hs index 3479f1bdf0..214ce4e5a5 100644 --- a/cardano-api/internal/Cardano/Api/Query.hs +++ b/cardano-api/internal/Cardano/Api/Query.hs @@ -183,22 +183,21 @@ instance NodeToClientVersionOf (QueryInMode result) where data EraHistory where EraHistory :: Consensus.CardanoBlock L.StandardCrypto ~ Consensus.HardForkBlock xs - => ConsensusMode CardanoMode - -> History.Interpreter xs + => History.Interpreter xs -> EraHistory getProgress :: () => SlotNo -> EraHistory -> Either Qry.PastHorizonException (RelativeTime, SlotLength) -getProgress slotNo (EraHistory _ interpreter) = Qry.interpretQuery interpreter (Qry.slotToWallclock slotNo) +getProgress slotNo (EraHistory interpreter) = Qry.interpretQuery interpreter (Qry.slotToWallclock slotNo) -- | Returns the slot number for provided relative time from 'SystemStart' getSlotForRelativeTime :: () => RelativeTime -> EraHistory -> Either Qry.PastHorizonException SlotNo -getSlotForRelativeTime relTime (EraHistory _ interpreter) = do +getSlotForRelativeTime relTime (EraHistory interpreter) = do (slotNo, _, _) <- Qry.interpretQuery interpreter $ Qry.wallclockToSlot relTime pure slotNo @@ -207,7 +206,7 @@ newtype LedgerEpochInfo = LedgerEpochInfo { unLedgerEpochInfo :: Consensus.Epoch toLedgerEpochInfo :: () => EraHistory -> LedgerEpochInfo -toLedgerEpochInfo (EraHistory _ interpreter) = +toLedgerEpochInfo (EraHistory interpreter) = LedgerEpochInfo $ hoistEpochInfo (first (Text.pack . show) . runExcept) $ Consensus.interpreterToEpochInfo interpreter @@ -219,7 +218,7 @@ slotToEpoch :: () => SlotNo -> EraHistory -> Either Qry.PastHorizonException (EpochNo, SlotsInEpoch, SlotsToEpochEnd) -slotToEpoch slotNo (EraHistory _ interpreter) = case Qry.interpretQuery interpreter (Qry.slotToEpoch slotNo) of +slotToEpoch slotNo (EraHistory interpreter) = case Qry.interpretQuery interpreter (Qry.slotToEpoch slotNo) of Right (epochNumber, slotsInEpoch, slotsToEpochEnd) -> Right (epochNumber, SlotsInEpoch slotsInEpoch, SlotsToEpochEnd slotsToEpochEnd) Left e -> Left e @@ -710,7 +709,7 @@ fromConsensusQueryResult :: forall block result result'. () fromConsensusQueryResult QueryEraHistory q' r' = case q' of Consensus.BlockQuery (Consensus.QueryHardFork Consensus.GetInterpreter) - -> EraHistory CardanoMode r' + -> EraHistory r' _ -> fromConsensusQueryResultMismatch fromConsensusQueryResult QuerySystemStart q' r' = From d7c75353762cf07425ffe7ce49c82a86ca57a9a1 Mon Sep 17 00:00:00 2001 From: John Ky Date: Fri, 27 Oct 2023 20:12:00 +1100 Subject: [PATCH 32/37] Remove ConsensusMode argument from fromConsensusEraIndex function --- cardano-api/internal/Cardano/Api/Modes.hs | 6 ++---- cardano-api/internal/Cardano/Api/Query.hs | 2 +- 2 files changed, 3 insertions(+), 5 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/Modes.hs b/cardano-api/internal/Cardano/Api/Modes.hs index db70b48962..b9b6e93f17 100644 --- a/cardano-api/internal/Cardano/Api/Modes.hs +++ b/cardano-api/internal/Cardano/Api/Modes.hs @@ -174,12 +174,10 @@ toConsensusEraIndex = \case BabbageEra -> eraIndex5 ConwayEra -> eraIndex6 - fromConsensusEraIndex :: () - => ConsensusMode CardanoMode - -> Consensus.EraIndex (Consensus.CardanoEras StandardCrypto) + => Consensus.EraIndex (Consensus.CardanoEras StandardCrypto) -> AnyCardanoEra -fromConsensusEraIndex CardanoMode = \case +fromConsensusEraIndex = \case Consensus.EraIndex (Z (K ())) -> AnyCardanoEra ByronEra Consensus.EraIndex (S (Z (K ()))) -> diff --git a/cardano-api/internal/Cardano/Api/Query.hs b/cardano-api/internal/Cardano/Api/Query.hs index 214ce4e5a5..a01a44140d 100644 --- a/cardano-api/internal/Cardano/Api/Query.hs +++ b/cardano-api/internal/Cardano/Api/Query.hs @@ -733,7 +733,7 @@ fromConsensusQueryResult QueryChainPoint q' r' = fromConsensusQueryResult QueryCurrentEra q' r' = case q' of Consensus.BlockQuery (Consensus.QueryHardFork Consensus.GetCurrentEra) - -> fromConsensusEraIndex CardanoMode r' + -> fromConsensusEraIndex r' _ -> fromConsensusQueryResultMismatch fromConsensusQueryResult (QueryInEra QueryByronUpdateState) q' r' = From aa1eb054cbfb87fa2fffd6ebac9f18c6fc33aa14 Mon Sep 17 00:00:00 2001 From: John Ky Date: Fri, 27 Oct 2023 20:13:36 +1100 Subject: [PATCH 33/37] Delete localConsensusMode and consensusModeOnly functions --- cardano-api/internal/Cardano/Api/IPC.hs | 13 ------------- cardano-api/src/Cardano/Api.hs | 1 - 2 files changed, 14 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/IPC.hs b/cardano-api/internal/Cardano/Api/IPC.hs index a4171eecc9..b15e59eb3d 100644 --- a/cardano-api/internal/Cardano/Api/IPC.hs +++ b/cardano-api/internal/Cardano/Api/IPC.hs @@ -20,7 +20,6 @@ module Cardano.Api.IPC ( connectToLocalNode, connectToLocalNodeWithVersion, LocalNodeConnectInfo(..), - localConsensusMode, LocalNodeClientParams(..), mkLocalNodeClientParams, LocalNodeClientProtocols(..), @@ -72,7 +71,6 @@ module Cardano.Api.IPC ( -- *** Helpers --TODO: These should be exported via Cardano.Api.Mode ConsensusMode(..), - consensusModeOnly, toAcquiringFailure, NodeToClientVersion(..), @@ -178,17 +176,6 @@ data LocalNodeConnectInfo = , localNodeSocketPath :: SocketPath } -localConsensusMode :: () - => LocalNodeConnectInfo - -> ConsensusMode CardanoMode -localConsensusMode LocalNodeConnectInfo {localConsensusModeParams} = - consensusModeOnly localConsensusModeParams - -consensusModeOnly :: () - => ConsensusModeParams - -> ConsensusMode CardanoMode -consensusModeOnly CardanoModeParams{} = CardanoMode - -- ---------------------------------------------------------------------------- -- Actually connect to the node -- diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs index 03c06f7b20..2ddb76db26 100644 --- a/cardano-api/src/Cardano/Api.hs +++ b/cardano-api/src/Cardano/Api.hs @@ -789,7 +789,6 @@ module Cardano.Api ( AnyConsensusMode(..), renderMode, ConsensusMode(CardanoMode), - consensusModeOnly, ConsensusModeParams(..), ConsensusProtocol, ChainDepStateProtocol, From 43952f15ae0d41915c54ae62f19fc572337aaebf Mon Sep 17 00:00:00 2001 From: John Ky Date: Fri, 27 Oct 2023 20:15:40 +1100 Subject: [PATCH 34/37] Delete AnyConsensusMode and renderMode --- cardano-api/internal/Cardano/Api/Convenience/Query.hs | 5 ----- cardano-api/internal/Cardano/Api/Modes.hs | 11 ----------- cardano-api/src/Cardano/Api.hs | 2 -- 3 files changed, 18 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/Convenience/Query.hs b/cardano-api/internal/Cardano/Api/Convenience/Query.hs index b4c5e41f31..dabcda0029 100644 --- a/cardano-api/internal/Cardano/Api/Convenience/Query.hs +++ b/cardano-api/internal/Cardano/Api/Convenience/Query.hs @@ -24,7 +24,6 @@ import Cardano.Api.Eras import Cardano.Api.IO import Cardano.Api.IPC import Cardano.Api.IPC.Monad -import Cardano.Api.Modes import Cardano.Api.NetworkId import Cardano.Api.ProtocolParameters import Cardano.Api.Query @@ -54,7 +53,6 @@ data QueryConvenienceError = AcqFailure AcquiringFailure | QueryEraMismatch EraMismatch | ByronEraNotSupported - | EraConsensusModeMismatch !AnyConsensusMode !AnyCardanoEra | QceUnsupportedNtcVersion !UnsupportedNtcVersionError deriving Show @@ -67,9 +65,6 @@ renderQueryConvenienceError (QueryEraMismatch (EraMismatch ledgerEraName' otherE " era, but the transaction is for the " <> otherEraName' <> " era." renderQueryConvenienceError ByronEraNotSupported = "Byron era not supported" -renderQueryConvenienceError (EraConsensusModeMismatch cMode anyCEra) = - "Consensus mode and era mismatch. Consensus mode: " <> textShow cMode <> - " Era: " <> textShow anyCEra renderQueryConvenienceError (QceUnsupportedNtcVersion (UnsupportedNtcVersionError minNtcVersion ntcVersion)) = "Unsupported feature for the node-to-client protocol version.\n" <> "This query requires at least " <> textShow minNtcVersion <> " but the node negotiated " <> textShow ntcVersion <> ".\n" <> diff --git a/cardano-api/internal/Cardano/Api/Modes.hs b/cardano-api/internal/Cardano/Api/Modes.hs index b9b6e93f17..d64cea2e2c 100644 --- a/cardano-api/internal/Cardano/Api/Modes.hs +++ b/cardano-api/internal/Cardano/Api/Modes.hs @@ -16,8 +16,6 @@ module Cardano.Api.Modes ( -- * Consensus modes CardanoMode, ConsensusMode(..), - AnyConsensusMode(..), - renderMode, -- * The protocols supported in each era ConsensusProtocol, @@ -51,7 +49,6 @@ import qualified Ouroboros.Consensus.Shelley.ShelleyHFC as Consensus import Data.SOP (K (K)) import Data.SOP.Strict (NS (S, Z)) -import Data.Text (Text) -- ---------------------------------------------------------------------------- -- Consensus modes @@ -75,14 +72,6 @@ data ConsensusMode mode where deriving instance Show (ConsensusMode mode) -data AnyConsensusMode where - AnyConsensusMode :: ConsensusMode mode -> AnyConsensusMode - -deriving instance Show AnyConsensusMode - -renderMode :: AnyConsensusMode -> Text -renderMode (AnyConsensusMode CardanoMode) = "CardanoMode" - -- | The consensus-mode-specific parameters needed to connect to a local node -- that is using each consensus mode. -- diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs index 2ddb76db26..15f2175e2b 100644 --- a/cardano-api/src/Cardano/Api.hs +++ b/cardano-api/src/Cardano/Api.hs @@ -786,8 +786,6 @@ module Cardano.Api ( connectToLocalNode, connectToLocalNodeWithVersion, LocalNodeConnectInfo(..), - AnyConsensusMode(..), - renderMode, ConsensusMode(CardanoMode), ConsensusModeParams(..), ConsensusProtocol, From 0a7466ea3a0fcc4c2ab0debd846d8a9d17bdbc1b Mon Sep 17 00:00:00 2001 From: John Ky Date: Fri, 27 Oct 2023 20:18:47 +1100 Subject: [PATCH 35/37] Delete ConsensusMode and CardanoMode --- cardano-api/internal/Cardano/Api/IPC.hs | 2 -- cardano-api/internal/Cardano/Api/Modes.hs | 23 ----------------------- cardano-api/src/Cardano/Api.hs | 2 -- 3 files changed, 27 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/IPC.hs b/cardano-api/internal/Cardano/Api/IPC.hs index b15e59eb3d..ef71399c05 100644 --- a/cardano-api/internal/Cardano/Api/IPC.hs +++ b/cardano-api/internal/Cardano/Api/IPC.hs @@ -28,7 +28,6 @@ module Cardano.Api.IPC ( -- ** Modes -- | TODO move to Cardano.Api - CardanoMode, ConsensusModeParams(..), EpochSlots(..), @@ -70,7 +69,6 @@ module Cardano.Api.IPC ( -- *** Helpers --TODO: These should be exported via Cardano.Api.Mode - ConsensusMode(..), toAcquiringFailure, NodeToClientVersion(..), diff --git a/cardano-api/internal/Cardano/Api/Modes.hs b/cardano-api/internal/Cardano/Api/Modes.hs index d64cea2e2c..2cb6ca0b38 100644 --- a/cardano-api/internal/Cardano/Api/Modes.hs +++ b/cardano-api/internal/Cardano/Api/Modes.hs @@ -12,11 +12,6 @@ -- combinations of consensus protocols and ledger eras. -- module Cardano.Api.Modes ( - - -- * Consensus modes - CardanoMode, - ConsensusMode(..), - -- * The protocols supported in each era ConsensusProtocol, ChainDepStateProtocol, @@ -54,24 +49,6 @@ import Data.SOP.Strict (NS (S, Z)) -- Consensus modes -- --- | The Cardano consensus mode consists of all the eras currently in use on --- the Cardano mainnet. This is currently: the 'ByronEra'; 'ShelleyEra', --- 'AllegraEra' and 'MaryEra', in that order. --- --- This mode will be extended with new eras as the Cardano mainnet develops. --- -data CardanoMode - --- | This GADT provides a value-level representation of all the consensus modes. --- This enables pattern matching on the era to allow them to be treated in a --- non-uniform way. --- -data ConsensusMode mode where - CardanoMode :: ConsensusMode CardanoMode - - -deriving instance Show (ConsensusMode mode) - -- | The consensus-mode-specific parameters needed to connect to a local node -- that is using each consensus mode. -- diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs index 15f2175e2b..0769f1386f 100644 --- a/cardano-api/src/Cardano/Api.hs +++ b/cardano-api/src/Cardano/Api.hs @@ -786,7 +786,6 @@ module Cardano.Api ( connectToLocalNode, connectToLocalNodeWithVersion, LocalNodeConnectInfo(..), - ConsensusMode(CardanoMode), ConsensusModeParams(..), ConsensusProtocol, ChainDepStateProtocol, @@ -795,7 +794,6 @@ module Cardano.Api ( LocalNodeClientParams(..), mkLocalNodeClientParams, LocalChainSyncClient(..), - CardanoMode, -- connectToRemoteNode, -- ** Protocol related types From aa74887424f5821c0bcceb5d94331feef951c639 Mon Sep 17 00:00:00 2001 From: John Ky Date: Fri, 27 Oct 2023 21:36:13 +1100 Subject: [PATCH 36/37] Add eon arguments to makeSignedTransaction and evaluateTransactionExecutionUnits --- cardano-api/internal/Cardano/Api/Fees.hs | 10 ++++++---- cardano-api/internal/Cardano/Api/Tx.hs | 8 ++++++++ 2 files changed, 14 insertions(+), 4 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/Fees.hs b/cardano-api/internal/Cardano/Api/Fees.hs index 14099e9c51..34a361215d 100644 --- a/cardano-api/internal/Cardano/Api/Fees.hs +++ b/cardano-api/internal/Cardano/Api/Fees.hs @@ -218,7 +218,7 @@ evaluateTransactionFee _ _ _ _ byronwitcount | byronwitcount > 0 = evaluateTransactionFee sbe pp txbody keywitcount _byronwitcount = shelleyBasedEraConstraints sbe $ - case makeSignedTransaction [] txbody of + case makeSignedTransaction' (shelleyBasedToCardanoEra sbe) [] txbody of ByronTx w _ -> disjointByronEraOnlyAndShelleyBasedEra w sbe ShelleyTx _ tx -> fromShelleyLovelace $ Ledger.evaluateTransactionFee pp tx keywitcount @@ -455,15 +455,16 @@ instance Error TransactionValidityError where -- are actually used. -- evaluateTransactionExecutionUnits :: forall era. () - => SystemStart + => CardanoEra era + -> SystemStart -> LedgerEpochInfo -> LedgerProtocolParameters era -> UTxO era -> TxBody era -> Either TransactionValidityError (Map ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits)) -evaluateTransactionExecutionUnits systemstart epochInfo pp utxo txbody = - case makeSignedTransaction [] txbody of +evaluateTransactionExecutionUnits era systemstart epochInfo pp utxo txbody = + case makeSignedTransaction' era [] txbody of ByronTx {} -> evalPreAlonzo ShelleyTx sbe tx' -> evaluateTransactionExecutionUnitsShelley sbe systemstart epochInfo pp utxo tx' where @@ -800,6 +801,7 @@ makeTransactionBodyAutoBalance sbe systemstart history lpp@(LedgerProtocolParame exUnitsMap <- first TxBodyErrorValidityInterval $ evaluateTransactionExecutionUnits + era systemstart history lpp utxo diff --git a/cardano-api/internal/Cardano/Api/Tx.hs b/cardano-api/internal/Cardano/Api/Tx.hs index 99b1dacc58..a10a61e70e 100644 --- a/cardano-api/internal/Cardano/Api/Tx.hs +++ b/cardano-api/internal/Cardano/Api/Tx.hs @@ -36,6 +36,7 @@ module Cardano.Api.Tx ( -- ** Incremental signing and separate witnesses makeSignedTransaction, + makeSignedTransaction', KeyWitness(..), makeByronKeyWitness, ShelleyWitnessSigningKey(..), @@ -493,6 +494,13 @@ getTxWitnesses (ShelleyTx sbe tx') = -> [KeyWitness era] getAlonzoTxWitnesses = getShelleyTxWitnesses +makeSignedTransaction' :: () + => CardanoEra era + -> [KeyWitness era] + -> TxBody era + -> Tx era +makeSignedTransaction' _ = makeSignedTransaction + makeSignedTransaction :: forall era. [KeyWitness era] -> TxBody era From b155e2df0ab1b1fa01f00b040195f65a33b78eca Mon Sep 17 00:00:00 2001 From: John Ky Date: Fri, 27 Oct 2023 22:48:22 +1100 Subject: [PATCH 37/37] Disable incomplete-patterns warning on ghc-8.10.7 because it is inaccurate --- cardano-api/cardano-api.cabal | 3 +++ 1 file changed, 3 insertions(+) diff --git a/cardano-api/cardano-api.cabal b/cardano-api/cardano-api.cabal index 9080ffca3d..2b9de8e739 100644 --- a/cardano-api/cardano-api.cabal +++ b/cardano-api/cardano-api.cabal @@ -29,6 +29,9 @@ common project-config -Wredundant-constraints -Wunused-packages + if impl(ghc < 9) + ghc-options: -Wno-incomplete-patterns + common maybe-unix if !os(windows) build-depends: unix