From a9c2137c1d6babe9f65dc27feefa886fe95533b5 Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Fri, 15 Dec 2023 10:10:59 -0400 Subject: [PATCH] Implement Era GADT and UseEra class as an alternative to the existing era handling code --- cardano-api/cardano-api.cabal | 1 + .../internal/Cardano/Api/Protocol/Version.hs | 158 ++++++++---------- cardano-api/src/Cardano/Api/Experimental.hs | 16 ++ 3 files changed, 85 insertions(+), 90 deletions(-) create mode 100644 cardano-api/src/Cardano/Api/Experimental.hs diff --git a/cardano-api/cardano-api.cabal b/cardano-api/cardano-api.cabal index 289d20d946..25b9fcfd61 100644 --- a/cardano-api/cardano-api.cabal +++ b/cardano-api/cardano-api.cabal @@ -231,6 +231,7 @@ library Cardano.Api.ChainSync.Client Cardano.Api.ChainSync.ClientPipelined Cardano.Api.Crypto.Ed25519Bip32 + Cardano.Api.Experimental Cardano.Api.Shelley -- TODO: Eliminate Cardano.Api.Ledger when -- cardano-api only depends on modules diff --git a/cardano-api/internal/Cardano/Api/Protocol/Version.hs b/cardano-api/internal/Cardano/Api/Protocol/Version.hs index 42ffef8534..3c13943e63 100644 --- a/cardano-api/internal/Cardano/Api/Protocol/Version.hs +++ b/cardano-api/internal/Cardano/Api/Protocol/Version.hs @@ -1,130 +1,108 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilyDependencies #-} {-# LANGUAGE TypeOperators #-} - - -module Cardano.Api.Protocol.Version where +-- | This module defines the protocol versions corresponding to the eras in the Cardano blockchain. +module Cardano.Api.Protocol.Version + ( BabbageEra + , ConwayEra + , Era + , MaxSupportedVersion + , MinSupportedVersion + , RequiresCurrent + , SupportedProtocolVersionRange + , UseEra + , VersionToEra + , getProtocolVersion + , protocolVersionToSbe + ) where import Cardano.Api.Eon.ShelleyBasedEra (ShelleyBasedEra (..)) import qualified Cardano.Api.Eras.Core as Api -import Cardano.Api.Script -import Cardano.Api.TxBody -import qualified Data.Set as Set import GHC.TypeLits --- Users interacting with Cardano are likely only interested in using the latest --- features available on mainnet and experimenting with the upcoming era as this becomes --- available. Therefore we restrict the choices of protocol version to what is currently --- on mainnet and what is in the upcoming era. +-- | 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). +-- +-- - 'MinSupportedVersion': Represents the minimum protocol version, aligning with the current +-- era on mainnet (Babbage era). +-- - 'MaxSupportedVersion': Represents the maximum protocol version, corresponding to the next +-- era planned for Cardano's mainnet (Conway era). --- | Minimum supported version. Corresponds to Babbage era. +-- | The minimum supported protocol version, corresponding to the Babbage era on Cardano's mainnet. type MinSupportedVersion = 8 :: Nat --- | Maximum supported version. Corresponds to Conway era. +-- | The maximum supported protocol version, representing the upcoming Conway era. type MaxSupportedVersion = 9 :: Nat type BabbageEra = 8 :: Nat type ConwayEra = 9 :: Nat -type PostConwayEra = 10 :: Nat type SupportedProtocolVersionRange (version :: Nat) = ( MinSupportedVersion <= version , version <= MaxSupportedVersion ) --- Will eventually disappear +-- Allows us to gradually change the api without breaking things. +-- This will eventually be removed. type family RequiresCurrent (version :: Nat) = era | era -> version where RequiresCurrent BabbageEra = Api.BabbageEra -data SomeProtocolVersion (version :: Nat) where - CurrentProtocolVersion +-- | Represents the eras in Cardano's blockchain history. +-- +-- Instead of enumerating every possible era, we use two constructors: +-- 'CurrentEra' and 'UpcomingEra'. This design simplifies the handling +-- of eras, especially for 'cardano-api' consumers who are primarily concerned +-- with the current mainnet era and the next era for an upcoming hardfork. +-- +-- Usage: +-- - 'CurrentEra': Reflects the era currently active on mainnet. +-- - 'UpcomingEra': Represents the era planned for the next hardfork. +-- +-- After a hardfork, 'cardano-api' should be updated promptly to reflect +-- the new mainnet era in 'CurrentEra'. +-- +-- Each era is associated with a specific protocol version: +-- - 'BabbageEra' for 'CurrentEra' +-- - 'ConwayEra' for 'UpcomingEra' +data Era (version :: Nat) where + -- | The era currently active on Cardano's mainnet. + CurrentEra :: SupportedProtocolVersionRange BabbageEra - => SomeProtocolVersion BabbageEra - UpcomingProtocolVersion + => Era BabbageEra + -- | The era planned for the next hardfork on Cardano's mainnet. + UpcomingEra :: SupportedProtocolVersionRange ConwayEra - => SomeProtocolVersion ConwayEra - + => Era ConwayEra type family VersionToEra (version :: Nat) where VersionToEra BabbageEra = Api.BabbageEra VersionToEra ConwayEra = Api.ConwayEra protocolVersionToSbe - :: SomeProtocolVersion version + :: Era version -> ShelleyBasedEra (VersionToEra version) -protocolVersionToSbe CurrentProtocolVersion = ShelleyBasedEraBabbage -protocolVersionToSbe UpcomingProtocolVersion = ShelleyBasedEraConway - --- An Example. Functions exposed to users should be generic in version. -validateTxBodyContent' - :: SomeProtocolVersion version - -> TxBodyContent BuildTx (VersionToEra version) - -> Either TxBodyError () -validateTxBodyContent' p txBodContent@TxBodyContent { - txIns, - txInsCollateral, - txOuts, - txProtocolParams, - txMintValue, - txMetadata} = do - - let sbe = protocolVersionToSbe p - witnesses = collectTxBodyScriptWitnesses sbe txBodContent - languages = Set.fromList - [ toAlonzoLanguage (AnyPlutusScriptVersion v) - | (_, AnyScriptWitness (PlutusScriptWitness _ v _ _ _ _)) <- witnesses - ] - - validateTxIns txIns - validateTxOuts sbe txOuts - validateMetadata txMetadata - validateMintValue txMintValue - validateTxInsCollateral txInsCollateral languages - validateProtocolParameters txProtocolParams languages - - case p of - CurrentProtocolVersion -> do - guardShelleyTxInsOverflow (map fst txIns) - validateTxIns' p txIns - UpcomingProtocolVersion -> pure () - --- RequiresCurrent allows modification of existing cardano-api until the --- refactor is complete. Note that functions which are not era dependent will --- not have SomeProtocolVersion as a parameter. -validateTxIns' - :: SomeProtocolVersion BabbageEra - -> [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn (RequiresCurrent BabbageEra)))] - -> Either TxBodyError () -validateTxIns' _ _txIns = - sequence_ [ - ] - - -newtype UpdatedWitness (version :: Nat) = UpdatedWitness () - --- For functionality specific to an era we use concrete types -futureValidateTxIns - :: SomeProtocolVersion BabbageEra - -> [(TxIn, BuildTxWith BuildTx (UpdatedWitness BabbageEra))] - -> Either TxBodyError () -futureValidateTxIns p _txIns = - case p of - CurrentProtocolVersion -> sequence_ [] - --- This will give a type error when we update CurrentProtocolVersion BabbageEra --- to CurrentProtocolVersion ConwayEra -example - :: SomeProtocolVersion version - -> [(TxIn, BuildTxWith BuildTx (UpdatedWitness version))] - -> Either TxBodyError () -example p' txins = - case p' of - CurrentProtocolVersion -> futureValidateTxIns p' txins - UpcomingProtocolVersion -> pure () +protocolVersionToSbe CurrentEra = ShelleyBasedEraBabbage +protocolVersionToSbe UpcomingEra = ShelleyBasedEraConway + +------------------------------------------------------------------------- + +-- | Type class interface for the 'Era' type. + +class UseEra (version :: Nat) where + getProtocolVersion :: Era version + +instance UseEra BabbageEra where + getProtocolVersion = CurrentEra + +instance UseEra ConwayEra where + getProtocolVersion = UpcomingEra diff --git a/cardano-api/src/Cardano/Api/Experimental.hs b/cardano-api/src/Cardano/Api/Experimental.hs new file mode 100644 index 0000000000..24b4854172 --- /dev/null +++ b/cardano-api/src/Cardano/Api/Experimental.hs @@ -0,0 +1,16 @@ +module Cardano.Api.Experimental + ( -- * New Era interface + BabbageEra + , ConwayEra + , Era + , MaxSupportedVersion + , MinSupportedVersion + , RequiresCurrent + , SupportedProtocolVersionRange + , UseEra + , VersionToEra + , getProtocolVersion + , protocolVersionToSbe + ) where + +import Cardano.Api.Protocol.Version