From 4d2ee8fb407e65bfe380aa3594a7ecf898c4d53e Mon Sep 17 00:00:00 2001 From: John Ky Date: Mon, 5 Jun 2023 14:51:25 +1000 Subject: [PATCH 1/7] New Cardano.Api.Feature module --- cardano-api/cardano-api.cabal | 1 + cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs | 18 +++- cardano-api/internal/Cardano/Api/Feature.hs | 88 +++++++++++++++++++ 3 files changed, 105 insertions(+), 2 deletions(-) create mode 100644 cardano-api/internal/Cardano/Api/Feature.hs diff --git a/cardano-api/cardano-api.cabal b/cardano-api/cardano-api.cabal index e713e244a6..8279ff74de 100644 --- a/cardano-api/cardano-api.cabal +++ b/cardano-api/cardano-api.cabal @@ -57,6 +57,7 @@ library internal Cardano.Api.EraCast Cardano.Api.Eras Cardano.Api.Error + Cardano.Api.Feature Cardano.Api.Fees Cardano.Api.Genesis Cardano.Api.GenesisParameters diff --git a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs index 0c7ef24ecb..6f73431d3b 100644 --- a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs +++ b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs @@ -7,7 +7,9 @@ {-# LANGUAGE TypeApplications #-} module Test.Gen.Cardano.Api.Typed - ( genAddressByron + ( genFeatureValueInEra + + , genAddressByron , genAddressInEra , genAddressShelley , genCertificate @@ -119,6 +121,7 @@ import Cardano.Api hiding (txIns) import qualified Cardano.Api as Api import Cardano.Api.Byron (KeyWitness (ByronKeyWitness), WitnessNetworkIdOrByronAddress (..)) +import Cardano.Api.Feature import Cardano.Api.Script (scriptInEraToRefScript) import Cardano.Api.Shelley (GovernancePoll (..), GovernancePollAnswer (..), Hash (..), KESPeriod (KESPeriod), @@ -137,7 +140,7 @@ import qualified Cardano.Ledger.Alonzo.Scripts as Alonzo import Cardano.Ledger.SafeHash (unsafeMakeSafeHash) import qualified Cardano.Ledger.Shelley.TxBody as Ledger (EraIndependentTxBody) -import Control.Applicative (optional) +import Control.Applicative (Alternative (..), optional) import Data.ByteString (ByteString) import qualified Data.ByteString as BS import qualified Data.ByteString.Short as SBS @@ -703,6 +706,17 @@ genTxBody era = do Left err -> fail (displayError err) Right txBody -> pure txBody +-- | Generate a 'FeatureValue' for the given 'CardanoEra' with the provided generator. +genFeatureValueInEra :: () + => FeatureInEra feature + => Alternative f + => f a + -> CardanoEra era + -> f (FeatureValue feature era a) +genFeatureValueInEra gen = + featureInEra (pure NoFeatureValue) $ \witness -> + pure NoFeatureValue <|> fmap (FeatureValue witness) gen + genTxScriptValidity :: CardanoEra era -> Gen (TxScriptValidity era) genTxScriptValidity era = case txScriptValiditySupportedInCardanoEra era of Nothing -> pure TxScriptValidityNone diff --git a/cardano-api/internal/Cardano/Api/Feature.hs b/cardano-api/internal/Cardano/Api/Feature.hs new file mode 100644 index 0000000000..1d983890c8 --- /dev/null +++ b/cardano-api/internal/Cardano/Api/Feature.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} + +module Cardano.Api.Feature + ( FeatureValue (..) + , FeatureInEra(..) + , featureInShelleyBasedEra + , valueOrDefault + , asFeatureValue + , asFeatureValueInShelleyBasedEra + , isFeatureValue + ) where + +import Cardano.Api.Eras + +import Data.Kind + +-- | A class for features that are supported in some eras but not others. +class FeatureInEra (feature :: Type -> Type) where + -- | Determine the value to use for a feature in a given 'CardanoEra'. + -- Note that the negative case is the first argument, and the positive case is the second as per + -- the 'either' function convention. + featureInEra :: () + => a -- ^ Value to use if the feature is not supported in the era + -> (feature era -> a) -- ^ Function to get thealue to use if the feature is supported in the era + -> CardanoEra era -- ^ Era to check + -> a -- ^ The value to use + +-- | Determine the value to use for a feature in a given 'ShelleyBasedEra'. +featureInShelleyBasedEra :: () + => FeatureInEra feature + => a + -> (feature era -> a) + -> ShelleyBasedEra era + -> a +featureInShelleyBasedEra no yes = featureInEra no yes . shelleyBasedToCardanoEra + +-- | A value of type @'FeatureValue' feature era a@ is either: +data FeatureValue feature era a where + -- | A value is available for this feature in this era + FeatureValue + :: feature era + -- ^ The witness that the feature is supported in this era + -> a + -- ^ The value to use + -> FeatureValue feature era a + + -- | No value is available for this feature in this era + NoFeatureValue + :: FeatureValue feature era a + +deriving instance (Eq a, Eq (feature era)) => Eq (FeatureValue feature era a) +deriving instance (Show a, Show (feature era)) => Show (FeatureValue feature era a) + +-- | Determine if a value is defined. +-- +-- If the value is not defined, it could be because the feature is not supported or +-- because the feature is supported but the value is not available. +isFeatureValue :: FeatureValue feature era a -> Bool +isFeatureValue = \case + NoFeatureValue -> False + FeatureValue _ _ -> True + +-- | Get the value if it is defined, otherwise return the default value. +valueOrDefault :: a -> FeatureValue feature era a -> a +valueOrDefault defaultValue = \case + NoFeatureValue -> defaultValue + FeatureValue _ a -> a + +-- | Attempt to construct a 'FeatureValue' from a value and era. +-- If the feature is not supported in the era, then 'NoFeatureValue' is returned. +asFeatureValue :: () + => FeatureInEra feature + => a + -> CardanoEra era + -> FeatureValue feature era a +asFeatureValue value = featureInEra NoFeatureValue (`FeatureValue` value) + +-- | Attempt to construct a 'FeatureValue' from a value and a shelley-based-era. +asFeatureValueInShelleyBasedEra :: () + => FeatureInEra feature + => a + -> ShelleyBasedEra era + -> FeatureValue feature era a +asFeatureValueInShelleyBasedEra value = asFeatureValue value . shelleyBasedToCardanoEra From df3e51d381fdace47ccbec271bd6804be001b70b Mon Sep 17 00:00:00 2001 From: John Ky Date: Fri, 7 Apr 2023 01:11:34 +1000 Subject: [PATCH 2/7] New ProtocolUpdateUTxOCostPerByteSupportedInEra type --- .../Cardano/Api/ProtocolParameters.hs | 31 +++++++++++++++++++ cardano-api/src/Cardano/Api.hs | 3 ++ 2 files changed, 34 insertions(+) diff --git a/cardano-api/internal/Cardano/Api/ProtocolParameters.hs b/cardano-api/internal/Cardano/Api/ProtocolParameters.hs index a4091cee4f..31bc2d2cf7 100644 --- a/cardano-api/internal/Cardano/Api/ProtocolParameters.hs +++ b/cardano-api/internal/Cardano/Api/ProtocolParameters.hs @@ -8,6 +8,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {- HLINT ignore "Redundant ==" -} @@ -70,11 +71,16 @@ module Cardano.Api.ProtocolParameters ( -- * Data family instances AsType(..), + + -- ** Era-dependent protocol features + ProtocolUTxOCostPerByteFeature(..), + ) where import Cardano.Api.Address import Cardano.Api.Eras import Cardano.Api.Error +import Cardano.Api.Feature import Cardano.Api.Hash import Cardano.Api.HasTypeProxy import Cardano.Api.Json (toRationalJSON) @@ -667,6 +673,31 @@ instance FromCBOR ProtocolParametersUpdate where <*> fromCBOR <*> fromCBOR +-- ---------------------------------------------------------------------------- +-- Features +-- + +-- | A representation of whether the era supports the 'UTxO Cost Per Byte' +-- protocol parameter. +-- +-- The Babbage and subsequent eras support such a protocol parameter. +-- +data ProtocolUTxOCostPerByteFeature era where + ProtocolUTxOCostPerByteInBabbageEra :: ProtocolUTxOCostPerByteFeature BabbageEra + ProtocolUTxOCostPerByteInConwayEra :: ProtocolUTxOCostPerByteFeature ConwayEra + +deriving instance Eq (ProtocolUTxOCostPerByteFeature era) +deriving instance Show (ProtocolUTxOCostPerByteFeature era) + +instance FeatureInEra ProtocolUTxOCostPerByteFeature where + featureInEra no yes = \case + ByronEra -> no + ShelleyEra -> no + AllegraEra -> no + MaryEra -> no + AlonzoEra -> no + BabbageEra -> yes ProtocolUTxOCostPerByteInBabbageEra + ConwayEra -> yes ProtocolUTxOCostPerByteInConwayEra -- ---------------------------------------------------------------------------- -- Praos nonce diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs index 3d3345d1fe..887d565458 100644 --- a/cardano-api/src/Cardano/Api.hs +++ b/cardano-api/src/Cardano/Api.hs @@ -294,6 +294,9 @@ module Cardano.Api ( scriptDataSupportedInEra, totalAndReturnCollateralSupportedInEra, + -- ** Era-dependent protocol features + ProtocolUTxOCostPerByteFeature(..), + -- ** Fee calculation LedgerEpochInfo(..), transactionFee, From 19e9c1dcc17081790de2c2dc464b5a4cc6e53571 Mon Sep 17 00:00:00 2001 From: John Ky Date: Tue, 11 Apr 2023 16:44:39 +1000 Subject: [PATCH 3/7] New ProtocolUpdateUTxOCostPerWordSupportedInEra type --- .../Cardano/Api/ProtocolParameters.hs | 22 +++++++++++++++++++ cardano-api/src/Cardano/Api.hs | 1 + 2 files changed, 23 insertions(+) diff --git a/cardano-api/internal/Cardano/Api/ProtocolParameters.hs b/cardano-api/internal/Cardano/Api/ProtocolParameters.hs index 31bc2d2cf7..045121ef3d 100644 --- a/cardano-api/internal/Cardano/Api/ProtocolParameters.hs +++ b/cardano-api/internal/Cardano/Api/ProtocolParameters.hs @@ -74,6 +74,7 @@ module Cardano.Api.ProtocolParameters ( -- ** Era-dependent protocol features ProtocolUTxOCostPerByteFeature(..), + ProtocolUTxOCostPerWordFeature(..), ) where @@ -699,6 +700,27 @@ instance FeatureInEra ProtocolUTxOCostPerByteFeature where BabbageEra -> yes ProtocolUTxOCostPerByteInBabbageEra ConwayEra -> yes ProtocolUTxOCostPerByteInConwayEra +-- | A representation of whether the era supports the 'UTxO Cost Per Word' +-- protocol parameter. +-- +-- The Babbage and subsequent eras support such a protocol parameter. +-- +data ProtocolUTxOCostPerWordFeature era where + ProtocolUpdateUTxOCostPerWordInAlonzoEra :: ProtocolUTxOCostPerWordFeature AlonzoEra + +deriving instance Eq (ProtocolUTxOCostPerWordFeature era) +deriving instance Show (ProtocolUTxOCostPerWordFeature era) + +instance FeatureInEra ProtocolUTxOCostPerWordFeature where + featureInEra no yes = \case + ByronEra -> no + ShelleyEra -> no + AllegraEra -> no + MaryEra -> no + AlonzoEra -> yes ProtocolUpdateUTxOCostPerWordInAlonzoEra + BabbageEra -> no + ConwayEra -> no + -- ---------------------------------------------------------------------------- -- Praos nonce -- diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs index 887d565458..ee12dc10d6 100644 --- a/cardano-api/src/Cardano/Api.hs +++ b/cardano-api/src/Cardano/Api.hs @@ -296,6 +296,7 @@ module Cardano.Api ( -- ** Era-dependent protocol features ProtocolUTxOCostPerByteFeature(..), + ProtocolUTxOCostPerWordFeature(..), -- ** Fee calculation LedgerEpochInfo(..), From e728649b5d7972d870cf1d3d0f0131cf5a06dd76 Mon Sep 17 00:00:00 2001 From: John Ky Date: Fri, 7 Apr 2023 02:04:34 +1000 Subject: [PATCH 4/7] Generate protocolUpdateUTxOCostPerByte only if it is supported in era. --- cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs index 6f73431d3b..5a60a1165f 100644 --- a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs +++ b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs @@ -946,11 +946,13 @@ genProtocolParametersUpdate = do genUpdateProposal :: CardanoEra era -> Gen UpdateProposal -genUpdateProposal _era = -- TODO Make era specific +genUpdateProposal _era = UpdateProposal <$> Gen.map (Range.constant 1 3) - ((,) <$> genVerificationKeyHash AsGenesisKey - <*> genProtocolParametersUpdate) + ( (,) + <$> genVerificationKeyHash AsGenesisKey + <*> genProtocolParametersUpdate + ) <*> genEpochNo genCostModel :: Gen Alonzo.CostModel From 954c2943dd2237c78098731be3edc378306a3772 Mon Sep 17 00:00:00 2001 From: John Ky Date: Fri, 7 Apr 2023 22:01:38 +1000 Subject: [PATCH 5/7] Use do notation and NamedFieldPuns to implement genProtocolParameters --- cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs | 64 ++++++++++--------- 1 file changed, 33 insertions(+), 31 deletions(-) diff --git a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs index 5a60a1165f..6c246fa00f 100644 --- a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs +++ b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs @@ -126,7 +126,7 @@ import Cardano.Api.Script (scriptInEraToRefScript) import Cardano.Api.Shelley (GovernancePoll (..), GovernancePollAnswer (..), Hash (..), KESPeriod (KESPeriod), OperationalCertificateIssueCounter (OperationalCertificateIssueCounter), - PlutusScript (PlutusScriptSerialised), ProtocolParameters (ProtocolParameters), + PlutusScript (PlutusScriptSerialised), ProtocolParameters (..), ReferenceScript (..), ReferenceTxInsScriptsInlineDatumsSupportedInEra (..), StakeCredential (StakeCredentialByKey), StakePoolKey, refInsScriptsAndInlineDatsSupportedInEra) @@ -163,6 +163,7 @@ import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range {- HLINT ignore "Reduce duplication" -} +{- HLINT ignore "Use let" -} genAddressByron :: Gen (Address ByronAddr) genAddressByron = makeByronAddress <$> genNetworkId @@ -846,36 +847,37 @@ genMaybePraosNonce :: Gen (Maybe PraosNonce) genMaybePraosNonce = Gen.maybe genPraosNonce genProtocolParameters :: Gen ProtocolParameters -genProtocolParameters = - ProtocolParameters - <$> ((,) <$> genNat <*> genNat) - <*> Gen.maybe genRational - <*> genMaybePraosNonce - <*> genNat - <*> genNat - <*> genNat - <*> genLovelace - <*> genLovelace - <*> Gen.maybe genLovelace - <*> genLovelace - <*> genLovelace - <*> genLovelace - <*> genEpochNo - <*> genNat - <*> genRationalInt64 - <*> genRational - <*> genRational - <*> Gen.maybe genLovelace - <*> return mempty - --TODO: Babbage figure out how to deal with - -- asymmetric cost model JSON instances - <*> Gen.maybe genExecutionUnitPrices - <*> Gen.maybe genExecutionUnits - <*> Gen.maybe genExecutionUnits - <*> Gen.maybe genNat - <*> Gen.maybe genNat - <*> Gen.maybe genNat - <*> Gen.maybe genLovelace +genProtocolParameters = do + protocolParamProtocolVersion <- (,) <$> genNat <*> genNat + protocolParamDecentralization <- Gen.maybe genRational + protocolParamExtraPraosEntropy <- genMaybePraosNonce + protocolParamMaxBlockHeaderSize <- genNat + protocolParamMaxBlockBodySize <- genNat + protocolParamMaxTxSize <- genNat + protocolParamTxFeeFixed <- genLovelace + protocolParamTxFeePerByte <- genLovelace + protocolParamMinUTxOValue <- Gen.maybe genLovelace + protocolParamStakeAddressDeposit <- genLovelace + protocolParamStakePoolDeposit <- genLovelace + protocolParamMinPoolCost <- genLovelace + protocolParamPoolRetireMaxEpoch <- genEpochNo + protocolParamStakePoolTargetNum <- genNat + protocolParamPoolPledgeInfluence <- genRationalInt64 + protocolParamMonetaryExpansion <- genRational + protocolParamTreasuryCut <- genRational + protocolParamUTxOCostPerWord <- Gen.maybe genLovelace + protocolParamCostModels <- pure mempty + --TODO: Babbage figure out how to deal with + -- asymmetric cost model JSON instances + protocolParamPrices <- Gen.maybe genExecutionUnitPrices + protocolParamMaxTxExUnits <- Gen.maybe genExecutionUnits + protocolParamMaxBlockExUnits <- Gen.maybe genExecutionUnits + protocolParamMaxValueSize <- Gen.maybe genNat + protocolParamCollateralPercent <- Gen.maybe genNat + protocolParamMaxCollateralInputs <- Gen.maybe genNat + protocolParamUTxOCostPerByte <- Gen.maybe genLovelace + + pure ProtocolParameters {..} -- | Generate valid protocol parameters which pass validations in Cardano.Api.ProtocolParameters genValidProtocolParameters :: Gen ProtocolParameters From 44d6e78406603a35474b29e345bf6bedbcdd03d4 Mon Sep 17 00:00:00 2001 From: John Ky Date: Fri, 7 Apr 2023 22:22:26 +1000 Subject: [PATCH 6/7] Generate protocolParamUTxOCostPerByte only if it is supported in era. --- cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs | 12 ++++++------ .../cardano-api-test/Test/Cardano/Api/Typed/JSON.hs | 5 ++++- 2 files changed, 10 insertions(+), 7 deletions(-) diff --git a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs index 6c246fa00f..8e59102666 100644 --- a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs +++ b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs @@ -638,7 +638,7 @@ genTxBodyContent era = do txMetadata <- genTxMetadataInEra era txAuxScripts <- genTxAuxScripts era let txExtraKeyWits = TxExtraKeyWitnessesNone --TODO: Alonzo era: Generate witness key hashes - txProtocolParams <- BuildTxWith <$> Gen.maybe genValidProtocolParameters + txProtocolParams <- BuildTxWith <$> Gen.maybe (genValidProtocolParameters era) txWithdrawals <- genTxWithdrawals era txCertificates <- genTxCertificates era txUpdateProposal <- genTxUpdateProposal era @@ -846,8 +846,8 @@ genPraosNonce = makePraosNonce <$> Gen.bytes (Range.linear 0 32) genMaybePraosNonce :: Gen (Maybe PraosNonce) genMaybePraosNonce = Gen.maybe genPraosNonce -genProtocolParameters :: Gen ProtocolParameters -genProtocolParameters = do +genProtocolParameters :: CardanoEra era -> Gen ProtocolParameters +genProtocolParameters _era = do protocolParamProtocolVersion <- (,) <$> genNat <*> genNat protocolParamDecentralization <- Gen.maybe genRational protocolParamExtraPraosEntropy <- genMaybePraosNonce @@ -875,13 +875,13 @@ genProtocolParameters = do protocolParamMaxValueSize <- Gen.maybe genNat protocolParamCollateralPercent <- Gen.maybe genNat protocolParamMaxCollateralInputs <- Gen.maybe genNat - protocolParamUTxOCostPerByte <- Gen.maybe genLovelace + protocolParamUTxOCostPerByte <- fmap Just genLovelace pure ProtocolParameters {..} -- | Generate valid protocol parameters which pass validations in Cardano.Api.ProtocolParameters -genValidProtocolParameters :: Gen ProtocolParameters -genValidProtocolParameters = +genValidProtocolParameters :: CardanoEra era -> Gen ProtocolParameters +genValidProtocolParameters _era = ProtocolParameters <$> ((,) <$> genNat <*> genNat) <*> Gen.maybe genRational diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/JSON.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/JSON.hs index 2a946d83ca..b3f36cc44d 100644 --- a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/JSON.hs +++ b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/JSON.hs @@ -8,6 +8,8 @@ module Test.Cardano.Api.Typed.JSON ( tests ) where +import Cardano.Api + import Data.Aeson (eitherDecode, encode) import Test.Gen.Cardano.Api.Typed (genMaybePraosNonce, genProtocolParameters) @@ -29,7 +31,8 @@ prop_roundtrip_praos_nonce_JSON = H.property $ do prop_roundtrip_protocol_parameters_JSON :: Property prop_roundtrip_protocol_parameters_JSON = H.property $ do - pp <- forAll genProtocolParameters + AnyCardanoEra era <- forAll $ Gen.element [minBound .. maxBound] + pp <- forAll (genProtocolParameters era) tripping pp encode eitherDecode -- ----------------------------------------------------------------------------- From cc83938a2c5b937f1b331697bcf6ad941fed3ab4 Mon Sep 17 00:00:00 2001 From: John Ky Date: Tue, 11 Apr 2023 16:45:16 +1000 Subject: [PATCH 7/7] Generate protocolParamUTxOCostPerWord only if it is supported in era. --- cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs | 25 ++++++++++--------- cardano-api/src/Cardano/Api.hs | 2 ++ 2 files changed, 15 insertions(+), 12 deletions(-) diff --git a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs index 8e59102666..b50fcff0e1 100644 --- a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs +++ b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs @@ -847,7 +847,7 @@ genMaybePraosNonce :: Gen (Maybe PraosNonce) genMaybePraosNonce = Gen.maybe genPraosNonce genProtocolParameters :: CardanoEra era -> Gen ProtocolParameters -genProtocolParameters _era = do +genProtocolParameters era = do protocolParamProtocolVersion <- (,) <$> genNat <*> genNat protocolParamDecentralization <- Gen.maybe genRational protocolParamExtraPraosEntropy <- genMaybePraosNonce @@ -865,7 +865,7 @@ genProtocolParameters _era = do protocolParamPoolPledgeInfluence <- genRationalInt64 protocolParamMonetaryExpansion <- genRational protocolParamTreasuryCut <- genRational - protocolParamUTxOCostPerWord <- Gen.maybe genLovelace + protocolParamUTxOCostPerWord <- featureInEra @ProtocolUTxOCostPerWordFeature (pure Nothing) (const (Just <$> genLovelace)) era protocolParamCostModels <- pure mempty --TODO: Babbage figure out how to deal with -- asymmetric cost model JSON instances @@ -875,13 +875,13 @@ genProtocolParameters _era = do protocolParamMaxValueSize <- Gen.maybe genNat protocolParamCollateralPercent <- Gen.maybe genNat protocolParamMaxCollateralInputs <- Gen.maybe genNat - protocolParamUTxOCostPerByte <- fmap Just genLovelace + protocolParamUTxOCostPerByte <- featureInEra @ProtocolUTxOCostPerByteFeature (pure Nothing) (const (Just <$> genLovelace)) era pure ProtocolParameters {..} -- | Generate valid protocol parameters which pass validations in Cardano.Api.ProtocolParameters genValidProtocolParameters :: CardanoEra era -> Gen ProtocolParameters -genValidProtocolParameters _era = +genValidProtocolParameters era = ProtocolParameters <$> ((,) <$> genNat <*> genNat) <*> Gen.maybe genRational @@ -901,7 +901,7 @@ genValidProtocolParameters _era = <*> genRational <*> genRational -- 'Just' is required by checks in Cardano.Api.ProtocolParameters - <*> fmap Just genLovelace + <*> featureInEra @ProtocolUTxOCostPerWordFeature (pure Nothing) (const (Just <$> genLovelace)) era <*> return mempty --TODO: Babbage figure out how to deal with -- asymmetric cost model JSON instances @@ -912,10 +912,10 @@ genValidProtocolParameters _era = <*> fmap Just genNat <*> fmap Just genNat <*> fmap Just genNat - <*> fmap Just genLovelace + <*> featureInEra @ProtocolUTxOCostPerByteFeature (pure Nothing) (const (Just <$> genLovelace)) era -genProtocolParametersUpdate :: Gen ProtocolParametersUpdate -genProtocolParametersUpdate = do +genProtocolParametersUpdate :: CardanoEra era -> Gen ProtocolParametersUpdate +genProtocolParametersUpdate era = do protocolUpdateProtocolVersion <- Gen.maybe ((,) <$> genNat <*> genNat) protocolUpdateDecentralization <- Gen.maybe genRational protocolUpdateExtraPraosEntropy <- Gen.maybe genMaybePraosNonce @@ -933,7 +933,7 @@ genProtocolParametersUpdate = do protocolUpdatePoolPledgeInfluence <- Gen.maybe genRationalInt64 protocolUpdateMonetaryExpansion <- Gen.maybe genRational protocolUpdateTreasuryCut <- Gen.maybe genRational - protocolUpdateUTxOCostPerWord <- Gen.maybe genLovelace + protocolUpdateUTxOCostPerWord <- featureInEra @ProtocolUTxOCostPerWordFeature (pure Nothing) (const (Just <$> genLovelace)) era let protocolUpdateCostModels = mempty -- genCostModels --TODO: Babbage figure out how to deal with -- asymmetric cost model JSON instances @@ -943,17 +943,18 @@ genProtocolParametersUpdate = do protocolUpdateMaxValueSize <- Gen.maybe genNat protocolUpdateCollateralPercent <- Gen.maybe genNat protocolUpdateMaxCollateralInputs <- Gen.maybe genNat - protocolUpdateUTxOCostPerByte <- Gen.maybe genLovelace + protocolUpdateUTxOCostPerByte <- featureInEra @ProtocolUTxOCostPerByteFeature (pure Nothing) (const (Just <$> genLovelace)) era + pure ProtocolParametersUpdate{..} genUpdateProposal :: CardanoEra era -> Gen UpdateProposal -genUpdateProposal _era = +genUpdateProposal era = UpdateProposal <$> Gen.map (Range.constant 1 3) ( (,) <$> genVerificationKeyHash AsGenesisKey - <*> genProtocolParametersUpdate + <*> genProtocolParametersUpdate era ) <*> genEpochNo diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs index ee12dc10d6..53cd6a979c 100644 --- a/cardano-api/src/Cardano/Api.hs +++ b/cardano-api/src/Cardano/Api.hs @@ -277,6 +277,7 @@ module Cardano.Api ( CertificatesSupportedInEra(..), UpdateProposalSupportedInEra(..), TxTotalAndReturnCollateralSupportedInEra(..), + FeatureInEra(..), -- ** Feature availability functions collateralSupportedInEra, @@ -861,6 +862,7 @@ import Cardano.Api.DeserialiseAnyOf import Cardano.Api.EraCast import Cardano.Api.Eras import Cardano.Api.Error +import Cardano.Api.Feature import Cardano.Api.Fees import Cardano.Api.Genesis import Cardano.Api.GenesisParameters