From fa2b9e2c4ba494eb00dbb314ca50671690d2b785 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Cl=C3=A9ment=20Hurlin?= Date: Thu, 16 Jan 2025 17:36:36 +0100 Subject: [PATCH] Remove ProtocolParameters --- cardano-api/cardano-api.cabal | 3 - cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs | 34 - .../Cardano/Api/ProtocolParameters.hs | 597 +----------------- cardano-api/src/Cardano/Api.hs | 2 - cardano-api/src/Cardano/Api/Shelley.hs | 3 - .../Golden/Cardano/Api/ProtocolParameters.hs | 144 ----- .../cardano-api-test/Test/Cardano/Api/Json.hs | 7 - .../Test/Cardano/Api/ProtocolParameters.hs | 220 ------- .../test/cardano-api-test/cardano-api-test.hs | 2 - 9 files changed, 2 insertions(+), 1010 deletions(-) delete mode 100644 cardano-api/test/cardano-api-golden/Test/Golden/Cardano/Api/ProtocolParameters.hs delete mode 100644 cardano-api/test/cardano-api-test/Test/Cardano/Api/ProtocolParameters.hs diff --git a/cardano-api/cardano-api.cabal b/cardano-api/cardano-api.cabal index d1cb46b7f7..3b9b5c145f 100644 --- a/cardano-api/cardano-api.cabal +++ b/cardano-api/cardano-api.cabal @@ -367,7 +367,6 @@ test-suite cardano-api-test Test.Cardano.Api.Metadata Test.Cardano.Api.Ord Test.Cardano.Api.Orphans - Test.Cardano.Api.ProtocolParameters Test.Cardano.Api.RawBytes Test.Cardano.Api.Transaction.Autobalance Test.Cardano.Api.TxBody @@ -396,7 +395,6 @@ test-suite cardano-api-golden cardano-data >=1.0, cardano-ledger-alonzo, cardano-ledger-api ^>=1.9, - cardano-ledger-babbage >=1.9, cardano-ledger-binary, cardano-ledger-core:{cardano-ledger-core, testlib} >=1.14, cardano-ledger-shelley, @@ -425,7 +423,6 @@ test-suite cardano-api-golden other-modules: Test.Golden.Cardano.Api.Genesis Test.Golden.Cardano.Api.Ledger - Test.Golden.Cardano.Api.ProtocolParameters Test.Golden.Cardano.Api.Script Test.Golden.Cardano.Api.Value Test.Golden.ErrorsSpec diff --git a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs index 26eafc9733..7e9b32b1c1 100644 --- a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs +++ b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs @@ -30,7 +30,6 @@ module Test.Gen.Cardano.Api.Typed , genMaybePraosNonce , genPraosNonce , genValidProtocolParameters - , genProtocolParameters , genValueNestedRep , genValueNestedBundle , genByronKeyWitness @@ -990,39 +989,6 @@ genPraosNonce = makePraosNonce <$> Gen.bytes (Range.linear 0 32) genMaybePraosNonce :: Gen (Maybe PraosNonce) genMaybePraosNonce = Gen.maybe genPraosNonce -genProtocolParameters :: CardanoEra era -> Gen ProtocolParameters -genProtocolParameters era = 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 <- genEpochInterval - protocolParamStakePoolTargetNum <- genNat - protocolParamPoolPledgeInfluence <- genRationalInt64 - protocolParamMonetaryExpansion <- genRational - protocolParamTreasuryCut <- genRational - let protocolParamCostModels = 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 <- - inEonForEra @BabbageEraOnwards (pure Nothing) (const (Just <$> genLovelace)) era - - pure ProtocolParameters{..} - -- | Generate valid protocol parameters which pass validations in Cardano.Api.ProtocolParameters genValidProtocolParameters :: ShelleyBasedEra era -> Gen (LedgerProtocolParameters era) genValidProtocolParameters sbe = shelleyBasedEraTestConstraints sbe $ LedgerProtocolParameters <$> Q.arbitrary diff --git a/cardano-api/internal/Cardano/Api/ProtocolParameters.hs b/cardano-api/internal/Cardano/Api/ProtocolParameters.hs index 9290ae35be..62fa902664 100644 --- a/cardano-api/internal/Cardano/Api/ProtocolParameters.hs +++ b/cardano-api/internal/Cardano/Api/ProtocolParameters.hs @@ -30,9 +30,7 @@ -- * parameters fixed in the genesis file: 'GenesisParameters' module Cardano.Api.ProtocolParameters ( -- * The updatable protocol parameters - ProtocolParameters (..) - , checkProtocolParameters - , EpochNo + EpochNo -- * The updatable protocol parameters , LedgerProtocolParameters (..) @@ -45,7 +43,6 @@ module Cardano.Api.ProtocolParameters , IntroducedInBabbagePParams (..) , IntroducedInConwayPParams (..) , createEraBasedProtocolParamUpdate - , convertToLedgerProtocolParameters , createPParams -- * Deprecated @@ -76,9 +73,7 @@ module Cardano.Api.ProtocolParameters , fromLedgerUpdate , toLedgerProposedPPUpdates , fromLedgerProposedPPUpdates - , toLedgerPParams , toLedgerPParamsUpdate - , fromLedgerPParams , fromLedgerPParamsUpdate , toAlonzoPrices , fromAlonzoPrices @@ -138,8 +133,7 @@ import Cardano.Slotting.Slot (EpochNo (..)) import PlutusLedgerApi.Common (CostModelApplyError) import Control.Monad -import Data.Aeson (FromJSON (..), ToJSON (..), object, withObject, (.!=), (.:), (.:?), - (.=)) +import Data.Aeson (FromJSON (..), ToJSON (..), object, withObject, (.:), (.=)) import Data.Bifunctor (bimap, first) import Data.ByteString (ByteString) import Data.Data (Data) @@ -147,7 +141,6 @@ import Data.Either.Combinators (maybeToRight) import Data.Int (Int64) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map -import Data.Maybe (isJust) import Data.Maybe.Strict (StrictMaybe (..)) import Data.String (IsString) import Data.Text (Text) @@ -175,17 +168,6 @@ instance IsShelleyBasedEra era => Eq (LedgerProtocolParameters era) where shelleyBasedEraConstraints (shelleyBasedEra @era) $ a == b -{-# DEPRECATED - convertToLedgerProtocolParameters - "Use the ledger's PParams (from module Cardano.Api.Ledger) type instead of ProtocolParameters. The type will be removed after Chang hard fork." - #-} -convertToLedgerProtocolParameters - :: ShelleyBasedEra era - -> ProtocolParameters - -> Either ProtocolParametersConversionError (LedgerProtocolParameters era) -convertToLedgerProtocolParameters sbe pp = - LedgerProtocolParameters <$> toLedgerPParams sbe pp - createPParams :: ShelleyBasedEra era -> EraBasedProtocolParametersUpdate era @@ -447,203 +429,6 @@ createIntroducedInBabbagePParams w (IntroducedInBabbagePParams coinsPerUTxOByte) babbageEraOnwardsConstraints w $ Ledger.emptyPParamsUpdate & Ledger.ppuCoinsPerUTxOByteL .~ coinsPerUTxOByte --- | The values of the set of /updatable/ protocol parameters. At any --- particular point on the chain there is a current set of parameters in use. --- --- These parameters can be updated (at epoch boundaries) via an --- 'UpdateProposal', which contains a 'ProtocolParametersUpdate'. --- --- The 'ProtocolParametersUpdate' is essentially a diff for the --- 'ProtocolParameters'. --- --- There are also parameters fixed in the Genesis file. See 'GenesisParameters'. -{-# DEPRECATED - ProtocolParameters - "Use the ledger's PParams (from module Cardano.Api.Ledger) type instead of ProtocolParameters. The type will be removed after Chang hard fork." - #-} - -data ProtocolParameters - = ProtocolParameters - { protocolParamProtocolVersion :: (Natural, Natural) - -- ^ Protocol version, major and minor. Updating the major version is - -- used to trigger hard forks. - -- (Major , Minor ) - , protocolParamDecentralization :: Maybe Rational - -- ^ The decentralization parameter. This is fraction of slots that - -- belong to the BFT overlay schedule, rather than the Praos schedule. - -- So 1 means fully centralised, while 0 means fully decentralised. - -- - -- This is the \"d\" parameter from the design document. - -- - -- /Deprecated in Babbage/ - , protocolParamExtraPraosEntropy :: Maybe PraosNonce - -- ^ Extra entropy for the Praos per-epoch nonce. - -- - -- This can be used to add extra entropy during the decentralisation - -- process. If the extra entropy can be demonstrated to be generated - -- randomly then this method can be used to show that the initial - -- federated operators did not subtly bias the initial schedule so that - -- they retain undue influence after decentralisation. - , protocolParamMaxBlockHeaderSize :: Natural - -- ^ The maximum permitted size of a block header. - -- - -- This must be at least as big as the largest legitimate block headers - -- but should not be too much larger, to help prevent DoS attacks. - -- - -- Caution: setting this to be smaller than legitimate block headers is - -- a sure way to brick the system! - , protocolParamMaxBlockBodySize :: Natural - -- ^ The maximum permitted size of the block body (that is, the block - -- payload, without the block header). - -- - -- This should be picked with the Praos network delta security parameter - -- in mind. Making this too large can severely weaken the Praos - -- consensus properties. - -- - -- Caution: setting this to be smaller than a transaction that can - -- change the protocol parameters is a sure way to brick the system! - , protocolParamMaxTxSize :: Natural - -- ^ The maximum permitted size of a transaction. - -- - -- Typically this should not be too high a fraction of the block size, - -- otherwise wastage from block fragmentation becomes a problem, and - -- the current implementation does not use any sophisticated box packing - -- algorithm. - , protocolParamTxFeeFixed :: L.Coin - -- ^ The constant factor for the minimum fee calculation. - , protocolParamTxFeePerByte :: L.Coin - -- ^ Per byte linear factor for the minimum fee calculation. - , protocolParamMinUTxOValue :: Maybe L.Coin - -- ^ The minimum permitted value for new UTxO entries, ie for - -- transaction outputs. - , protocolParamStakeAddressDeposit :: L.Coin - -- ^ The deposit required to register a stake address. - , protocolParamStakePoolDeposit :: L.Coin - -- ^ The deposit required to register a stake pool. - , protocolParamMinPoolCost :: L.Coin - -- ^ The minimum value that stake pools are permitted to declare for - -- their cost parameter. - , protocolParamPoolRetireMaxEpoch :: Ledger.EpochInterval - -- ^ The maximum number of epochs into the future that stake pools - -- are permitted to schedule a retirement. - , protocolParamStakePoolTargetNum :: Natural - -- ^ The equilibrium target number of stake pools. - -- - -- This is the \"k\" incentives parameter from the design document. - , protocolParamPoolPledgeInfluence :: Rational - -- ^ The influence of the pledge in stake pool rewards. - -- - -- This is the \"a_0\" incentives parameter from the design document. - , protocolParamMonetaryExpansion :: Rational - -- ^ The monetary expansion rate. This determines the fraction of the - -- reserves that are added to the fee pot each epoch. - -- - -- This is the \"rho\" incentives parameter from the design document. - , protocolParamTreasuryCut :: Rational - -- ^ The fraction of the fee pot each epoch that goes to the treasury. - -- - -- This is the \"tau\" incentives parameter from the design document. - , protocolParamCostModels :: Map AnyPlutusScriptVersion CostModel - -- ^ Cost models for script languages that use them. - -- - -- /Introduced in Alonzo/ - , protocolParamPrices :: Maybe ExecutionUnitPrices - -- ^ Price of execution units for script languages that use them. - -- - -- /Introduced in Alonzo/ - , protocolParamMaxTxExUnits :: Maybe ExecutionUnits - -- ^ Max total script execution resources units allowed per tx - -- - -- /Introduced in Alonzo/ - , protocolParamMaxBlockExUnits :: Maybe ExecutionUnits - -- ^ Max total script execution resources units allowed per block - -- - -- /Introduced in Alonzo/ - , protocolParamMaxValueSize :: Maybe Natural - -- ^ Max size of a Value in a tx output. - -- - -- /Introduced in Alonzo/ - , protocolParamCollateralPercent :: Maybe Natural - -- ^ The percentage of the script contribution to the txfee that must be - -- provided as collateral inputs when including Plutus scripts. - -- - -- /Introduced in Alonzo/ - , protocolParamMaxCollateralInputs :: Maybe Natural - -- ^ The maximum number of collateral inputs allowed in a transaction. - -- - -- /Introduced in Alonzo/ - , protocolParamUTxOCostPerByte :: Maybe L.Coin - -- ^ Cost in ada per byte of UTxO storage. - -- - -- /Introduced in Babbage/ - } - deriving (Eq, Generic, Show) - -instance FromJSON ProtocolParameters where - parseJSON = - withObject "ProtocolParameters" $ \o -> do - v <- o .: "protocolVersion" - ProtocolParameters - <$> ((,) <$> v .: "major" <*> v .: "minor") - <*> o .:? "decentralization" - <*> o .: "extraPraosEntropy" - <*> o .: "maxBlockHeaderSize" - <*> o .: "maxBlockBodySize" - <*> o .: "maxTxSize" - <*> o .: "txFeeFixed" - <*> o .: "txFeePerByte" - <*> o .: "minUTxOValue" - <*> o .: "stakeAddressDeposit" - <*> o .: "stakePoolDeposit" - <*> o .: "minPoolCost" - <*> o .: "poolRetireMaxEpoch" - <*> o .: "stakePoolTargetNum" - <*> o .: "poolPledgeInfluence" - <*> o .: "monetaryExpansion" - <*> o .: "treasuryCut" - <*> (fmap unCostModels <$> o .:? "costModels") .!= Map.empty - <*> o .:? "executionUnitPrices" - <*> o .:? "maxTxExecutionUnits" - <*> o .:? "maxBlockExecutionUnits" - <*> o .:? "maxValueSize" - <*> o .:? "collateralPercentage" - <*> o .:? "maxCollateralInputs" - <*> o .:? "utxoCostPerByte" - -instance ToJSON ProtocolParameters where - toJSON ProtocolParameters{..} = - object - [ "extraPraosEntropy" .= protocolParamExtraPraosEntropy - , "stakePoolTargetNum" .= protocolParamStakePoolTargetNum - , "minUTxOValue" .= protocolParamMinUTxOValue - , "poolRetireMaxEpoch" .= protocolParamPoolRetireMaxEpoch - , "decentralization" .= (toRationalJSON <$> protocolParamDecentralization) - , "stakePoolDeposit" .= protocolParamStakePoolDeposit - , "maxBlockHeaderSize" .= protocolParamMaxBlockHeaderSize - , "maxBlockBodySize" .= protocolParamMaxBlockBodySize - , "maxTxSize" .= protocolParamMaxTxSize - , "treasuryCut" .= toRationalJSON protocolParamTreasuryCut - , "minPoolCost" .= protocolParamMinPoolCost - , "monetaryExpansion" .= toRationalJSON protocolParamMonetaryExpansion - , "stakeAddressDeposit" .= protocolParamStakeAddressDeposit - , "poolPledgeInfluence" .= toRationalJSON protocolParamPoolPledgeInfluence - , "protocolVersion" - .= let (major, minor) = protocolParamProtocolVersion - in object ["major" .= major, "minor" .= minor] - , "txFeeFixed" .= protocolParamTxFeeFixed - , "txFeePerByte" .= protocolParamTxFeePerByte - , -- Alonzo era: - "costModels" .= CostModels protocolParamCostModels - , "executionUnitPrices" .= protocolParamPrices - , "maxTxExecutionUnits" .= protocolParamMaxTxExUnits - , "maxBlockExecutionUnits" .= protocolParamMaxBlockExUnits - , "maxValueSize" .= protocolParamMaxValueSize - , "collateralPercentage" .= protocolParamCollateralPercent - , "maxCollateralInputs" .= protocolParamMaxCollateralInputs - , -- Babbage era: - "utxoCostPerByte" .= protocolParamUTxOCostPerByte - ] - -- ---------------------------------------------------------------------------- -- Updates to the protocol parameters -- @@ -1273,13 +1058,6 @@ toBabbagePParamsUpdate & ppuProtocolVersionL .~ noInlineMaybeToStrictMaybe protVer pure ppuBabbage -requireParam - :: String - -> (a -> Either ProtocolParametersConversionError b) - -> Maybe a - -> Either ProtocolParametersConversionError b -requireParam paramName = maybe (Left $ PpceMissingParameter paramName) - mkProtVer :: (Natural, Natural) -> Either ProtocolParametersConversionError Ledger.ProtVer mkProtVer (majorProtVer, minorProtVer) = maybeToRight (PpceVersionInvalid majorProtVer) $ @@ -1454,377 +1232,6 @@ fromConwayPParamsUpdate -> ProtocolParametersUpdate fromConwayPParamsUpdate = fromBabbageCommonPParamsUpdate --- ---------------------------------------------------------------------------- --- Conversion functions: protocol parameters to ledger types --- - -toLedgerPParams - :: ShelleyBasedEra era - -> ProtocolParameters - -> Either ProtocolParametersConversionError (Ledger.PParams (ShelleyLedgerEra era)) -toLedgerPParams ShelleyBasedEraShelley = toShelleyPParams -toLedgerPParams ShelleyBasedEraAllegra = toShelleyPParams -toLedgerPParams ShelleyBasedEraMary = toShelleyPParams -toLedgerPParams ShelleyBasedEraAlonzo = toAlonzoPParams -toLedgerPParams ShelleyBasedEraBabbage = toBabbagePParams -toLedgerPParams ShelleyBasedEraConway = toConwayPParams - -toShelleyCommonPParams - :: EraPParams ledgerera - => ProtocolParameters - -> Either ProtocolParametersConversionError (PParams ledgerera) -toShelleyCommonPParams - ProtocolParameters - { protocolParamProtocolVersion - , protocolParamMaxBlockHeaderSize - , protocolParamMaxBlockBodySize - , protocolParamMaxTxSize - , protocolParamTxFeeFixed - , protocolParamTxFeePerByte - , protocolParamStakeAddressDeposit - , protocolParamStakePoolDeposit - , protocolParamMinPoolCost - , protocolParamPoolRetireMaxEpoch - , protocolParamStakePoolTargetNum - , protocolParamPoolPledgeInfluence - , protocolParamMonetaryExpansion - , protocolParamTreasuryCut - } = do - a0 <- boundRationalEither "A0" protocolParamPoolPledgeInfluence - rho <- boundRationalEither "Rho" protocolParamMonetaryExpansion - tau <- boundRationalEither "Tau" protocolParamTreasuryCut - protVer <- mkProtVer protocolParamProtocolVersion - let ppCommon = - emptyPParams - & ppMinFeeAL .~ protocolParamTxFeePerByte - & ppMinFeeBL .~ protocolParamTxFeeFixed - & ppMaxBBSizeL .~ fromIntegral protocolParamMaxBlockBodySize - & ppMaxTxSizeL .~ fromIntegral protocolParamMaxTxSize - & ppMaxBHSizeL .~ fromIntegral protocolParamMaxBlockHeaderSize - & ppKeyDepositL .~ protocolParamStakeAddressDeposit - & ppPoolDepositL .~ protocolParamStakePoolDeposit - & ppEMaxL .~ protocolParamPoolRetireMaxEpoch - & ppNOptL .~ protocolParamStakePoolTargetNum - & ppA0L .~ a0 - & ppRhoL .~ rho - & ppTauL .~ tau - & ppProtocolVersionL .~ protVer - & ppMinPoolCostL .~ protocolParamMinPoolCost - pure ppCommon - -toShelleyPParams - :: ( EraPParams ledgerera - , Ledger.AtMostEra Ledger.MaryEra ledgerera - , Ledger.AtMostEra Ledger.AlonzoEra ledgerera - ) - => ProtocolParameters - -> Either ProtocolParametersConversionError (PParams ledgerera) -toShelleyPParams - protocolParameters@ProtocolParameters - { protocolParamDecentralization - , protocolParamExtraPraosEntropy - , protocolParamMinUTxOValue - } = do - ppCommon <- toShelleyCommonPParams protocolParameters - d <- - boundRationalEither "D" - =<< maybeToRight (PpceMissingParameter "decentralization") protocolParamDecentralization - minUTxOValue <- - maybeToRight (PpceMissingParameter "protocolParamMinUTxOValue") protocolParamMinUTxOValue - let ppShelley = - ppCommon - & ppDL .~ d - & ppExtraEntropyL .~ toLedgerNonce protocolParamExtraPraosEntropy - & ppMinUTxOValueL .~ minUTxOValue - pure ppShelley - -toAlonzoCommonPParams - :: AlonzoEraPParams ledgerera - => ProtocolParameters - -> Either ProtocolParametersConversionError (PParams ledgerera) -toAlonzoCommonPParams - protocolParameters@ProtocolParameters - { protocolParamCostModels - , protocolParamPrices - , protocolParamMaxTxExUnits - , protocolParamMaxBlockExUnits - , protocolParamMaxValueSize - , protocolParamCollateralPercent - , protocolParamMaxCollateralInputs - } = do - ppShelleyCommon <- toShelleyCommonPParams protocolParameters - costModels <- toAlonzoCostModels protocolParamCostModels - prices <- - requireParam "protocolParamPrices" toAlonzoPrices protocolParamPrices - maxTxExUnits <- - requireParam "protocolParamMaxTxExUnits" Right protocolParamMaxTxExUnits - maxBlockExUnits <- - requireParam "protocolParamMaxBlockExUnits" Right protocolParamMaxBlockExUnits - maxValueSize <- - requireParam "protocolParamMaxBlockExUnits" Right protocolParamMaxValueSize - collateralPercent <- - requireParam "protocolParamCollateralPercent" Right protocolParamCollateralPercent - maxCollateralInputs <- - requireParam "protocolParamMaxCollateralInputs" Right protocolParamMaxCollateralInputs - let ppAlonzoCommon = - ppShelleyCommon - & ppCostModelsL .~ costModels - & ppPricesL .~ prices - & ppMaxTxExUnitsL .~ toAlonzoExUnits maxTxExUnits - & ppMaxBlockExUnitsL .~ toAlonzoExUnits maxBlockExUnits - & ppMaxValSizeL .~ maxValueSize - & ppCollateralPercentageL .~ collateralPercent - & ppMaxCollateralInputsL .~ maxCollateralInputs - pure ppAlonzoCommon - -toAlonzoPParams - :: Ledger.Crypto crypto - => ProtocolParameters - -> Either ProtocolParametersConversionError (PParams (Ledger.AlonzoEra crypto)) -toAlonzoPParams - protocolParameters@ProtocolParameters - { protocolParamDecentralization - } = do - ppAlonzoCommon <- toAlonzoCommonPParams protocolParameters - d <- - requireParam - "protocolParamDecentralization" - (boundRationalEither "D") - protocolParamDecentralization - let ppAlonzo = - ppAlonzoCommon - & ppDL .~ d - pure ppAlonzo - -toBabbagePParams - :: BabbageEraPParams ledgerera - => ProtocolParameters - -> Either ProtocolParametersConversionError (PParams ledgerera) -toBabbagePParams - protocolParameters@ProtocolParameters - { protocolParamUTxOCostPerByte - } = do - ppAlonzoCommon <- toAlonzoCommonPParams protocolParameters - utxoCostPerByte <- - requireParam "protocolParamUTxOCostPerByte" Right protocolParamUTxOCostPerByte - let ppBabbage = - ppAlonzoCommon - & ppCoinsPerUTxOByteL .~ CoinPerByte utxoCostPerByte - pure ppBabbage - -toConwayPParams - :: BabbageEraPParams ledgerera - => ProtocolParameters - -> Either ProtocolParametersConversionError (PParams ledgerera) -toConwayPParams = toBabbagePParams - --- ---------------------------------------------------------------------------- --- Conversion functions: protocol parameters from ledger types --- - -{-# DEPRECATED - fromLedgerPParams - "Use the ledger's PParams (from module Cardano.Api.Ledger) type instead of ProtocolParameters. The type will be removed after Chang hard fork." - #-} -fromLedgerPParams - :: ShelleyBasedEra era - -> Ledger.PParams (ShelleyLedgerEra era) - -> ProtocolParameters -fromLedgerPParams ShelleyBasedEraShelley = fromShelleyPParams -fromLedgerPParams ShelleyBasedEraAllegra = fromShelleyPParams -fromLedgerPParams ShelleyBasedEraMary = fromShelleyPParams -fromLedgerPParams ShelleyBasedEraAlonzo = fromExactlyAlonzoPParams -fromLedgerPParams ShelleyBasedEraBabbage = fromBabbagePParams -fromLedgerPParams ShelleyBasedEraConway = fromConwayPParams - -{-# DEPRECATED - fromShelleyCommonPParams - "Use the ledger's PParams (from module Cardano.Api.Ledger) type instead of ProtocolParameters. The type will be removed after Chang hard fork." - #-} -fromShelleyCommonPParams - :: EraPParams ledgerera - => PParams ledgerera - -> ProtocolParameters -fromShelleyCommonPParams pp = - ProtocolParameters - { protocolParamProtocolVersion = case pp ^. ppProtocolVersionL of - Ledger.ProtVer a b -> (Ledger.getVersion a, b) - , protocolParamMaxBlockHeaderSize = fromIntegral $ pp ^. ppMaxBHSizeL - , protocolParamMaxBlockBodySize = fromIntegral $ pp ^. ppMaxBBSizeL - , protocolParamMaxTxSize = fromIntegral $ pp ^. ppMaxTxSizeL - , protocolParamTxFeeFixed = pp ^. ppMinFeeBL - , protocolParamTxFeePerByte = pp ^. ppMinFeeAL - , protocolParamStakeAddressDeposit = pp ^. ppKeyDepositL - , protocolParamStakePoolDeposit = pp ^. ppPoolDepositL - , protocolParamMinPoolCost = pp ^. ppMinPoolCostL - , protocolParamPoolRetireMaxEpoch = pp ^. ppEMaxL - , protocolParamStakePoolTargetNum = pp ^. ppNOptL - , protocolParamPoolPledgeInfluence = Ledger.unboundRational (pp ^. ppA0L) - , protocolParamMonetaryExpansion = Ledger.unboundRational (pp ^. ppRhoL) - , protocolParamTreasuryCut = Ledger.unboundRational (pp ^. ppTauL) - , protocolParamCostModels = mempty -- Only from Alonzo onwards - , protocolParamPrices = Nothing -- Only from Alonzo onwards - , protocolParamMaxTxExUnits = Nothing -- Only from Alonzo onwards - , protocolParamMaxBlockExUnits = Nothing -- Only from Alonzo onwards - , protocolParamMaxValueSize = Nothing -- Only from Alonzo onwards - , protocolParamCollateralPercent = Nothing -- Only from Alonzo onwards - , protocolParamMaxCollateralInputs = Nothing -- Only from Alonzo onwards - , protocolParamUTxOCostPerByte = Nothing -- Only from Babbage onwards - , protocolParamDecentralization = Nothing -- Obsolete from Babbage onwards - , protocolParamExtraPraosEntropy = Nothing -- Obsolete from Alonzo onwards - , protocolParamMinUTxOValue = Nothing -- Obsolete from Alonzo onwards - } - -{-# DEPRECATED - fromShelleyPParams - "Use the ledger's PParams (from module Cardano.Api.Ledger) type instead of ProtocolParameters. The type will be removed after Chang hard fork." - #-} -fromShelleyPParams - :: ( EraPParams ledgerera - , Ledger.AtMostEra Ledger.MaryEra ledgerera - , Ledger.AtMostEra Ledger.AlonzoEra ledgerera - ) - => PParams ledgerera - -> ProtocolParameters -fromShelleyPParams pp = - (fromShelleyCommonPParams pp) - { protocolParamDecentralization = Just . Ledger.unboundRational $ pp ^. ppDL - , protocolParamExtraPraosEntropy = fromLedgerNonce $ pp ^. ppExtraEntropyL - , protocolParamMinUTxOValue = Just $ pp ^. ppMinUTxOValueL - } - -{-# DEPRECATED - fromAlonzoPParams - "Use the ledger's PParams (from module Cardano.Api.Ledger) type instead of ProtocolParameters. The type will be removed after Chang hard fork." - #-} -fromAlonzoPParams - :: AlonzoEraPParams ledgerera - => PParams ledgerera - -> ProtocolParameters -fromAlonzoPParams pp = - (fromShelleyCommonPParams pp) - { protocolParamCostModels = fromAlonzoCostModels $ pp ^. ppCostModelsL - , protocolParamDecentralization = Just . Ledger.unboundRational $ pp ^. ppDG - , protocolParamPrices = Just . fromAlonzoPrices $ pp ^. ppPricesL - , protocolParamMaxTxExUnits = Just . fromAlonzoExUnits $ pp ^. ppMaxTxExUnitsL - , protocolParamMaxBlockExUnits = Just . fromAlonzoExUnits $ pp ^. ppMaxBlockExUnitsL - , protocolParamMaxValueSize = Just $ pp ^. ppMaxValSizeL - , protocolParamCollateralPercent = Just $ pp ^. ppCollateralPercentageL - , protocolParamMaxCollateralInputs = Just $ pp ^. ppMaxCollateralInputsL - } - -{-# DEPRECATED - fromExactlyAlonzoPParams - "Use the ledger's PParams (from module Cardano.Api.Ledger) type instead of ProtocolParameters. The type will be removed after Chang hard fork." - #-} -fromExactlyAlonzoPParams - :: (AlonzoEraPParams ledgerera, Ledger.ExactEra Ledger.AlonzoEra ledgerera) - => PParams ledgerera - -> ProtocolParameters -fromExactlyAlonzoPParams pp = - (fromAlonzoPParams pp) - { protocolParamUTxOCostPerByte = Just . unCoinPerWord $ pp ^. ppCoinsPerUTxOWordL - } - -{-# DEPRECATED - fromBabbagePParams - "Use the ledger's PParams (from module Cardano.Api.Ledger) type instead of ProtocolParameters. The type will be removed after Chang hard fork." - #-} -fromBabbagePParams - :: BabbageEraPParams ledgerera - => PParams ledgerera - -> ProtocolParameters -fromBabbagePParams pp = - (fromAlonzoPParams pp) - { protocolParamUTxOCostPerByte = Just . unCoinPerByte $ pp ^. ppCoinsPerUTxOByteL - , protocolParamDecentralization = Nothing - } - -{-# DEPRECATED - fromConwayPParams - "Use the ledger's PParams (from module Cardano.Api.Ledger) type instead of ProtocolParameters. The type will be removed after Chang hard fork." - #-} -fromConwayPParams - :: BabbageEraPParams ledgerera - => PParams ledgerera - -> ProtocolParameters -fromConwayPParams = fromBabbagePParams - -{-# DEPRECATED - checkProtocolParameters - "Use the ledger's PParams (from module Cardano.Api.Ledger) type instead of ProtocolParameters. The type will be removed after Chang hard fork. PParams natively enforce these checks." - #-} -checkProtocolParameters - :: () - => ShelleyBasedEra era - -> ProtocolParameters - -> Either ProtocolParametersError () -checkProtocolParameters sbe ProtocolParameters{..} = - case sbe of - ShelleyBasedEraShelley -> checkMinUTxOVal - ShelleyBasedEraAllegra -> checkMinUTxOVal - ShelleyBasedEraMary -> checkMinUTxOVal - ShelleyBasedEraAlonzo -> checkAlonzoParams - ShelleyBasedEraBabbage -> checkBabbageParams - ShelleyBasedEraConway -> checkBabbageParams - where - era = toCardanoEra sbe - - cModel = not $ Map.null protocolParamCostModels - prices = isJust protocolParamPrices - maxTxUnits = isJust protocolParamMaxTxExUnits - maxBlockExUnits = isJust protocolParamMaxBlockExUnits - maxValueSize = isJust protocolParamMaxValueSize - collateralPercent = isJust protocolParamCollateralPercent - maxCollateralInputs = isJust protocolParamMaxCollateralInputs - costPerByte = isJust protocolParamUTxOCostPerByte - decentralization = isJust protocolParamDecentralization - extraPraosEntropy = isJust protocolParamExtraPraosEntropy - - alonzoPParamFieldsRequirements :: [Bool] - alonzoPParamFieldsRequirements = - [ cModel - , prices - , maxTxUnits - , maxBlockExUnits - , maxValueSize - , collateralPercent - , maxCollateralInputs - , not costPerByte - ] - - babbagePParamFieldsRequirements :: [Bool] - babbagePParamFieldsRequirements = - [ cModel - , prices - , maxTxUnits - , maxBlockExUnits - , maxValueSize - , collateralPercent - , maxCollateralInputs - , costPerByte - , not decentralization - , not extraPraosEntropy - ] - - checkAlonzoParams :: Either ProtocolParametersError () - checkAlonzoParams = do - if all (== True) alonzoPParamFieldsRequirements - then return () - else Left PParamsErrorMissingAlonzoProtocolParameter - - checkBabbageParams :: Either ProtocolParametersError () - checkBabbageParams = - if all (== True) babbagePParamFieldsRequirements - then return () - else Left PParamsErrorMissingAlonzoProtocolParameter - - checkMinUTxOVal :: Either ProtocolParametersError () - checkMinUTxOVal = - if isJust protocolParamMinUTxOValue - then return () - else Left . PParamsErrorMissingMinUTxoValue $ cardanoEraConstraints era $ AnyCardanoEra era - data ProtocolParametersError = PParamsErrorMissingMinUTxoValue !AnyCardanoEra | PParamsErrorMissingAlonzoProtocolParameter diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs index 4ca9994569..2633ef28c1 100644 --- a/cardano-api/src/Cardano/Api.hs +++ b/cardano-api/src/Cardano/Api.hs @@ -941,8 +941,6 @@ module Cardano.Api , ProtocolParametersConversionError (..) -- ** Conversions - , toLedgerPParams - , fromLedgerPParams , toCtxUTxOTxOut -- TODO: arrange not to export these , fromNetworkMagic diff --git a/cardano-api/src/Cardano/Api/Shelley.hs b/cardano-api/src/Cardano/Api/Shelley.hs index 6ae36572f7..0be3d3890f 100644 --- a/cardano-api/src/Cardano/Api/Shelley.hs +++ b/cardano-api/src/Cardano/Api/Shelley.hs @@ -120,9 +120,6 @@ module Cardano.Api.Shelley , IntroducedInBabbagePParams (..) , IntroducedInConwayPParams (..) , createEraBasedProtocolParamUpdate - , convertToLedgerProtocolParameters - , ProtocolParameters (..) - , checkProtocolParameters , ProtocolParametersError (..) -- * Scripts diff --git a/cardano-api/test/cardano-api-golden/Test/Golden/Cardano/Api/ProtocolParameters.hs b/cardano-api/test/cardano-api-golden/Test/Golden/Cardano/Api/ProtocolParameters.hs deleted file mode 100644 index b56b6cc7ae..0000000000 --- a/cardano-api/test/cardano-api-golden/Test/Golden/Cardano/Api/ProtocolParameters.hs +++ /dev/null @@ -1,144 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MonoLocalBinds #-} -{-# LANGUAGE NumericUnderscores #-} -{-# LANGUAGE ScopedTypeVariables #-} --- TODO remove me when ProtocolParameters is deleted -{-# OPTIONS_GHC -Wno-deprecations #-} - -module Test.Golden.Cardano.Api.ProtocolParameters - ( test_golden_ProtocolParameters - , test_golden_ProtocolParameters_to_PParams - ) -where - -import Cardano.Api (AnyPlutusScriptVersion (AnyPlutusScriptVersion), CostModel (..), - ExecutionUnits (..), PlutusScriptVersion (..), makePraosNonce) -import Cardano.Api.Ledger (Coin (..), EpochInterval (EpochInterval), StandardCrypto) -import Cardano.Api.ProtocolParameters (ExecutionUnitPrices (..), ProtocolParameters (..)) - -import Cardano.Ledger.Alonzo (AlonzoEra) -import Cardano.Ledger.Alonzo.PParams (AlonzoPParams (..)) -import Cardano.Ledger.Babbage (BabbageEra) -import Cardano.Ledger.Babbage.PParams (BabbagePParams (..)) -import Cardano.Ledger.Plutus.CostModels (costModelParamsCount) -import Cardano.Ledger.Plutus.Language (Language (..)) -import Cardano.Ledger.Shelley (ShelleyEra) -import Cardano.Ledger.Shelley.PParams (ShelleyPParams (..)) - -import Data.Aeson (FromJSON, eitherDecode, encode) -import Data.ByteString.Lazy (ByteString) -import Data.Functor.Identity (Identity) -import Data.Int (Int64) -import Data.Map (Map) -import Data.Proxy (Proxy (..)) -import GHC.Exts (IsList (..)) - -import Hedgehog (Property, property, success) -import qualified Hedgehog.Extras.Aeson as H -import Hedgehog.Internal.Property (failWith) -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.Hedgehog (testProperty) - -test_golden_ProtocolParameters :: TestTree -test_golden_ProtocolParameters = testProperty "golden ProtocolParameters" $ do - H.goldenTestJsonValuePretty - legacyCardanoApiProtocolParameters - "test/cardano-api-golden/files/golden/LegacyProtocolParameters.json" - -test_golden_ProtocolParameters_to_PParams :: TestTree -test_golden_ProtocolParameters_to_PParams = - testGroup - "golden ProtocolParameter tests" - [ testProperty "ShelleyPParams" $ - goldenLegacyProtocolParametersToPParams - (Proxy :: Proxy (ShelleyPParams Identity (ShelleyEra StandardCrypto))) - , testProperty "AlonzoPParams" $ - goldenLegacyProtocolParametersToPParams - (Proxy :: Proxy (AlonzoPParams Identity (AlonzoEra StandardCrypto))) - , testProperty "BabbagePParams" $ - goldenLegacyProtocolParametersToPParams - (Proxy :: Proxy (BabbagePParams Identity (BabbageEra StandardCrypto))) - ] - --- Test that tries decoding the legacy protocol parameters golden file --- 'legacyCardanoApiProtocolParameters' as the type provided as a 'Proxy'. -goldenLegacyProtocolParametersToPParams :: forall pp. FromJSON pp => Proxy pp -> Property -goldenLegacyProtocolParametersToPParams proxy = - property $ case decodedLegacyCardanoApiProtocolParameters of - Left err -> - failWith - Nothing - ( "goldenLegacyProtocolParametersToPParams could not decode golden file as " - <> show proxy - <> ": " - <> show err - ) - Right _ -> success - where - bytestringLegacyCardanoApiProtocolParameters :: ByteString - bytestringLegacyCardanoApiProtocolParameters = encode legacyCardanoApiProtocolParameters - - decodedLegacyCardanoApiProtocolParameters :: Either String pp - decodedLegacyCardanoApiProtocolParameters = eitherDecode bytestringLegacyCardanoApiProtocolParameters - -legacyCardanoApiProtocolParameters :: ProtocolParameters -legacyCardanoApiProtocolParameters = - ProtocolParameters - { protocolParamUTxOCostPerByte = Just $ Coin 1_000_000 - , protocolParamTxFeePerByte = Coin 2_000_000 - , protocolParamTxFeeFixed = Coin 1_500_000 - , protocolParamTreasuryCut = 0.1 - , protocolParamStakePoolTargetNum = 100 - , protocolParamStakePoolDeposit = Coin 1_000_000_000 - , protocolParamStakeAddressDeposit = Coin 10_000_000 - , protocolParamProtocolVersion = (2, 3) - , protocolParamPrices = Just executionUnitPrices - , protocolParamPoolRetireMaxEpoch = Cardano.Api.Ledger.EpochInterval 4 - , protocolParamPoolPledgeInfluence = 0.54 - , protocolParamMonetaryExpansion = 0.23 - , protocolParamMinUTxOValue = Just $ Coin 3_000_000 - , protocolParamMinPoolCost = Coin 3_500_000 - , protocolParamMaxValueSize = Just 10 - , protocolParamMaxTxSize = 3_000 - , protocolParamMaxTxExUnits = Just executionUnits - , protocolParamMaxCollateralInputs = Just 10 - , protocolParamMaxBlockHeaderSize = 1_200 - , protocolParamMaxBlockExUnits = Just executionUnits2 - , protocolParamMaxBlockBodySize = 5_000 - , protocolParamExtraPraosEntropy = Just $ makePraosNonce "entropyEntropy" - , protocolParamDecentralization = Just 0.52 - , protocolParamCostModels = costModels - , protocolParamCollateralPercent = Just 23 - } - where - executionUnitPrices :: ExecutionUnitPrices - executionUnitPrices = - ExecutionUnitPrices - { priceExecutionSteps = 0.3 - , priceExecutionMemory = 0.2 - } - - costModels :: Map AnyPlutusScriptVersion CostModel - costModels = - fromList - [ (AnyPlutusScriptVersion PlutusScriptV3, CostModel [1 .. numParams PlutusV3]) - , (AnyPlutusScriptVersion PlutusScriptV2, CostModel [1 .. numParams PlutusV2]) - , (AnyPlutusScriptVersion PlutusScriptV1, CostModel [1 .. numParams PlutusV1]) - ] - - numParams :: Language -> Int64 - numParams = fromIntegral . costModelParamsCount - - executionUnits :: ExecutionUnits - executionUnits = - ExecutionUnits - { executionSteps = 4_300 - , executionMemory = 2_300 - } - - executionUnits2 :: ExecutionUnits - executionUnits2 = - ExecutionUnits - { executionSteps = 5_600 - , executionMemory = 3_400 - } 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 e8122a77de..00cd77a800 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 @@ -65,12 +65,6 @@ prop_roundtrip_praos_nonce_JSON = H.property $ do pNonce <- forAll $ Gen.just genMaybePraosNonce tripping pNonce encode eitherDecode -prop_roundtrip_protocol_parameters_JSON :: Property -prop_roundtrip_protocol_parameters_JSON = H.property $ do - AnyCardanoEra era <- forAll $ Gen.element [minBound .. maxBound] - pp <- forAll (genProtocolParameters era) - tripping pp encode eitherDecode - tests :: TestTree tests = testGroup @@ -83,5 +77,4 @@ tests = , testProperty "json roundtrip txout utxo context" prop_json_roundtrip_txout_utxo_context , testProperty "json roundtrip scriptdata detailed json" prop_json_roundtrip_scriptdata_detailed_json , testProperty "json roundtrip praos nonce" prop_roundtrip_praos_nonce_JSON - , testProperty "json roundtrip protocol parameters" prop_roundtrip_protocol_parameters_JSON ] diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/ProtocolParameters.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/ProtocolParameters.hs deleted file mode 100644 index 33efb853b3..0000000000 --- a/cardano-api/test/cardano-api-test/Test/Cardano/Api/ProtocolParameters.hs +++ /dev/null @@ -1,220 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} --- TODO remove me when ProtocolParameters is deleted -{-# OPTIONS_GHC -Wno-deprecations #-} - -module Test.Cardano.Api.ProtocolParameters - ( tests - ) -where - -import Cardano.Api (CardanoEra (..), ProtocolParametersConversionError, inEonForEra, - prettyPrintJSON) -import Cardano.Api.Eon.ShelleyBasedEra (ShelleyBasedEra (..), ShelleyLedgerEra) -import Cardano.Api.Ledger (PParams (..)) -import Cardano.Api.ProtocolParameters (LedgerProtocolParameters (..), - convertToLedgerProtocolParameters, fromLedgerPParams) - -import Control.Monad (void) -import Data.Aeson (FromJSON, Object, ToJSON, eitherDecode) -import qualified Data.Aeson.Key as Aeson -import qualified Data.Aeson.KeyMap as Aeson -import qualified Data.ByteString.Lazy as LBS -import Data.Foldable as Foldable (foldl') - -import Test.Gen.Cardano.Api.Typed (genProtocolParameters) - -import Hedgehog (Gen, MonadTest, Property, forAll, property, success, (===)) -import Hedgehog.Extras (leftFail) -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.Hedgehog (testProperty) - --- Originally, cardano-api used a different type than cardano-ledger to represent --- protocol parameters. From conway on, we aim to unify those types and use PParams. --- These tests aim to ensure backwards compatibility between the legacy type ProtocolParams --- and PParams for eras before conway. Conway should use PParams directly, so we don't --- provide any tests for it. -tests :: TestTree -tests = - testGroup - "ProtocolParameter tests" - [ testGroup - "ToJSON instances produce the same" - [ testProperty "ShelleyEra" $ protocolParametersSerializeTheSame ShelleyEra - , testProperty "AlonzoEra" $ protocolParametersSerializeTheSame AlonzoEra - , testProperty "BabbageEra" $ protocolParametersSerializeTheSame BabbageEra - ] - , testGroup - "ProtocolParameters ToJSON can be read by PParams FromJSON" - [ testProperty "ShelleyEra" $ protocolParametersAreCompatible ShelleyEra - , testProperty "AlonzoEra" $ protocolParametersAreCompatible AlonzoEra - , testProperty "BabbageEra" $ protocolParametersAreCompatible BabbageEra - ] - , testGroup - "PParams roundtrip" - [ testProperty "ShelleyEra" $ roundtripBetweenPParamsAndLegacyProtocolParameters ShelleyEra - , testProperty "AlonzoEra" $ roundtripBetweenPParamsAndLegacyProtocolParameters AlonzoEra - , testProperty "BabbageEra" $ roundtripBetweenPParamsAndLegacyProtocolParameters BabbageEra - ] - ] - --- | Compares the JSON serialization of cardano-ledger's PParams and cardano-api's ProtocolParameters and --- | ensures that they are the same (except for the agreed changes specified in `patchProtocolParamsJSONOrFail`) -protocolParametersSerializeTheSame - :: forall era. ToJSON (PParams (ShelleyLedgerEra era)) => CardanoEra era -> Property -protocolParametersSerializeTheSame era = - property $ do - ValidatedSerializedPair - { serializedProtocolParameters - , serializedPParams - } <- - forAll $ genValidSerializedPair era - patchedserializedProtocolParameters <- - patchProtocolParamsJSONOrFail era serializedProtocolParameters - serializedPParams === patchedserializedProtocolParameters - --- | Ensure that cardano-api's legacy ProtocolParameter serialization can be deserialized by cardano-ledger's PParams FromJSON instance -protocolParametersAreCompatible - :: forall era - . ( ToJSON (PParams (ShelleyLedgerEra era)) - , FromJSON (PParams (ShelleyLedgerEra era)) - ) - => CardanoEra era -> Property -protocolParametersAreCompatible era = - property $ do - ValidatedSerializedPair - { serializedProtocolParameters - , serializedPParams = _ - } <- - forAll $ genValidSerializedPair era - void - ( leftFail - (eitherDecode serializedProtocolParameters :: Either String (PParams (ShelleyLedgerEra era))) - ) - success - --- | This tests that, for protocol parameter sets that can roundtrip between PParams and ProtocolParameters --- (i.e. sets of parameters that are valid/work according to the constraints in both PParams and ProtocolParameters --- and their conversion functions), deserializing them using PParams FromJSON instance and then serializing --- again using PParams ToJSON instance results in the same thing. -roundtripBetweenPParamsAndLegacyProtocolParameters - :: forall era - . ( FromJSON (PParams (ShelleyLedgerEra era)) - , ToJSON (PParams (ShelleyLedgerEra era)) - ) - => CardanoEra era -> Property -roundtripBetweenPParamsAndLegacyProtocolParameters era = - property $ do - ValidatedSerializedPair - { serializedProtocolParameters - , serializedPParams = _ - } <- - forAll $ genValidSerializedPair era - patchedserializedProtocolParameters <- - patchProtocolParamsJSONOrFail era serializedProtocolParameters - case eitherDecode serializedProtocolParameters :: Either String (PParams (ShelleyLedgerEra era)) of - Left err -> fail err - Right pParams -> prettyPrintJSON pParams === LBS.toStrict patchedserializedProtocolParameters - -------------------------- --- Auxiliary generator -- -------------------------- - --- | Represents a corresponding pair of serialized protocol parameters in two formats -data ValidatedSerializedPair era = ValidatedSerializedPair - { serializedProtocolParameters :: LBS.ByteString - -- ^ Serialized cardano-api's legacy `ProtocolParameters` as a ByteString. - , serializedPParams :: LBS.ByteString - -- ^ Serialized cardano-ledger's `PParams` as a ByteString. - } - deriving Show - --- | Produces a pair of a valid cardano-api's legacy ProtocolParameters and corresponding cardano-ledger's PParams by doing a round trip -genValidSerializedPair - :: forall era - . ToJSON (PParams (ShelleyLedgerEra era)) => CardanoEra era -> Gen (ValidatedSerializedPair era) -genValidSerializedPair era = do - unrefinedProtocolParameters <- genProtocolParameters era - let mValidatedSerializedPair = - do - unrefinedPParams <- - convertToLedgerProtocolParameters sbe unrefinedProtocolParameters - :: (Either ProtocolParametersConversionError (LedgerProtocolParameters era)) - let refinedProtocolParams = fromLedgerPParams sbe $ unLedgerProtocolParameters unrefinedPParams - refinedPParams <- convertToLedgerProtocolParameters sbe refinedProtocolParams - return $ - ValidatedSerializedPair - { serializedProtocolParameters = LBS.fromStrict $ prettyPrintJSON refinedProtocolParams - , serializedPParams = LBS.fromStrict $ prettyPrintJSON . unLedgerProtocolParameters $ refinedPParams - } - case mValidatedSerializedPair of - Right result -> return result - Left _ -> genValidSerializedPair era - where - sbe :: ShelleyBasedEra era - sbe = toShelleyBased era - - toShelleyBased :: CardanoEra era -> ShelleyBasedEra era - toShelleyBased = inEonForEra (error "Not a Shelley-based era") id - --- Legacy representation of 'ProtocolParameters' in cardano-api is not 100% compatible with --- the 'PParams' representation in cardano-ledger. This functions modifies the JSON object --- produced by the serialization of 'ProtocolParameters' type to match 'PParams' serialization --- format. -patchProtocolParamsJSONOrFail - :: (MonadTest m, MonadFail m) => CardanoEra era -> LBS.ByteString -> m LBS.ByteString -patchProtocolParamsJSONOrFail era s = - LBS.fromStrict . prettyPrintJSON - <$> ( patchProtocolParamRepresentation - =<< leftFail (eitherDecode s) - ) - where - -- We are renaming two of the fields to match the spec. Based on discussion here: - -- https://github.com/IntersectMBO/cardano-ledger/pull/4129#discussion_r1507373498 - patchProtocolParamRepresentation :: MonadFail m => Object -> m Object - patchProtocolParamRepresentation o = do - filters <- filtersForEra era - renameKey "committeeTermLength" "committeeMaxTermLength" - =<< renameKey - "minCommitteeSize" - "committeeMinSize" - (applyFilters filters o) - - -- Legacy ProtocolParams ToJSON renders all fields from all eras in all eras, - -- because it is the same data type for every era. But this is not backwards compatible - -- because it means that new eras can modify the fields in old eras. For this reason, when - -- comparing to PParams we use this function to filter fields that don't belong to - -- particular era we are testing. - filtersForEra :: MonadFail m => CardanoEra era -> m [String] - filtersForEra ShelleyEra = - return - [ "collateralPercentage" - , "costModels" - , "executionUnitPrices" - , "maxBlockExecutionUnits" - , "maxCollateralInputs" - , "maxTxExecutionUnits" - , "maxValueSize" - , "utxoCostPerByte" - ] - filtersForEra AlonzoEra = return ["minUTxOValue"] - filtersForEra BabbageEra = return ["decentralization", "extraPraosEntropy", "minUTxOValue"] - filtersForEra era' = fail $ "filtersForEra is not defined for: " <> show era' - - applyFilters :: [String] -> Object -> Object - applyFilters filters o = Foldable.foldl' (flip Aeson.delete) o (map Aeson.fromString filters) - - -- Renames the key of an entry in a JSON object. - -- If there already is a key with the new name in the object the function fails. - renameKey :: MonadFail m => String -> String -> Object -> m Object - renameKey src dest o = - let srcKey = Aeson.fromString src - destKey = Aeson.fromString dest - in case Aeson.lookup srcKey o of - Nothing -> return o - Just v -> - if Aeson.member destKey o - then fail $ "renameKey failed because there is already an entry with the new name: " <> dest - else return $ Aeson.insert destKey v $ Aeson.delete srcKey o diff --git a/cardano-api/test/cardano-api-test/cardano-api-test.hs b/cardano-api/test/cardano-api-test/cardano-api-test.hs index 3b977fb1c0..6df15aaf96 100644 --- a/cardano-api/test/cardano-api-test/cardano-api-test.hs +++ b/cardano-api/test/cardano-api-test/cardano-api-test.hs @@ -20,7 +20,6 @@ import qualified Test.Cardano.Api.KeysByron import qualified Test.Cardano.Api.Ledger import qualified Test.Cardano.Api.Metadata import qualified Test.Cardano.Api.Ord -import qualified Test.Cardano.Api.ProtocolParameters import qualified Test.Cardano.Api.RawBytes import qualified Test.Cardano.Api.Transaction.Autobalance import qualified Test.Cardano.Api.TxBody @@ -55,7 +54,6 @@ tests = , Test.Cardano.Api.Ledger.tests , Test.Cardano.Api.Metadata.tests , Test.Cardano.Api.Ord.tests - , Test.Cardano.Api.ProtocolParameters.tests , Test.Cardano.Api.RawBytes.tests , Test.Cardano.Api.Transaction.Autobalance.tests , Test.Cardano.Api.TxBody.tests