From 7b200160ca59b230cf08bfc1b2a88c2e7e7a7c2c Mon Sep 17 00:00:00 2001 From: Aniket Deshpande Date: Wed, 28 Jun 2023 14:36:56 +0530 Subject: [PATCH] Add PParams for Conway --- eras/babbage/impl/CHANGELOG.md | 4 +- .../babbage/impl/cardano-ledger-babbage.cabal | 2 +- .../src/Cardano/Ledger/Babbage/PParams.hs | 2 +- eras/conway/impl/CHANGELOG.md | 5 + eras/conway/impl/cardano-ledger-conway.cabal | 2 +- .../impl/src/Cardano/Ledger/Conway/Core.hs | 165 +++++ .../src/Cardano/Ledger/Conway/Governance.hs | 4 +- .../impl/src/Cardano/Ledger/Conway/PParams.hs | 628 +++++++++++++++++- .../src/Cardano/Ledger/Conway/Translation.hs | 9 +- .../Test/Cardano/Ledger/Conway/Arbitrary.hs | 93 +++ eras/conway/test-suite/cddl-files/conway.cddl | 72 +- .../Ledger/Conway/Serialisation/Roundtrip.hs | 13 +- 12 files changed, 929 insertions(+), 70 deletions(-) diff --git a/eras/babbage/impl/CHANGELOG.md b/eras/babbage/impl/CHANGELOG.md index 1be7c81cb70..5dc7114674b 100644 --- a/eras/babbage/impl/CHANGELOG.md +++ b/eras/babbage/impl/CHANGELOG.md @@ -1,8 +1,8 @@ # Version history for `cardano-ledger-babbage` -## 1.4.0.1 +## 1.4.1.0 -* +* Added `babbagePParamsHKDPairs` ## 1.4.0.0 diff --git a/eras/babbage/impl/cardano-ledger-babbage.cabal b/eras/babbage/impl/cardano-ledger-babbage.cabal index bcd6c461e0f..7fdc98936ff 100644 --- a/eras/babbage/impl/cardano-ledger-babbage.cabal +++ b/eras/babbage/impl/cardano-ledger-babbage.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: cardano-ledger-babbage -version: 1.4.0.2 +version: 1.4.1.0 license: Apache-2.0 maintainer: operations@iohk.io author: IOHK diff --git a/eras/babbage/impl/src/Cardano/Ledger/Babbage/PParams.hs b/eras/babbage/impl/src/Cardano/Ledger/Babbage/PParams.hs index 2bde22650fb..f84f1459e9b 100644 --- a/eras/babbage/impl/src/Cardano/Ledger/Babbage/PParams.hs +++ b/eras/babbage/impl/src/Cardano/Ledger/Babbage/PParams.hs @@ -27,6 +27,7 @@ module Cardano.Ledger.Babbage.PParams ( encodeLangViews, coinsPerUTxOWordToCoinsPerUTxOByte, coinsPerUTxOByteToCoinsPerUTxOWord, + babbagePParamsHKDPairs, ) where @@ -233,7 +234,6 @@ instance Crypto c => BabbageEraPParams (BabbageEra c) where instance Crypto c => EraGovernance (BabbageEra c) where type GovernanceState (BabbageEra c) = ShelleyPPUPState (BabbageEra c) emptyGovernanceState = ShelleyPPUPState emptyPPPUpdates emptyPPPUpdates - getProposedPPUpdates = Just . proposals instance Era era => EncCBOR (BabbagePParams Identity era) where diff --git a/eras/conway/impl/CHANGELOG.md b/eras/conway/impl/CHANGELOG.md index 85afd0fb589..05d866afebd 100644 --- a/eras/conway/impl/CHANGELOG.md +++ b/eras/conway/impl/CHANGELOG.md @@ -20,6 +20,11 @@ ## 1.6.0.0 * Removal of `GovernanceProcedure` in favor of `GovernanceProcedures` +* Add `ConwayPParams` #3498 +* Add `UpgradeConwayPParams` #3498 +* Add `ConwayEraPParams` #3498 +* Add `PoolVotingThresholds` #3498 +* Add `DRepVotingThresholds` #3498 ## 1.5.0.0 diff --git a/eras/conway/impl/cardano-ledger-conway.cabal b/eras/conway/impl/cardano-ledger-conway.cabal index 1772483b94b..282939fd6e9 100644 --- a/eras/conway/impl/cardano-ledger-conway.cabal +++ b/eras/conway/impl/cardano-ledger-conway.cabal @@ -69,7 +69,7 @@ library cardano-ledger-binary >=1.1, cardano-ledger-allegra >=1.1, cardano-ledger-alonzo ^>=1.4, - cardano-ledger-babbage >=1.1, + cardano-ledger-babbage >=1.4.1, cardano-ledger-core >=1.4 && <1.6, cardano-ledger-mary >=1.1, cardano-ledger-shelley ^>=1.4.1, diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Core.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Core.hs index 49febfb0bf6..2820ec7826c 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Core.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Core.hs @@ -1,21 +1,186 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableSuperClasses #-} module Cardano.Ledger.Conway.Core ( module X, ConwayEraTxBody (..), + ConwayEraPParams (..), + ppPoolVotingThresholdsL, + ppDRepVotingThresholdsL, + ppMinCommitteeSizeL, + ppCommitteeTermLimitL, + ppGovActionExpirationL, + ppGovActionDepositL, + ppDRepDepositL, + ppDRepActivityL, + ppuPoolVotingThresholdsL, + ppuDRepVotingThresholdsL, + ppuMinCommitteeSizeL, + ppuCommitteeTermLimitL, + ppuGovActionExpirationL, + ppuGovActionDepositL, + ppuDRepDepositL, + ppuDRepActivityL, + PoolVotingThresholds (..), + DRepVotingThresholds (..), ) where import Cardano.Ledger.Babbage.Core as X +import Cardano.Ledger.BaseTypes (EpochNo, StrictMaybe, UnitInterval) +import Cardano.Ledger.Binary (DecCBOR, EncCBOR, decodeRecordNamed, encodeListLen) +import Cardano.Ledger.Binary.Decoding (DecCBOR (decCBOR)) +import Cardano.Ledger.Binary.Encoding (EncCBOR (encCBOR)) +import Cardano.Ledger.Coin (Coin) import Cardano.Ledger.Conway.Governance (ProposalProcedure, VotingProcedure) +import Cardano.Ledger.HKD (HKD, HKDFunctor) +import Control.DeepSeq (NFData) +import Data.Aeson (ToJSON) +import Data.Default.Class (Default) +import Data.Functor.Identity (Identity) import Data.Sequence.Strict (StrictSeq) +import GHC.Generics (Generic) import Lens.Micro (Lens') +import NoThunks.Class (NoThunks) +import Numeric.Natural (Natural) class BabbageEraTxBody era => ConwayEraTxBody era where votingProceduresTxBodyL :: Lens' (TxBody era) (StrictSeq (VotingProcedure era)) proposalProceduresTxBodyL :: Lens' (TxBody era) (StrictSeq (ProposalProcedure era)) + +class BabbageEraPParams era => ConwayEraPParams era where + hkdPoolVotingThresholdsL :: HKDFunctor f => Lens' (PParamsHKD f era) (HKD f PoolVotingThresholds) + hkdDRepVotingThresholdsL :: HKDFunctor f => Lens' (PParamsHKD f era) (HKD f DRepVotingThresholds) + hkdMinCommitteeSizeL :: HKDFunctor f => Lens' (PParamsHKD f era) (HKD f Natural) + hkdCommitteeTermLimitL :: HKDFunctor f => Lens' (PParamsHKD f era) (HKD f Natural) + hkdGovActionExpirationL :: HKDFunctor f => Lens' (PParamsHKD f era) (HKD f Natural) + hkdGovActionDepositL :: HKDFunctor f => Lens' (PParamsHKD f era) (HKD f Coin) + hkdDRepDepositL :: HKDFunctor f => Lens' (PParamsHKD f era) (HKD f Coin) + hkdDRepActivityL :: HKDFunctor f => Lens' (PParamsHKD f era) (HKD f EpochNo) + +ppPoolVotingThresholdsL :: forall era. ConwayEraPParams era => Lens' (PParams era) PoolVotingThresholds +ppPoolVotingThresholdsL = ppLens . hkdPoolVotingThresholdsL @era @Identity + +ppDRepVotingThresholdsL :: forall era. ConwayEraPParams era => Lens' (PParams era) DRepVotingThresholds +ppDRepVotingThresholdsL = ppLens . hkdDRepVotingThresholdsL @era @Identity + +ppMinCommitteeSizeL :: forall era. ConwayEraPParams era => Lens' (PParams era) Natural +ppMinCommitteeSizeL = ppLens . hkdMinCommitteeSizeL @era @Identity + +ppCommitteeTermLimitL :: forall era. ConwayEraPParams era => Lens' (PParams era) Natural +ppCommitteeTermLimitL = ppLens . hkdCommitteeTermLimitL @era @Identity + +ppGovActionExpirationL :: forall era. ConwayEraPParams era => Lens' (PParams era) Natural +ppGovActionExpirationL = ppLens . hkdGovActionExpirationL @era @Identity + +ppGovActionDepositL :: forall era. ConwayEraPParams era => Lens' (PParams era) Coin +ppGovActionDepositL = ppLens . hkdGovActionDepositL @era @Identity + +ppDRepDepositL :: forall era. ConwayEraPParams era => Lens' (PParams era) Coin +ppDRepDepositL = ppLens . hkdDRepDepositL @era @Identity + +ppDRepActivityL :: forall era. ConwayEraPParams era => Lens' (PParams era) EpochNo +ppDRepActivityL = ppLens . hkdDRepActivityL @era @Identity + +ppuPoolVotingThresholdsL :: forall era. ConwayEraPParams era => Lens' (PParamsUpdate era) (StrictMaybe PoolVotingThresholds) +ppuPoolVotingThresholdsL = ppuLens . hkdPoolVotingThresholdsL @era @StrictMaybe + +ppuDRepVotingThresholdsL :: forall era. ConwayEraPParams era => Lens' (PParamsUpdate era) (StrictMaybe DRepVotingThresholds) +ppuDRepVotingThresholdsL = ppuLens . hkdDRepVotingThresholdsL @era @StrictMaybe + +ppuMinCommitteeSizeL :: forall era. ConwayEraPParams era => Lens' (PParamsUpdate era) (StrictMaybe Natural) +ppuMinCommitteeSizeL = ppuLens . hkdMinCommitteeSizeL @era @StrictMaybe + +ppuCommitteeTermLimitL :: forall era. ConwayEraPParams era => Lens' (PParamsUpdate era) (StrictMaybe Natural) +ppuCommitteeTermLimitL = ppuLens . hkdCommitteeTermLimitL @era @StrictMaybe + +ppuGovActionExpirationL :: forall era. ConwayEraPParams era => Lens' (PParamsUpdate era) (StrictMaybe Natural) +ppuGovActionExpirationL = ppuLens . hkdGovActionExpirationL @era @StrictMaybe + +ppuGovActionDepositL :: forall era. ConwayEraPParams era => Lens' (PParamsUpdate era) (StrictMaybe Coin) +ppuGovActionDepositL = ppuLens . hkdGovActionDepositL @era @StrictMaybe + +ppuDRepDepositL :: forall era. ConwayEraPParams era => Lens' (PParamsUpdate era) (StrictMaybe Coin) +ppuDRepDepositL = ppuLens . hkdDRepDepositL @era @StrictMaybe + +ppuDRepActivityL :: forall era. ConwayEraPParams era => Lens' (PParamsUpdate era) (StrictMaybe EpochNo) +ppuDRepActivityL = ppuLens . hkdDRepActivityL @era @StrictMaybe + +data PoolVotingThresholds = PoolVotingThresholds + { pvtMotionNoConfidence :: !UnitInterval + , pvtCommitteeNormal :: !UnitInterval + , pvtCommitteeNoConfidence :: !UnitInterval + , pvtHardForkInitiation :: !UnitInterval + } + deriving (Eq, Ord, Show, Generic, Default, ToJSON, NFData, NoThunks) + +instance EncCBOR PoolVotingThresholds where + encCBOR PoolVotingThresholds {..} = + encodeListLen 4 + <> encCBOR pvtMotionNoConfidence + <> encCBOR pvtCommitteeNormal + <> encCBOR pvtCommitteeNoConfidence + <> encCBOR pvtHardForkInitiation + +instance DecCBOR PoolVotingThresholds where + decCBOR = + decodeRecordNamed "PoolVotingThresholds" (const 4) $ do + pvtMotionNoConfidence <- decCBOR + pvtCommitteeNormal <- decCBOR + pvtCommitteeNoConfidence <- decCBOR + pvtHardForkInitiation <- decCBOR + pure $ PoolVotingThresholds {..} + +data DRepVotingThresholds = DRepVotingThresholds + { dvtMotionNoConfidence :: !UnitInterval + , dvtCommitteeNormal :: !UnitInterval + , dvtCommitteeNoConfidence :: !UnitInterval + , dvtUpdateToConstitution :: !UnitInterval + , dvtHardForkInitiation :: !UnitInterval + , dvtPPNetworkGroup :: !UnitInterval + , dvtPPEconomicGroup :: !UnitInterval + , dvtPPTechnicalGroup :: !UnitInterval + , dvtPPGovernanceGroup :: !UnitInterval + , dvtTreasuryWithdrawal :: !UnitInterval + } + deriving (Eq, Ord, Show, Generic, Default, ToJSON, NFData, NoThunks) + +instance EncCBOR DRepVotingThresholds where + encCBOR DRepVotingThresholds {..} = + encodeListLen 10 + <> encCBOR dvtMotionNoConfidence + <> encCBOR dvtCommitteeNormal + <> encCBOR dvtCommitteeNoConfidence + <> encCBOR dvtUpdateToConstitution + <> encCBOR dvtHardForkInitiation + <> encCBOR dvtPPNetworkGroup + <> encCBOR dvtPPEconomicGroup + <> encCBOR dvtPPTechnicalGroup + <> encCBOR dvtPPGovernanceGroup + <> encCBOR dvtTreasuryWithdrawal + +instance DecCBOR DRepVotingThresholds where + decCBOR = + decodeRecordNamed "DRepVotingThresholds" (const 10) $ do + dvtMotionNoConfidence <- decCBOR + dvtCommitteeNormal <- decCBOR + dvtCommitteeNoConfidence <- decCBOR + dvtUpdateToConstitution <- decCBOR + dvtHardForkInitiation <- decCBOR + dvtPPNetworkGroup <- decCBOR + dvtPPEconomicGroup <- decCBOR + dvtPPTechnicalGroup <- decCBOR + dvtPPGovernanceGroup <- decCBOR + dvtTreasuryWithdrawal <- decCBOR + pure $ DRepVotingThresholds {..} diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Governance.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Governance.hs index 7ee7e864d99..678744474a6 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Governance.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Governance.hs @@ -70,10 +70,8 @@ import Cardano.Ledger.Conway.Governance.Procedures ( VotingProcedure (..), govActionIdToText, ) -import Cardano.Ledger.Conway.PParams () import Cardano.Ledger.Core import Cardano.Ledger.Credential (Credential (..)) -import Cardano.Ledger.Crypto (Crypto) import Cardano.Ledger.Keys (KeyHash (..), KeyRole (..)) import Cardano.Ledger.SafeHash (SafeHash) import Cardano.Ledger.Shelley.Governance @@ -344,6 +342,6 @@ toConwayGovernancePairs cg@(ConwayGovernance _ _) = , "ratify" .= cgRatify ] -instance Crypto c => EraGovernance (ConwayEra c) where +instance EraPParams (ConwayEra c) => EraGovernance (ConwayEra c) where type GovernanceState (ConwayEra c) = ConwayGovernance (ConwayEra c) getConstitutionHash g = Just $ g ^. cgRatifyL . rsEnactStateL . ensConstitutionL diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/PParams.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/PParams.hs index b73e12ced97..7758bafe6a2 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/PParams.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/PParams.hs @@ -1,62 +1,241 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} -- | This module contains the type of protocol parameters and EraPParams instance module Cardano.Ledger.Conway.PParams ( BabbagePParams (..), + ConwayPParams (..), getLanguageView, LangDepView (..), encodeLangViews, + upgradeConwayPParams, + UpgradeConwayPParams (..), + PoolVotingThresholds (..), + DRepVotingThresholds (..), ) where import Cardano.Ledger.Alonzo.PParams (OrdExUnits (..)) -import Cardano.Ledger.Alonzo.Scripts (ExUnits (..)) -import Cardano.Ledger.Babbage.Core +import Cardano.Ledger.Alonzo.Scripts (CostModels, ExUnits (..), Prices (Prices), emptyCostModels) +import Cardano.Ledger.Babbage (BabbageEra) +import Cardano.Ledger.Babbage.Core hiding (Value) import Cardano.Ledger.Babbage.PParams +import Cardano.Ledger.BaseTypes (EpochNo (EpochNo), NonNegativeInterval, ProtVer (ProtVer), UnitInterval) +import Cardano.Ledger.Binary +import Cardano.Ledger.Binary.Coders +import Cardano.Ledger.Coin (Coin (Coin)) +import Cardano.Ledger.Conway.Core hiding (Value) import Cardano.Ledger.Conway.Era (ConwayEra) import Cardano.Ledger.Crypto import Cardano.Ledger.HKD (HKD, HKDFunctor (..)) -import Data.Coerce +import Control.DeepSeq (NFData) +import Data.Aeson hiding (Encoding, decode, encode) +import Data.Default.Class (Default (def)) +import Data.Functor.Identity (Identity) +import Data.Maybe.Strict (StrictMaybe (..), isSNothing) import Data.Proxy +import GHC.Generics (Generic) import Lens.Micro +import NoThunks.Class (NoThunks) +import Numeric.Natural (Natural) + +-- | Conway Protocol parameters. The following parameters have been added since Babbage: +-- * @poolVotingThresholds@ +-- * @dRepVotingThresholds@ +-- * @minCommitteeSize@ +-- * @committeeTermLimit@ +-- * @govActionExpiration@ +-- * @govActionDeposit@ +-- * @dRepDeposit@ +-- * @dRepActivity@ +data ConwayPParams f era = ConwayPParams + { cppMinFeeA :: !(HKD f Coin) + -- ^ The linear factor for the minimum fee calculation + , cppMinFeeB :: !(HKD f Coin) + -- ^ The constant factor for the minimum fee calculation + , cppMaxBBSize :: !(HKD f Natural) + -- ^ Maximal block body size + , cppMaxTxSize :: !(HKD f Natural) + -- ^ Maximal transaction size + , cppMaxBHSize :: !(HKD f Natural) + -- ^ Maximal block header size + , cppKeyDeposit :: !(HKD f Coin) + -- ^ The amount of a key registration deposit + , cppPoolDeposit :: !(HKD f Coin) + -- ^ The amount of a pool registration deposit + , cppEMax :: !(HKD f EpochNo) + -- ^ Maximum number of epochs in the future a pool retirement is allowed to + -- be scheduled for. + , cppNOpt :: !(HKD f Natural) + -- ^ Desired number of pools + , cppA0 :: !(HKD f NonNegativeInterval) + -- ^ Pool influence + , cppRho :: !(HKD f UnitInterval) + -- ^ Monetary expansion + , cppTau :: !(HKD f UnitInterval) + -- ^ Treasury expansion + , cppProtocolVersion :: !(HKD f ProtVer) + -- ^ Protocol version + , cppMinPoolCost :: !(HKD f Coin) + -- ^ Minimum Stake Pool Cost + , cppCoinsPerUTxOByte :: !(HKD f CoinPerByte) + -- ^ Cost in lovelace per byte of UTxO storage + , cppCostModels :: !(HKD f CostModels) + -- ^ Cost models for non-native script languages + , cppPrices :: !(HKD f Prices) + -- ^ Prices of execution units (for non-native script languages) + , cppMaxTxExUnits :: !(HKD f OrdExUnits) + -- ^ Max total script execution resources units allowed per tx + , cppMaxBlockExUnits :: !(HKD f OrdExUnits) + -- ^ Max total script execution resources units allowed per block + , cppMaxValSize :: !(HKD f Natural) + -- ^ Max size of a Value in an output + , cppCollateralPercentage :: !(HKD f Natural) + -- ^ Percentage of the txfee which must be provided as collateral when + -- including non-native scripts. + , cppMaxCollateralInputs :: !(HKD f Natural) + -- ^ Maximum number of collateral inputs allowed in a transaction + -- + -- New ones for Conway + , cppPoolVotingThresholds :: !(HKD f PoolVotingThresholds) + -- ^ Thresholds for SPO votes + , cppDRepVotingThresholds :: !(HKD f DRepVotingThresholds) + -- ^ Thresholds for DRep votes + , cppMinCommitteeSize :: !(HKD f Natural) + -- ^ Minimum size of the Constitutional Committee + , cppCommitteeTermLimit :: !(HKD f Natural) + -- ^ The Constitutional Committee Term limit in number of Slots + , cppGovActionExpiration :: !(HKD f Natural) + -- ^ Governance action expiration in number of Slots + , cppGovActionDeposit :: !(HKD f Coin) + -- ^ The amount of the Governance Action deposit + , cppDRepDeposit :: !(HKD f Coin) + -- ^ The amount of a DRep registration deposit + , cppDRepActivity :: !(HKD f EpochNo) + -- ^ The number of Epochs that a DRep can perform no activity without losing their @Active@ status. + } + deriving (Generic) + +deriving instance Eq (ConwayPParams Identity era) + +deriving instance Ord (ConwayPParams Identity era) + +deriving instance Show (ConwayPParams Identity era) + +instance NoThunks (ConwayPParams Identity era) + +instance NFData (ConwayPParams Identity era) + +deriving instance Eq (ConwayPParams StrictMaybe era) + +deriving instance Ord (ConwayPParams StrictMaybe era) + +deriving instance Show (ConwayPParams StrictMaybe era) + +instance NoThunks (ConwayPParams StrictMaybe era) + +instance NFData (ConwayPParams StrictMaybe era) + +data UpgradeConwayPParams f = UpgradeConwayPParams + { ucppPoolVotingThresholds :: !(HKD f PoolVotingThresholds) + , ucppDRepVotingThresholds :: !(HKD f DRepVotingThresholds) + , ucppMinCommitteeSize :: !(HKD f Natural) + , ucppCommitteeTermLimit :: !(HKD f Natural) + , ucppGovActionExpiration :: !(HKD f Natural) + , ucppGovActionDeposit :: !(HKD f Coin) + , ucppDRepDeposit :: !(HKD f Coin) + , ucppDRepActivity :: !(HKD f EpochNo) + } + deriving (Generic) + +deriving instance Eq (UpgradeConwayPParams Identity) + +deriving instance Ord (UpgradeConwayPParams Identity) + +deriving instance Show (UpgradeConwayPParams Identity) + +instance NoThunks (UpgradeConwayPParams Identity) + +instance NFData (UpgradeConwayPParams Identity) + +deriving instance Eq (UpgradeConwayPParams StrictMaybe) + +deriving instance Ord (UpgradeConwayPParams StrictMaybe) + +deriving instance Show (UpgradeConwayPParams StrictMaybe) + +instance NoThunks (UpgradeConwayPParams StrictMaybe) + +instance NFData (UpgradeConwayPParams StrictMaybe) + +instance Default (UpgradeConwayPParams Identity) where + def = + UpgradeConwayPParams + { ucppPoolVotingThresholds = def + , ucppDRepVotingThresholds = def + , ucppMinCommitteeSize = 0 + , ucppCommitteeTermLimit = 0 + , ucppGovActionExpiration = 0 + , ucppGovActionDeposit = Coin 0 + , ucppDRepDeposit = Coin 0 + , ucppDRepActivity = EpochNo 0 + } + +instance Default (UpgradeConwayPParams StrictMaybe) where + def = + UpgradeConwayPParams + { ucppPoolVotingThresholds = SNothing + , ucppDRepVotingThresholds = SNothing + , ucppMinCommitteeSize = SNothing + , ucppCommitteeTermLimit = SNothing + , ucppGovActionExpiration = SNothing + , ucppGovActionDeposit = SNothing + , ucppDRepDeposit = SNothing + , ucppDRepActivity = SNothing + } instance Crypto c => EraPParams (ConwayEra c) where - type PParamsHKD f (ConwayEra c) = BabbagePParams f (ConwayEra c) - type UpgradePParams f (ConwayEra c) = () + type PParamsHKD f (ConwayEra c) = ConwayPParams f (ConwayEra c) + type UpgradePParams f (ConwayEra c) = UpgradeConwayPParams f type DowngradePParams f (ConwayEra c) = () - emptyPParamsIdentity = emptyBabbagePParams - emptyPParamsStrictMaybe = emptyBabbagePParamsUpdate - - upgradePParamsHKD () = coerce - downgradePParamsHKD () = coerce - - hkdMinFeeAL = lens bppMinFeeA $ \pp x -> pp {bppMinFeeA = x} - hkdMinFeeBL = lens bppMinFeeB $ \pp x -> pp {bppMinFeeB = x} - hkdMaxBBSizeL = lens bppMaxBBSize $ \pp x -> pp {bppMaxBBSize = x} - hkdMaxTxSizeL = lens bppMaxTxSize $ \pp x -> pp {bppMaxTxSize = x} - hkdMaxBHSizeL = lens bppMaxBHSize $ \pp x -> pp {bppMaxBHSize = x} - hkdKeyDepositL = lens bppKeyDeposit $ \pp x -> pp {bppKeyDeposit = x} - hkdPoolDepositL = lens bppPoolDeposit $ \pp x -> pp {bppPoolDeposit = x} - hkdEMaxL = lens bppEMax $ \pp x -> pp {bppEMax = x} - hkdNOptL = lens bppNOpt $ \pp x -> pp {bppNOpt = x} - hkdA0L = lens bppA0 $ \pp x -> pp {bppA0 = x} - hkdRhoL = lens bppRho $ \pp x -> pp {bppRho = x} - hkdTauL = lens bppTau $ \pp x -> pp {bppTau = x} - hkdProtocolVersionL = lens bppProtocolVersion $ \pp x -> pp {bppProtocolVersion = x} - hkdMinPoolCostL = lens bppMinPoolCost $ \pp x -> pp {bppMinPoolCost = x} + emptyPParamsIdentity = emptyConwayPParams + emptyPParamsStrictMaybe = emptyConwayPParamsUpdate + + upgradePParamsHKD = upgradeConwayPParams + downgradePParamsHKD () = downgradeConwayPParams + + hkdMinFeeAL = lens cppMinFeeA $ \pp x -> pp {cppMinFeeA = x} + hkdMinFeeBL = lens cppMinFeeB $ \pp x -> pp {cppMinFeeB = x} + hkdMaxBBSizeL = lens cppMaxBBSize $ \pp x -> pp {cppMaxBBSize = x} + hkdMaxTxSizeL = lens cppMaxTxSize $ \pp x -> pp {cppMaxTxSize = x} + hkdMaxBHSizeL = lens cppMaxBHSize $ \pp x -> pp {cppMaxBHSize = x} + hkdKeyDepositL = lens cppKeyDeposit $ \pp x -> pp {cppKeyDeposit = x} + hkdPoolDepositL = lens cppPoolDeposit $ \pp x -> pp {cppPoolDeposit = x} + hkdEMaxL = lens cppEMax $ \pp x -> pp {cppEMax = x} + hkdNOptL = lens cppNOpt $ \pp x -> pp {cppNOpt = x} + hkdA0L = lens cppA0 $ \pp x -> pp {cppA0 = x} + hkdRhoL = lens cppRho $ \pp x -> pp {cppRho = x} + hkdTauL = lens cppTau $ \pp x -> pp {cppTau = x} + hkdProtocolVersionL = lens cppProtocolVersion $ \pp x -> pp {cppProtocolVersion = x} + hkdMinPoolCostL = lens cppMinPoolCost $ \pp x -> pp {cppMinPoolCost = x} ppDG = to (const minBound) hkdDL = notSupportedInThisEraL @@ -65,21 +244,400 @@ instance Crypto c => EraPParams (ConwayEra c) where instance Crypto c => AlonzoEraPParams (ConwayEra c) where hkdCoinsPerUTxOWordL = notSupportedInThisEraL - hkdCostModelsL = lens bppCostModels $ \pp x -> pp {bppCostModels = x} - hkdPricesL = lens bppPrices $ \pp x -> pp {bppPrices = x} + hkdCostModelsL = lens cppCostModels $ \pp x -> pp {cppCostModels = x} + hkdPricesL = lens cppPrices $ \pp x -> pp {cppPrices = x} hkdMaxTxExUnitsL :: forall f. HKDFunctor f => Lens' (PParamsHKD f (ConwayEra c)) (HKD f ExUnits) hkdMaxTxExUnitsL = - lens (hkdMap (Proxy @f) unOrdExUnits . bppMaxTxExUnits) $ \pp x -> - pp {bppMaxTxExUnits = hkdMap (Proxy @f) OrdExUnits x} + lens (hkdMap (Proxy @f) unOrdExUnits . cppMaxTxExUnits) $ \pp x -> + pp {cppMaxTxExUnits = hkdMap (Proxy @f) OrdExUnits x} hkdMaxBlockExUnitsL :: forall f. HKDFunctor f => Lens' (PParamsHKD f (ConwayEra c)) (HKD f ExUnits) hkdMaxBlockExUnitsL = - lens (hkdMap (Proxy @f) unOrdExUnits . bppMaxBlockExUnits) $ \pp x -> - pp {bppMaxBlockExUnits = hkdMap (Proxy @f) OrdExUnits x} - hkdMaxValSizeL = lens bppMaxValSize $ \pp x -> pp {bppMaxValSize = x} + lens (hkdMap (Proxy @f) unOrdExUnits . cppMaxBlockExUnits) $ \pp x -> + pp {cppMaxBlockExUnits = hkdMap (Proxy @f) OrdExUnits x} + hkdMaxValSizeL = lens cppMaxValSize $ \pp x -> pp {cppMaxValSize = x} hkdCollateralPercentageL = - lens bppCollateralPercentage $ \pp x -> pp {bppCollateralPercentage = x} + lens cppCollateralPercentage $ \pp x -> pp {cppCollateralPercentage = x} hkdMaxCollateralInputsL = - lens bppMaxCollateralInputs $ \pp x -> pp {bppMaxCollateralInputs = x} + lens cppMaxCollateralInputs $ \pp x -> pp {cppMaxCollateralInputs = x} instance Crypto c => BabbageEraPParams (ConwayEra c) where - hkdCoinsPerUTxOByteL = lens bppCoinsPerUTxOByte (\pp x -> pp {bppCoinsPerUTxOByte = x}) + hkdCoinsPerUTxOByteL = lens cppCoinsPerUTxOByte (\pp x -> pp {cppCoinsPerUTxOByte = x}) + +instance Crypto c => ConwayEraPParams (ConwayEra c) where + hkdPoolVotingThresholdsL = lens cppPoolVotingThresholds (\pp x -> pp {cppPoolVotingThresholds = x}) + hkdDRepVotingThresholdsL = lens cppDRepVotingThresholds (\pp x -> pp {cppDRepVotingThresholds = x}) + hkdMinCommitteeSizeL = lens cppMinCommitteeSize (\pp x -> pp {cppMinCommitteeSize = x}) + hkdCommitteeTermLimitL = lens cppCommitteeTermLimit (\pp x -> pp {cppCommitteeTermLimit = x}) + hkdGovActionExpirationL = lens cppGovActionExpiration (\pp x -> pp {cppGovActionExpiration = x}) + hkdGovActionDepositL = lens cppGovActionDeposit (\pp x -> pp {cppGovActionDeposit = x}) + hkdDRepDepositL = lens cppDRepDeposit (\pp x -> pp {cppDRepDeposit = x}) + hkdDRepActivityL = lens cppDRepActivity (\pp x -> pp {cppDRepActivity = x}) + +instance Era era => EncCBOR (ConwayPParams Identity era) where + encCBOR ConwayPParams {..} = + encode $ + Rec (ConwayPParams @Identity) + !> To cppMinFeeA + !> To cppMinFeeB + !> To cppMaxBBSize + !> To cppMaxTxSize + !> To cppMaxBHSize + !> To cppKeyDeposit + !> To cppPoolDeposit + !> To cppEMax + !> To cppNOpt + !> To cppA0 + !> To cppRho + !> To cppTau + !> To cppProtocolVersion + !> To cppMinPoolCost + !> To cppCoinsPerUTxOByte + !> To cppCostModels + !> To cppPrices + !> To cppMaxTxExUnits + !> To cppMaxBlockExUnits + !> To cppMaxValSize + !> To cppCollateralPercentage + !> To cppMaxCollateralInputs + -- New for Conway + !> To cppPoolVotingThresholds + !> To cppDRepVotingThresholds + !> To cppMinCommitteeSize + !> To cppCommitteeTermLimit + !> To cppGovActionExpiration + !> To cppGovActionDeposit + !> To cppDRepDeposit + !> To cppDRepActivity + +instance Era era => ToCBOR (ConwayPParams Identity era) where + toCBOR = toEraCBOR @era + +instance Era era => DecCBOR (ConwayPParams Identity era) where + decCBOR = + decode $ + RecD (ConwayPParams @Identity) + FromCBOR (ConwayPParams Identity era) where + fromCBOR = fromEraCBOR @era + +instance Crypto c => ToJSON (ConwayPParams Identity (ConwayEra c)) where + toJSON = object . conwayPParamsPairs + toEncoding = pairs . mconcat . conwayPParamsPairs + +conwayPParamsPairs :: + forall era a. + (ConwayEraPParams era, KeyValue a) => + PParamsHKD Identity era -> + [a] +conwayPParamsPairs pp = + uncurry (.=) <$> conwayPParamsHKDPairs (Proxy @Identity) pp + +-- | Returns a basic "empty" `PParams` structure with all zero values. +emptyConwayPParams :: forall era. Era era => ConwayPParams Identity era +emptyConwayPParams = + ConwayPParams + { cppMinFeeA = Coin 0 + , cppMinFeeB = Coin 0 + , cppMaxBBSize = 0 + , cppMaxTxSize = 2048 + , cppMaxBHSize = 0 + , cppKeyDeposit = Coin 0 + , cppPoolDeposit = Coin 0 + , cppEMax = EpochNo 0 + , cppNOpt = 100 + , cppA0 = minBound + , cppRho = minBound + , cppTau = minBound + , cppProtocolVersion = ProtVer (eraProtVerLow @era) 0 + , cppMinPoolCost = mempty + , cppCoinsPerUTxOByte = CoinPerByte $ Coin 0 + , cppCostModels = emptyCostModels + , cppPrices = Prices minBound minBound + , cppMaxTxExUnits = OrdExUnits $ ExUnits 0 0 + , cppMaxBlockExUnits = OrdExUnits $ ExUnits 0 0 + , cppMaxValSize = 0 + , cppCollateralPercentage = 150 + , cppMaxCollateralInputs = 5 + , -- New in Conway + cppPoolVotingThresholds = def + , cppDRepVotingThresholds = def + , cppMinCommitteeSize = 0 + , cppCommitteeTermLimit = 0 + , cppGovActionExpiration = 0 + , cppGovActionDeposit = Coin 0 + , cppDRepDeposit = Coin 0 + , cppDRepActivity = EpochNo 0 + } + +emptyConwayPParamsUpdate :: ConwayPParams StrictMaybe era +emptyConwayPParamsUpdate = + ConwayPParams + { cppMinFeeA = SNothing + , cppMinFeeB = SNothing + , cppMaxBBSize = SNothing + , cppMaxTxSize = SNothing + , cppMaxBHSize = SNothing + , cppKeyDeposit = SNothing + , cppPoolDeposit = SNothing + , cppEMax = SNothing + , cppNOpt = SNothing + , cppA0 = SNothing + , cppRho = SNothing + , cppTau = SNothing + , cppProtocolVersion = SNothing + , cppMinPoolCost = SNothing + , cppCoinsPerUTxOByte = SNothing + , cppCostModels = SNothing + , cppPrices = SNothing + , cppMaxTxExUnits = SNothing + , cppMaxBlockExUnits = SNothing + , cppMaxValSize = SNothing + , cppCollateralPercentage = SNothing + , cppMaxCollateralInputs = SNothing + , -- New for Conway + cppPoolVotingThresholds = SNothing + , cppDRepVotingThresholds = SNothing + , cppMinCommitteeSize = SNothing + , cppCommitteeTermLimit = SNothing + , cppGovActionExpiration = SNothing + , cppGovActionDeposit = SNothing + , cppDRepDeposit = SNothing + , cppDRepActivity = SNothing + } + +encodePParamsUpdate :: + ConwayPParams StrictMaybe era -> + Encode ('Closed 'Sparse) (ConwayPParams StrictMaybe era) +encodePParamsUpdate ppup = + Keyed ConwayPParams + !> omitStrictMaybe 0 (cppMinFeeA ppup) encCBOR + !> omitStrictMaybe 1 (cppMinFeeB ppup) encCBOR + !> omitStrictMaybe 2 (cppMaxBBSize ppup) encCBOR + !> omitStrictMaybe 3 (cppMaxTxSize ppup) encCBOR + !> omitStrictMaybe 4 (cppMaxBHSize ppup) encCBOR + !> omitStrictMaybe 5 (cppKeyDeposit ppup) encCBOR + !> omitStrictMaybe 6 (cppPoolDeposit ppup) encCBOR + !> omitStrictMaybe 7 (cppEMax ppup) encCBOR + !> omitStrictMaybe 8 (cppNOpt ppup) encCBOR + !> omitStrictMaybe 9 (cppA0 ppup) encCBOR + !> omitStrictMaybe 10 (cppRho ppup) encCBOR + !> omitStrictMaybe 11 (cppTau ppup) encCBOR + !> omitStrictMaybe 14 (cppProtocolVersion ppup) encCBOR + !> omitStrictMaybe 16 (cppMinPoolCost ppup) encCBOR + !> omitStrictMaybe 17 (cppCoinsPerUTxOByte ppup) encCBOR + !> omitStrictMaybe 18 (cppCostModels ppup) encCBOR + !> omitStrictMaybe 19 (cppPrices ppup) encCBOR + !> omitStrictMaybe 20 (cppMaxTxExUnits ppup) encCBOR + !> omitStrictMaybe 21 (cppMaxBlockExUnits ppup) encCBOR + !> omitStrictMaybe 22 (cppMaxValSize ppup) encCBOR + !> omitStrictMaybe 23 (cppCollateralPercentage ppup) encCBOR + !> omitStrictMaybe 24 (cppMaxCollateralInputs ppup) encCBOR + -- New for Conway + !> omitStrictMaybe 25 (cppPoolVotingThresholds ppup) encCBOR + !> omitStrictMaybe 26 (cppDRepVotingThresholds ppup) encCBOR + !> omitStrictMaybe 27 (cppMinCommitteeSize ppup) encCBOR + !> omitStrictMaybe 28 (cppCommitteeTermLimit ppup) encCBOR + !> omitStrictMaybe 29 (cppGovActionExpiration ppup) encCBOR + !> omitStrictMaybe 30 (cppGovActionDeposit ppup) encCBOR + !> omitStrictMaybe 31 (cppDRepDeposit ppup) encCBOR + !> omitStrictMaybe 32 (cppDRepActivity ppup) encCBOR + where + omitStrictMaybe :: + Word -> StrictMaybe a -> (a -> Encoding) -> Encode ('Closed 'Sparse) (StrictMaybe a) + omitStrictMaybe key x enc = Omit isSNothing (Key key (E (enc . fromSJust) x)) + + fromSJust :: StrictMaybe a -> a + fromSJust (SJust x) = x + fromSJust SNothing = error "SNothing in fromSJust. This should never happen, it is guarded by isSNothing." + +instance Era era => EncCBOR (ConwayPParams StrictMaybe era) where + encCBOR ppup = encode (encodePParamsUpdate ppup) + +updateField :: Word -> Field (ConwayPParams StrictMaybe era) +updateField = \case + 0 -> field (\x up -> up {cppMinFeeA = SJust x}) From + 1 -> field (\x up -> up {cppMinFeeB = SJust x}) From + 2 -> field (\x up -> up {cppMaxBBSize = SJust x}) From + 3 -> field (\x up -> up {cppMaxTxSize = SJust x}) From + 4 -> field (\x up -> up {cppMaxBHSize = SJust x}) From + 5 -> field (\x up -> up {cppKeyDeposit = SJust x}) From + 6 -> field (\x up -> up {cppPoolDeposit = SJust x}) From + 7 -> field (\x up -> up {cppEMax = SJust x}) From + 8 -> field (\x up -> up {cppNOpt = SJust x}) From + 9 -> field (\x up -> up {cppA0 = SJust x}) From + 10 -> field (\x up -> up {cppRho = SJust x}) From + 11 -> field (\x up -> up {cppTau = SJust x}) From + 14 -> field (\x up -> up {cppProtocolVersion = SJust x}) From + 16 -> field (\x up -> up {cppMinPoolCost = SJust x}) From + 17 -> field (\x up -> up {cppCoinsPerUTxOByte = SJust x}) From + 18 -> field (\x up -> up {cppCostModels = SJust x}) From + 19 -> field (\x up -> up {cppPrices = SJust x}) From + 20 -> field (\x up -> up {cppMaxTxExUnits = SJust x}) From + 21 -> field (\x up -> up {cppMaxBlockExUnits = SJust x}) From + 22 -> field (\x up -> up {cppMaxValSize = SJust x}) From + 23 -> field (\x up -> up {cppCollateralPercentage = SJust x}) From + 24 -> field (\x up -> up {cppMaxCollateralInputs = SJust x}) From + -- New for Conway + 25 -> field (\x up -> up {cppPoolVotingThresholds = SJust x}) From + 26 -> field (\x up -> up {cppDRepVotingThresholds = SJust x}) From + 27 -> field (\x up -> up {cppMinCommitteeSize = SJust x}) From + 28 -> field (\x up -> up {cppCommitteeTermLimit = SJust x}) From + 29 -> field (\x up -> up {cppGovActionExpiration = SJust x}) From + 30 -> field (\x up -> up {cppGovActionDeposit = SJust x}) From + 31 -> field (\x up -> up {cppDRepDeposit = SJust x}) From + 32 -> field (\x up -> up {cppDRepActivity = SJust x}) From + k -> field (\_x up -> up) (Invalid k) + +instance Era era => DecCBOR (ConwayPParams StrictMaybe era) where + decCBOR = decode (SparseKeyed "PParamsUpdate" emptyConwayPParamsUpdate updateField []) + +instance Era era => ToCBOR (ConwayPParams StrictMaybe era) where + toCBOR = toEraCBOR @era + +instance Era era => FromCBOR (ConwayPParams StrictMaybe era) where + fromCBOR = fromEraCBOR @era + +instance + ( ConwayEraPParams era + , PParamsHKD StrictMaybe era ~ ConwayPParams StrictMaybe era + ) => + ToJSON (ConwayPParams StrictMaybe era) + where + toJSON = object . conwayPParamsUpdatePairs + toEncoding = pairs . mconcat . conwayPParamsUpdatePairs + +conwayPParamsUpdatePairs :: + forall era a. + (ConwayEraPParams era, KeyValue a) => + PParamsHKD StrictMaybe era -> + [a] +conwayPParamsUpdatePairs pp = + [ k .= v + | (k, SJust v) <- conwayPParamsHKDPairs (Proxy @StrictMaybe) pp + ] + +conwayPParamsHKDPairs :: + forall era f. + (ConwayEraPParams era, HKDFunctor f) => + Proxy f -> + PParamsHKD f era -> + [(Key, HKD f Value)] +conwayPParamsHKDPairs px pp = babbagePParamsHKDPairs px pp <> conwayUpgradePParamsHKDPairs px pp + +conwayUpgradePParamsHKDPairs :: + forall era f. + (ConwayEraPParams era, HKDFunctor f) => + Proxy f -> + PParamsHKD f era -> + [(Key, HKD f Value)] +conwayUpgradePParamsHKDPairs px pp = + [ ("poolVotingThresholds", hkdMap px (toJSON @PoolVotingThresholds) (pp ^. hkdPoolVotingThresholdsL @era @f)) + , ("dRepVotingThresholds", hkdMap px (toJSON @DRepVotingThresholds) (pp ^. hkdDRepVotingThresholdsL @era @f)) + , ("minCommitteeSize", hkdMap px (toJSON @Natural) (pp ^. hkdMinCommitteeSizeL @era @f)) + , ("committeeTermLimit", hkdMap px (toJSON @Natural) (pp ^. hkdCommitteeTermLimitL @era @f)) + , ("govActionExpiration", hkdMap px (toJSON @Natural) (pp ^. hkdGovActionExpirationL @era @f)) + , ("govActionDeposit", hkdMap px (toJSON @Coin) (pp ^. hkdGovActionDepositL @era @f)) + , ("dRepDeposit", hkdMap px (toJSON @Coin) (pp ^. hkdDRepDepositL @era @f)) + , ("dRepActivity", hkdMap px (toJSON @EpochNo) (pp ^. hkdDRepActivityL @era @f)) + ] + +upgradeConwayPParams :: + forall f c. + UpgradeConwayPParams f -> + PParamsHKD f (BabbageEra c) -> + ConwayPParams f (ConwayEra c) +upgradeConwayPParams UpgradeConwayPParams {..} BabbagePParams {..} = + ConwayPParams + { cppMinFeeA = bppMinFeeA + , cppMinFeeB = bppMinFeeB + , cppMaxBBSize = bppMaxBBSize + , cppMaxTxSize = bppMaxTxSize + , cppMaxBHSize = bppMaxBHSize + , cppKeyDeposit = bppKeyDeposit + , cppPoolDeposit = bppPoolDeposit + , cppEMax = bppEMax + , cppNOpt = bppNOpt + , cppA0 = bppA0 + , cppRho = bppRho + , cppTau = bppTau + , cppProtocolVersion = bppProtocolVersion + , cppMinPoolCost = bppMinPoolCost + , cppCoinsPerUTxOByte = bppCoinsPerUTxOByte + , cppCostModels = bppCostModels + , cppPrices = bppPrices + , cppMaxTxExUnits = bppMaxTxExUnits + , cppMaxBlockExUnits = bppMaxBlockExUnits + , cppMaxValSize = bppMaxValSize + , cppCollateralPercentage = bppCollateralPercentage + , cppMaxCollateralInputs = bppMaxCollateralInputs + , -- New for Conway + cppPoolVotingThresholds = ucppPoolVotingThresholds + , cppDRepVotingThresholds = ucppDRepVotingThresholds + , cppMinCommitteeSize = ucppMinCommitteeSize + , cppCommitteeTermLimit = ucppCommitteeTermLimit + , cppGovActionExpiration = ucppGovActionExpiration + , cppGovActionDeposit = ucppGovActionDeposit + , cppDRepDeposit = ucppDRepDeposit + , cppDRepActivity = ucppDRepActivity + } + +downgradeConwayPParams :: + forall f c. + ConwayPParams f (ConwayEra c) -> + PParamsHKD f (BabbageEra c) +downgradeConwayPParams ConwayPParams {..} = + BabbagePParams + { bppMinFeeA = cppMinFeeA + , bppMinFeeB = cppMinFeeB + , bppMaxBBSize = cppMaxBBSize + , bppMaxTxSize = cppMaxTxSize + , bppMaxBHSize = cppMaxBHSize + , bppKeyDeposit = cppKeyDeposit + , bppPoolDeposit = cppPoolDeposit + , bppEMax = cppEMax + , bppNOpt = cppNOpt + , bppA0 = cppA0 + , bppRho = cppRho + , bppTau = cppTau + , bppProtocolVersion = cppProtocolVersion + , bppMinPoolCost = cppMinPoolCost + , bppCoinsPerUTxOByte = cppCoinsPerUTxOByte + , bppCostModels = cppCostModels + , bppPrices = cppPrices + , bppMaxTxExUnits = cppMaxTxExUnits + , bppMaxBlockExUnits = cppMaxBlockExUnits + , bppMaxValSize = cppMaxValSize + , bppCollateralPercentage = cppCollateralPercentage + , bppMaxCollateralInputs = cppMaxCollateralInputs + } diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Translation.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Translation.hs index f23242b8078..52e55b465e1 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Translation.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Translation.hs @@ -40,6 +40,7 @@ import Cardano.Ledger.Shelley.API ( import qualified Cardano.Ledger.Shelley.API as API import Cardano.Ledger.Val (Val (coin, zero)) import Data.Coerce +import Data.Default.Class (def) import qualified Data.Map.Strict as Map import Lens.Micro @@ -99,7 +100,7 @@ instance Crypto c => TranslateEra (ConwayEra c) Tx where -------------------------------------------------------------------------------- instance Crypto c => TranslateEra (ConwayEra c) PParams where - translateEra _ = pure . upgradePParams () + translateEra _ = pure . upgradePParams def -- TODO: Pick UpgradeConwayPParams from ConwayGenesis instead instance Crypto c => TranslateEra (ConwayEra c) EpochState where translateEra ctxt es = @@ -108,8 +109,8 @@ instance Crypto c => TranslateEra (ConwayEra c) EpochState where { esAccountState = esAccountState es , esSnapshots = esSnapshots es , esLState = translateEra' ctxt $ esLState es - , esPrevPp = upgradePParams () $ esPrevPp es - , esPp = upgradePParams () $ esPp es + , esPrevPp = upgradePParams def $ esPrevPp es -- TODO: Pick UpgradeConwayPParams from ConwayGenesis instead + , esPp = upgradePParams def $ esPp es -- TODO: Pick UpgradeConwayPParams from ConwayGenesis instead , esNonMyopic = esNonMyopic es } @@ -160,7 +161,7 @@ instance Crypto c => TranslateEra (ConwayEra c) API.UTxO where instance Crypto c => TranslateEra (ConwayEra c) API.ProposedPPUpdates where translateEra _ctxt (API.ProposedPPUpdates ppup) = - pure $ API.ProposedPPUpdates $ fmap (upgradePParamsUpdate ()) ppup + pure $ API.ProposedPPUpdates $ fmap (upgradePParamsUpdate def) ppup -- TODO: Pick UpgradeConwayPParams from ConwayGenesis instead -- | Filter out TxOut's with zero Coins and normalize Pointers, while converting TxOuts to -- Conway era. diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Arbitrary.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Arbitrary.hs index 4add9b96470..99e2a42284b 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Arbitrary.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Arbitrary.hs @@ -10,17 +10,20 @@ module Test.Cardano.Ledger.Conway.Arbitrary () where import Cardano.Ledger.Alonzo.Scripts (AlonzoScript) +import Cardano.Ledger.BaseTypes (StrictMaybe) import Cardano.Ledger.Binary (Sized) import Cardano.Ledger.Conway import Cardano.Ledger.Conway.Core import Cardano.Ledger.Conway.Genesis (ConwayGenesis (..)) import Cardano.Ledger.Conway.Governance +import Cardano.Ledger.Conway.PParams import Cardano.Ledger.Conway.Rules import Cardano.Ledger.Conway.TxBody import Cardano.Ledger.Conway.TxCert import Cardano.Ledger.Crypto (Crypto) import Cardano.Ledger.Language (Language (..)) import Control.State.Transition.Extended (STS (Event)) +import Data.Functor.Identity (Identity) import Test.Cardano.Ledger.Alonzo.Arbitrary (genAlonzoScript) import Test.Cardano.Ledger.Babbage.Arbitrary () import Test.Cardano.Ledger.Common @@ -317,3 +320,93 @@ instance Era era => Arbitrary (ConwayGovCertPredFailure era) where , ConwayDRepIncorrectDeposit <$> arbitrary , ConwayCommitteeHasResigned <$> arbitrary ] + +instance Era era => Arbitrary (ConwayPParams Identity era) where + arbitrary = + ConwayPParams + <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + +instance Era era => Arbitrary (ConwayPParams StrictMaybe era) where + arbitrary = + ConwayPParams + <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + +instance Arbitrary PoolVotingThresholds where + arbitrary = + PoolVotingThresholds + <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + +instance Arbitrary DRepVotingThresholds where + arbitrary = + DRepVotingThresholds + <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary diff --git a/eras/conway/test-suite/cddl-files/conway.cddl b/eras/conway/test-suite/cddl-files/conway.cddl index 7e10b013c32..fea63c709f5 100644 --- a/eras/conway/test-suite/cddl-files/conway.cddl +++ b/eras/conway/test-suite/cddl-files/conway.cddl @@ -360,30 +360,58 @@ url = tstr .size (0..64) withdrawals = { * reward_account => coin } protocol_param_update = - { ? 0: uint ; minfee A - , ? 1: uint ; minfee B - , ? 2: uint ; max block body size - , ? 3: uint ; max transaction size - , ? 4: uint ; max block header size - , ? 5: coin ; key deposit - , ? 6: coin ; pool deposit (TODO: drep deposit needs to be added) - , ? 7: epoch ; maximum epoch - , ? 8: uint ; n_opt: desired number of stake pools - , ? 9: rational ; pool pledge influence - , ? 10: unit_interval ; expansion rate - , ? 11: unit_interval ; treasury growth rate - , ? 14: [protocol_version] ; protocol version - , ? 16: coin ; min pool cost - , ? 17: coin ; ada per utxo byte - , ? 18: costmdls ; cost models for script languages - , ? 19: ex_unit_prices ; execution costs - , ? 20: ex_units ; max tx ex units - , ? 21: ex_units ; max block ex units - , ? 22: uint ; max value size - , ? 23: uint ; collateral percentage - , ? 24: uint ; max collateral inputs + { ? 0: uint ; minfee A + , ? 1: uint ; minfee B + , ? 2: uint ; max block body size + , ? 3: uint ; max transaction size + , ? 4: uint ; max block header size + , ? 5: coin ; key deposit + , ? 6: coin ; pool deposit (TODO: drep deposit needs to be added) + , ? 7: epoch ; maximum epoch + , ? 8: uint ; n_opt: desired number of stake pools + , ? 9: rational ; pool pledge influence + , ? 10: unit_interval ; expansion rate + , ? 11: unit_interval ; treasury growth rate + , ? 14: [protocol_version] ; protocol version + , ? 16: coin ; min pool cost + , ? 17: coin ; ada per utxo byte + , ? 18: costmdls ; cost models for script languages + , ? 19: ex_unit_prices ; execution costs + , ? 20: ex_units ; max tx ex units + , ? 21: ex_units ; max block ex units + , ? 22: uint ; max value size + , ? 23: uint ; collateral percentage + , ? 24: uint ; max collateral inputs + , ? 25: pool_voting_thresholds ; pool voting thresholds + , ? 26: drep_voting_thresholds ; DRep voting thresholds + , ? 27: uint ; min committee size + , ? 28: uint ; committee term limit + , ? 29: uint ; governance action expiration + , ? 30: coin ; governance action deposit + , ? 31: coin ; DRep deposit + , ? 32: epoch ; DRep inactivity period } +pool_voting_thresholds = + [ unit_interval ; motion no confidence + , unit_interval ; committee normal + , unit_interval ; committee no confidence + , unit_interval ; hard fork initiation + ] + +drep_voting_thresholds = + [ unit_interval ; motion no confidence + , unit_interval ; committee normal + , unit_interval ; committee no confidence + , unit_interval ; update constitution + , unit_interval ; hard fork initiation + , unit_interval ; PP network group + , unit_interval ; PP economic group + , unit_interval ; PP technical group + , unit_interval ; PP governance group + , unit_interval ; treasury withdrawal + ] + transaction_witness_set = { ? 0: [* vkeywitness ] , ? 1: [* native_script ] diff --git a/eras/conway/test-suite/src/Test/Cardano/Ledger/Conway/Serialisation/Roundtrip.hs b/eras/conway/test-suite/src/Test/Cardano/Ledger/Conway/Serialisation/Roundtrip.hs index ab72c444e9f..922c5c8c1c6 100644 --- a/eras/conway/test-suite/src/Test/Cardano/Ledger/Conway/Serialisation/Roundtrip.hs +++ b/eras/conway/test-suite/src/Test/Cardano/Ledger/Conway/Serialisation/Roundtrip.hs @@ -11,10 +11,13 @@ import Cardano.Ledger.Alonzo.TxWits (AlonzoTxWits) import Cardano.Ledger.Binary.Version (natVersion) import Cardano.Ledger.Conway (Conway) import Cardano.Ledger.Conway.Genesis (ConwayGenesis (..)) +import Cardano.Ledger.Conway.PParams (ConwayPParams) import Cardano.Ledger.Core import Data.Data (Proxy (..), typeRep) +import Data.Functor.Identity (Identity) +import Data.Maybe.Strict (StrictMaybe) import Test.Cardano.Ledger.Alonzo.Arbitrary (FlexibleCostModels) -import Test.Cardano.Ledger.Binary.Plain.RoundTrip as Plain (roundTripCborExpectation) +import Test.Cardano.Ledger.Binary.Plain.RoundTrip as Plain import Test.Cardano.Ledger.Binary.RoundTrip import Test.Cardano.Ledger.Conway.Arbitrary () import Test.Tasty (TestTree, testGroup) @@ -50,4 +53,12 @@ allprops = roundTripCborRangeExpectation @(TxCert Conway) (eraProtVerLow @Conway) (eraProtVerHigh @Conway) + , testProperty "Conway PParams" $ + roundTripCborRangeExpectation @(ConwayPParams Identity Conway) + (eraProtVerLow @Conway) + (eraProtVerHigh @Conway) + , testProperty "Conway PParamsUpdate" $ + roundTripCborRangeExpectation @(ConwayPParams StrictMaybe Conway) + (eraProtVerLow @Conway) + (eraProtVerHigh @Conway) ]