From db22ace0baa6aaebf0dcc68051ce320daab58993 Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Fri, 2 Aug 2024 11:58:44 +0200 Subject: [PATCH] Rebase changes --- cardano-api/CHANGELOG.md | 2 +- cardano-api/cardano-api.cabal | 4 +- .../internal/Cardano/Api/Experimental/Eras.hs | 117 ++++++++++++------ .../internal/Cardano/Api/Experimental/Tx.hs | 60 ++------- cardano-api/internal/Cardano/Api/Fees.hs | 4 +- cardano-api/internal/Cardano/Api/Tx/Body.hs | 1 - cardano-api/src/Cardano/Api/Experimental.hs | 10 +- 7 files changed, 101 insertions(+), 97 deletions(-) diff --git a/cardano-api/CHANGELOG.md b/cardano-api/CHANGELOG.md index dc88f8de1..629b72312 100644 --- a/cardano-api/CHANGELOG.md +++ b/cardano-api/CHANGELOG.md @@ -350,7 +350,7 @@ (feature, compatible) [PR 410](https://github.com/IntersectMBO/cardano-api/pull/410) -- Implement Era GADT and UseEra class as an alternative to the existing era handling code +- Implement Era GADT and IsEra class as an alternative to the existing era handling code (feature, compatible) [PR 402](https://github.com/IntersectMBO/cardano-api/pull/402) diff --git a/cardano-api/cardano-api.cabal b/cardano-api/cardano-api.cabal index e671523aa..46e4c0264 100644 --- a/cardano-api/cardano-api.cabal +++ b/cardano-api/cardano-api.cabal @@ -83,6 +83,8 @@ library internal Cardano.Api.Eras.Case Cardano.Api.Eras.Core Cardano.Api.Error + Cardano.Api.Experimental.Eras + Cardano.Api.Experimental.Tx Cardano.Api.Feature Cardano.Api.Fees Cardano.Api.Genesis @@ -131,8 +133,6 @@ library internal Cardano.Api.ReexposeNetwork Cardano.Api.Rewards Cardano.Api.Script - Cardano.Api.Experimental.Eras - Cardano.Api.Experimental.Tx Cardano.Api.ScriptData Cardano.Api.SerialiseBech32 Cardano.Api.SerialiseCBOR diff --git a/cardano-api/internal/Cardano/Api/Experimental/Eras.hs b/cardano-api/internal/Cardano/Api/Experimental/Eras.hs index f857dae52..893e96c99 100644 --- a/cardano-api/internal/Cardano/Api/Experimental/Eras.hs +++ b/cardano-api/internal/Cardano/Api/Experimental/Eras.hs @@ -9,66 +9,76 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} -- | This module defines the protocol versions corresponding to the eras in the Cardano blockchain. module Cardano.Api.Experimental.Eras ( BabbageEra , ConwayEra , Era (..) - , ToConstrainedLedgerEra - , UseEra - , ApiErasToLedgerEras - , AvailableErasToSbe + , LedgerEra + , IsEra + , ApiEraToLedgerEra + , ExperimentalEraToApiEra , ApiEraToExperimentalEra , DeprecatedEra (..) + , EraCommonConstraints + , EraShimConstraints + , obtainCommonConstraints + , obtainShimConstraints , useEra - , protocolVersionToSbe + , eraToSbe , babbageEraOnwardsToEra , sbeToEra ) where -import Cardano.Api.Eon.ShelleyBasedEra (ShelleyBasedEra (..)) +import Cardano.Api.Eon.BabbageEraOnwards +import Cardano.Api.Eon.ShelleyBasedEra (ShelleyBasedEra (..), ShelleyLedgerEra) +import Cardano.Api.Eras.Core (BabbageEra, ConwayEra) import qualified Cardano.Api.Eras.Core as Api +import qualified Cardano.Api.ReexposeLedger as L import Cardano.Api.Via.ShowOf +import qualified Cardano.Ledger.Api as L import qualified Cardano.Ledger.Babbage as Ledger import qualified Cardano.Ledger.Conway as Ledger -import Cardano.Api.Eon.BabbageEraOnwards +import qualified Cardano.Ledger.Core as Ledger +import Cardano.Ledger.Hashes +import qualified Cardano.Ledger.SafeHash as L +import qualified Cardano.Ledger.UTxO as L +import Control.Monad.Error.Class import Data.Kind import Prettyprinter -- | Users typically interact with the latest features on the mainnet or experiment with features -- from the upcoming era. Hence, the protocol versions are limited to the current mainnet era -- and the next era (upcoming era). -data BabbageEra - -data ConwayEra -- Allows us to gradually change the api without breaking things. -- This will eventually be removed. -type family AvailableErasToSbe era = (r :: Type) | r -> era where - AvailableErasToSbe BabbageEra = Api.BabbageEra - AvailableErasToSbe ConwayEra = Api.ConwayEra +type family ExperimentalEraToApiEra era = (r :: Type) | r -> era where + ExperimentalEraToApiEra BabbageEra = Api.BabbageEra + ExperimentalEraToApiEra ConwayEra = Api.ConwayEra type family ApiEraToExperimentalEra era = (r :: Type) | r -> era where ApiEraToExperimentalEra Api.BabbageEra = BabbageEra ApiEraToExperimentalEra Api.ConwayEra = ConwayEra -type family ToConstrainedLedgerEra era = (r :: Type) | r -> era where - ToConstrainedLedgerEra BabbageEra = Ledger.Babbage - ToConstrainedLedgerEra ConwayEra = Ledger.Conway +type family LedgerEra era = (r :: Type) | r -> era where + LedgerEra BabbageEra = Ledger.Babbage + LedgerEra ConwayEra = Ledger.Conway -type family ApiErasToLedgerEras era = (r :: Type) | r -> era where - ApiErasToLedgerEras Api.BabbageEra = Ledger.Babbage - ApiErasToLedgerEras Api.ConwayEra = Ledger.Conway +type family ApiEraToLedgerEra era = (r :: Type) | r -> era where + ApiEraToLedgerEra Api.BabbageEra = Ledger.Babbage + ApiEraToLedgerEra Api.ConwayEra = Ledger.Conway -- | Represents the eras in Cardano's blockchain. -- This type represents eras currently on mainnet and new eras which are -- in development. -- --- After a hardfork, the from which we hardfork from gets deprecated and +-- After a hardfork, the era from which we hardfork from gets deprecated and -- after deprecation period, gets removed. During deprecation period, -- consumers of cardano-api should update their codebase to the mainnet era. data Era era where @@ -77,6 +87,8 @@ data Era era where -- | The upcoming era in development. ConwayEra :: Era ConwayEra +deriving instance Show (Era era) + -- | How to deprecate an era -- -- 1. Add DEPRECATED pragma to the era type tag and the era constructor at the same time: @@ -95,20 +107,19 @@ data Era era where -- ConwayEra :: Era ConwayEra -- @ -- --- 3. Add new 'UseEra' instance and update the deprecated era instance to produce a compile-time error: +-- 3. Add new 'IsEra' instance and update the deprecated era instance to produce a compile-time error: -- @ --- instance TypeError ('Text "UseEra BabbageEra: Deprecated. Update to ConwayEra") => UseEra BabbageEra where +-- instance TypeError ('Text "IsEra BabbageEra: Deprecated. Update to ConwayEra") => IsEra BabbageEra where -- useEra = error "unreachable" -- --- instance UseEra ConwayEra where +-- instance IsEra ConwayEra where -- useEra = ConwayEra -- @ - -protocolVersionToSbe +eraToSbe :: Era era - -> ShelleyBasedEra (AvailableErasToSbe era) -protocolVersionToSbe BabbageEra = ShelleyBasedEraBabbage -protocolVersionToSbe ConwayEra = ShelleyBasedEraConway + -> ShelleyBasedEra (ExperimentalEraToApiEra era) +eraToSbe BabbageEra = ShelleyBasedEraBabbage +eraToSbe ConwayEra = ShelleyBasedEraConway newtype DeprecatedEra era = DeprecatedEra (ShelleyBasedEra era) @@ -116,27 +127,59 @@ newtype DeprecatedEra era deriving via (ShowOf (DeprecatedEra era)) instance Pretty (DeprecatedEra era) -sbeToEra :: ShelleyBasedEra era -> Either (DeprecatedEra era) (Era (ApiEraToExperimentalEra era)) +sbeToEra + :: MonadError (DeprecatedEra era) m => ShelleyBasedEra era -> m (Era (ApiEraToExperimentalEra era)) sbeToEra ShelleyBasedEraConway = return ConwayEra sbeToEra ShelleyBasedEraBabbage = return BabbageEra -sbeToEra e@ShelleyBasedEraAlonzo = Left $ DeprecatedEra e -sbeToEra e@ShelleyBasedEraMary = Left $ DeprecatedEra e -sbeToEra e@ShelleyBasedEraAllegra = Left $ DeprecatedEra e -sbeToEra e@ShelleyBasedEraShelley = Left $ DeprecatedEra e +sbeToEra e@ShelleyBasedEraAlonzo = throwError $ DeprecatedEra e +sbeToEra e@ShelleyBasedEraMary = throwError $ DeprecatedEra e +sbeToEra e@ShelleyBasedEraAllegra = throwError $ DeprecatedEra e +sbeToEra e@ShelleyBasedEraShelley = throwError $ DeprecatedEra e babbageEraOnwardsToEra :: BabbageEraOnwards era -> Era (ApiEraToExperimentalEra era) babbageEraOnwardsToEra BabbageEraOnwardsBabbage = BabbageEra babbageEraOnwardsToEra BabbageEraOnwardsConway = ConwayEra - ------------------------------------------------------------------------- -- | Type class interface for the 'Era' type. -class UseEra era where +class IsEra era where useEra :: Era era -instance UseEra BabbageEra where +instance IsEra BabbageEra where useEra = BabbageEra -instance UseEra ConwayEra where +instance IsEra ConwayEra where useEra = ConwayEra + +obtainShimConstraints + :: BabbageEraOnwards era + -> (EraShimConstraints era => a) + -> a +obtainShimConstraints BabbageEraOnwardsBabbage x = x +obtainShimConstraints BabbageEraOnwardsConway x = x + +-- We need these constraints in order to propagate the new +-- experimental api without changing the existing api +type EraShimConstraints era = + ( LedgerEra (ApiEraToExperimentalEra era) ~ ShelleyLedgerEra era + , ExperimentalEraToApiEra (ApiEraToExperimentalEra era) ~ era + , L.EraTx (ApiEraToLedgerEra era) + ) + +obtainCommonConstraints + :: Era era + -> (EraCommonConstraints era => a) + -> a +obtainCommonConstraints BabbageEra x = x +obtainCommonConstraints ConwayEra x = x + +type EraCommonConstraints era = + ( L.AlonzoEraTx (LedgerEra era) + , L.BabbageEraTxBody (LedgerEra era) + , L.EraTx (LedgerEra era) + , L.EraUTxO (LedgerEra era) + , Ledger.EraCrypto (LedgerEra era) ~ L.StandardCrypto + , ShelleyLedgerEra (ExperimentalEraToApiEra era) ~ LedgerEra era + , L.HashAnnotated (Ledger.TxBody (LedgerEra era)) EraIndependentTxBody L.StandardCrypto + ) diff --git a/cardano-api/internal/Cardano/Api/Experimental/Tx.hs b/cardano-api/internal/Cardano/Api/Experimental/Tx.hs index 8a0f02c56..865b647f5 100644 --- a/cardano-api/internal/Cardano/Api/Experimental/Tx.hs +++ b/cardano-api/internal/Cardano/Api/Experimental/Tx.hs @@ -7,7 +7,6 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} module Cardano.Api.Experimental.Tx @@ -17,15 +16,10 @@ module Cardano.Api.Experimental.Tx , makeKeyWitness , signTx , convertTxBodyToUnsignedTx - , EraCommonConstraints - , EraShimConstraints - , obtainShimConstraints - , obtainCommonConstraints , hashTxBody ) where -import Cardano.Api.Eon.BabbageEraOnwards import Cardano.Api.Eon.ShelleyBasedEra import Cardano.Api.Eras.Case import Cardano.Api.Experimental.Eras @@ -44,7 +38,6 @@ import qualified Cardano.Ledger.Core as Ledger import Cardano.Ledger.Hashes import qualified Cardano.Ledger.Keys as L import qualified Cardano.Ledger.SafeHash as L -import qualified Cardano.Ledger.UTxO as L import qualified Data.Map.Strict as Map import qualified Data.Set as Set @@ -53,9 +46,9 @@ import Lens.Micro -- | A transaction that can contain everything -- except key witnesses newtype UnsignedTx era - = UnsignedTx (Ledger.Tx (ToConstrainedLedgerEra era)) + = UnsignedTx (Ledger.Tx (LedgerEra era)) -instance UseEra era => Show (UnsignedTx era) where +instance IsEra era => Show (UnsignedTx era) where showsPrec p (UnsignedTx tx) = case useEra @era of BabbageEra -> showsPrec p (tx :: Ledger.Tx Ledger.Babbage) ConwayEra -> showsPrec p (tx :: Ledger.Tx Ledger.Conway) @@ -65,10 +58,10 @@ newtype UnsignedTxError makeUnsignedTx :: Era era - -> TxBodyContent BuildTx (AvailableErasToSbe era) + -> TxBodyContent BuildTx (ExperimentalEraToApiEra era) -> Either TxBodyError (UnsignedTx era) makeUnsignedTx era bc = obtainCommonConstraints era $ do - let sbe = protocolVersionToSbe era + let sbe = eraToSbe era -- cardano-api types let apiTxOuts = txOuts bc @@ -134,11 +127,11 @@ makeUnsignedTx era bc = obtainCommonConstraints era $ do eraSpecificLedgerTxBody :: Era era - -> Ledger.TxBody (ToConstrainedLedgerEra era) - -> TxBodyContent BuildTx (AvailableErasToSbe era) - -> Either TxBodyError (Ledger.TxBody (ToConstrainedLedgerEra era)) + -> Ledger.TxBody (LedgerEra era) + -> TxBodyContent BuildTx (ExperimentalEraToApiEra era) + -> Either TxBodyError (Ledger.TxBody (LedgerEra era)) eraSpecificLedgerTxBody BabbageEra ledgerbody bc = do - let sbe = protocolVersionToSbe BabbageEra + let sbe = eraToSbe BabbageEra setUpdateProposal <- convTxUpdateProposal sbe (txUpdateProposal bc) @@ -155,7 +148,8 @@ eraSpecificLedgerTxBody ConwayEra ledgerbody bc = & L.votingProceduresTxBodyL .~ convVotingProcedures (maybe TxVotingProceduresNone unFeatured voteProcedures) & L.treasuryDonationTxBodyL .~ maybe (L.Coin 0) unFeatured treasuryDonation - & L.currentTreasuryValueTxBodyL .~ L.maybeToStrictMaybe (unFeatured <$> currentTresuryValue) + & L.currentTreasuryValueTxBodyL + .~ L.maybeToStrictMaybe (maybe (Just $ L.Coin 0) unFeatured currentTresuryValue) hashTxBody :: L.HashAnnotated (Ledger.TxBody era) EraIndependentTxBody L.StandardCrypto @@ -182,7 +176,7 @@ signTx -> [L.BootstrapWitness L.StandardCrypto] -> [L.WitVKey L.Witness L.StandardCrypto] -> UnsignedTx era - -> Ledger.Tx (ToConstrainedLedgerEra era) + -> Ledger.Tx (LedgerEra era) signTx era bootstrapWits shelleyKeyWits (UnsignedTx unsigned) = obtainCommonConstraints era $ let currentScriptWitnesses = unsigned ^. L.witsTxL @@ -196,23 +190,6 @@ signTx era bootstrapWits shelleyKeyWits (UnsignedTx unsigned) = signedTx = unsigned & L.witsTxL .~ (keyWits <> currentScriptWitnesses) in signedTx -obtainCommonConstraints - :: Era era - -> (EraCommonConstraints era => a) - -> a -obtainCommonConstraints BabbageEra x = x -obtainCommonConstraints ConwayEra x = x - -type EraCommonConstraints era = - ( L.AlonzoEraTx (ToConstrainedLedgerEra era) - , L.BabbageEraTxBody (ToConstrainedLedgerEra era) - , L.EraTx (ToConstrainedLedgerEra era) - , L.EraUTxO (ToConstrainedLedgerEra era) - , Ledger.EraCrypto (ToConstrainedLedgerEra era) ~ L.StandardCrypto - , ShelleyLedgerEra (AvailableErasToSbe era) ~ ToConstrainedLedgerEra era - , L.HashAnnotated (Ledger.TxBody (ToConstrainedLedgerEra era)) EraIndependentTxBody L.StandardCrypto - ) - -- Compatibility related. Will be removed once the old api has been deprecated and deleted. convertTxBodyToUnsignedTx @@ -225,18 +202,3 @@ convertTxBodyToUnsignedTx sbe txbody = in UnsignedTx $ obtainShimConstraints w unsignedLedgerTx ) sbe - --- We need these constraints in order to propagate the new --- experimental api without changing the existing api -type EraShimConstraints era = - ( ToConstrainedLedgerEra (ApiEraToExperimentalEra era) ~ ShelleyLedgerEra era - , AvailableErasToSbe (ApiEraToExperimentalEra era) ~ era - , L.EraTx (ApiErasToLedgerEras era) - ) - -obtainShimConstraints - :: BabbageEraOnwards era - -> (EraShimConstraints era => a) - -> a -obtainShimConstraints BabbageEraOnwardsBabbage x = x -obtainShimConstraints BabbageEraOnwardsConway x = x diff --git a/cardano-api/internal/Cardano/Api/Fees.hs b/cardano-api/internal/Cardano/Api/Fees.hs index 9061f1441..ba1a9dbdb 100644 --- a/cardano-api/internal/Cardano/Api/Fees.hs +++ b/cardano-api/internal/Cardano/Api/Fees.hs @@ -58,7 +58,7 @@ import Cardano.Api.Eon.ShelleyToAlonzoEra import Cardano.Api.Eras.Case import Cardano.Api.Eras.Core import Cardano.Api.Error -import Cardano.Api.Experimental.Eras (sbeToEra) +import Cardano.Api.Experimental.Eras (obtainShimConstraints, sbeToEra) import qualified Cardano.Api.Experimental.Eras as Exp import Cardano.Api.Experimental.Tx import Cardano.Api.Feature @@ -956,7 +956,7 @@ data BalancedTxBody era where -> BalancedTxBody era deriving instance - (Exp.UseEra (Exp.ApiEraToExperimentalEra era), IsShelleyBasedEra era) => Show (BalancedTxBody era) + (Exp.IsEra (Exp.ApiEraToExperimentalEra era), IsShelleyBasedEra era) => Show (BalancedTxBody era) newtype RequiredShelleyKeyWitnesses = RequiredShelleyKeyWitnesses {unRequiredShelleyKeyWitnesses :: Int} diff --git a/cardano-api/internal/Cardano/Api/Tx/Body.hs b/cardano-api/internal/Cardano/Api/Tx/Body.hs index 39232f5b5..3663882ed 100644 --- a/cardano-api/internal/Cardano/Api/Tx/Body.hs +++ b/cardano-api/internal/Cardano/Api/Tx/Body.hs @@ -139,7 +139,6 @@ module Cardano.Api.Tx.Body , convExtraKeyWitnesses , convLanguages , convMintValue - , convProposalProcedures , convReferenceInputs , convReturnCollateral , convScripts diff --git a/cardano-api/src/Cardano/Api/Experimental.hs b/cardano-api/src/Cardano/Api/Experimental.hs index d38703348..3a4716fe5 100644 --- a/cardano-api/src/Cardano/Api/Experimental.hs +++ b/cardano-api/src/Cardano/Api/Experimental.hs @@ -18,14 +18,14 @@ module Cardano.Api.Experimental , BabbageEra , ConwayEra , Era (..) - , ToConstrainedLedgerEra - , UseEra - , ApiErasToLedgerEras - , AvailableErasToSbe + , LedgerEra + , IsEra + , ApiEraToLedgerEra + , ExperimentalEraToApiEra , ApiEraToExperimentalEra , DeprecatedEra (..) , useEra - , protocolVersionToSbe + , eraToSbe , babbageEraOnwardsToEra , sbeToEra )