Merge pull request #3766 from input-output-hk/jj/protver-field
Prevent updating protocol version with `PParamUpdate`
Prevent updating protocol version with `PParamUpdate`
emptyPPPUpdates,
shelleyCommonPParamsHKDPairs,
shelleyCommonPParamsHKDPairsV6,
shelleyCommonPParamsHKDPairsV8,
)
import Cardano.Ledger.TreeDiff (ToExpr (..))
import Cardano.Ledger.Val (Val (..))
[(Key, HKD f Aeson.Value)]
alonzoPParamsHKDPairs px pp =
alonzoCommonPParamsHKDPairs px pp
++ shelleyCommonPParamsHKDPairsV8 px pp
++ shelleyCommonPParamsHKDPairsV6 px pp
++ [("lovelacePerUTxOWord", hkdMap px (toJSON @CoinPerWord) (pp ^. hkdCoinsPerUTxOWordL @_ @f))]
fromCBOR = fromEraCBOR @era
instance
(PParamsHKD Identity era ~ BabbagePParams Identity era, BabbageEraPParams era) =>
(PParamsHKD Identity era ~ BabbagePParams Identity era, BabbageEraPParams era, ProtVerAtMost era 8) =>
ToJSON (BabbagePParams Identity era)
where
toJSON = object . babbagePParamsPairs
fromCBOR = fromEraCBOR @era
instance
(PParamsHKD StrictMaybe era ~ BabbagePParams StrictMaybe era, BabbageEraPParams era) =>
(PParamsHKD StrictMaybe era ~ BabbagePParams StrictMaybe era, BabbageEraPParams era, ProtVerAtMost era 8) =>
ToJSON (BabbagePParams StrictMaybe era)
where
toJSON = object . babbagePParamsUpdatePairs
* Add `conwayWitsVKeyNeeded`
* Add `ConwayEraPParams era` constraint to `isCommitteeVotingAllowed` and `votingCommitteeThreshold`
* Switch to using `AlonzoEraUTxO` in rules
* Change `cppProtocolVersion` to a `HKDNoUpdate` field
## 1.9.0.0
import Cardano.Ledger.Conway.Core hiding (Value)
import Cardano.Ledger.Conway.Era (ConwayEra)
import Cardano.Ledger.Crypto
import Cardano.Ledger.HKD (HKD, HKDFunctor (..))
import Cardano.Ledger.HKD (HKD, HKDFunctor (..), HKDNoUpdate, NoUpdate (..))
import Cardano.Ledger.TreeDiff (ToExpr)
import Cardano.Ledger.Val (Val (..))
import Control.DeepSeq (NFData)
-- ^ Monetary expansion
, cppTau :: !(HKD f UnitInterval)
-- ^ Treasury expansion
, cppProtocolVersion :: !(HKD f ProtVer)
, cppProtocolVersion :: !(HKDNoUpdate f ProtVer)
-- ^ Protocol version
, cppMinPoolCost :: !(HKD f Coin)
-- ^ Minimum Stake Pool Cost
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}
hkdProtocolVersionL = notSupportedInThisEraL
hkdMinPoolCostL = lens cppMinPoolCost $ \pp x -> pp {cppMinPoolCost = x}
ppProtocolVersionL = ppLens . lens cppProtocolVersion (\pp x -> pp {cppProtocolVersion = x})
ppDG = to (const minBound)
ppuProtocolVersionL = notSupportedInThisEraL
hkdDL = notSupportedInThisEraL
hkdExtraEntropyL = notSupportedInThisEraL
hkdMinUTxOValueL = notSupportedInThisEraL
, cppA0 = SNothing
, cppRho = SNothing
, cppTau = SNothing
, cppProtocolVersion = SNothing
, cppProtocolVersion = NoUpdate
, cppMinPoolCost = SNothing
, cppCoinsPerUTxOByte = SNothing
, cppCostModels = SNothing
!> omitStrictMaybe 9 (cppA0 ppup) encCBOR
!> omitStrictMaybe 10 (cppRho ppup) encCBOR
!> omitStrictMaybe 11 (cppTau ppup) encCBOR
!> omitStrictMaybe 14 SNothing encCBOR
!> OmitC NoUpdate
!> omitStrictMaybe 16 (cppMinPoolCost ppup) encCBOR
!> omitStrictMaybe 17 (cppCoinsPerUTxOByte ppup) encCBOR
!> omitStrictMaybe 18 (cppCostModels ppup) encCBOR
upgradeConwayPParams ::
forall f c.
HKDFunctor f =>
UpgradeConwayPParams f ->
PParamsHKD f (BabbageEra c) ->
ConwayPParams f (ConwayEra c)
, cppA0 = bppA0
, cppRho = bppRho
, cppTau = bppTau
, cppProtocolVersion = bppProtocolVersion
, cppProtocolVersion = toNoUpdate @f @ProtVer bppProtocolVersion
, cppMinPoolCost = bppMinPoolCost
, cppCoinsPerUTxOByte = bppCoinsPerUTxOByte
, cppCostModels = bppCostModels
downgradeConwayPParams ::
forall f c.
HKDFunctor f =>
ConwayPParams f (ConwayEra c) ->
PParamsHKD f (BabbageEra c)
downgradeConwayPParams ConwayPParams {..} =
, bppA0 = cppA0
, bppRho = cppRho
, bppTau = cppTau
, bppProtocolVersion = cppProtocolVersion
, bppProtocolVersion = fromNoUpdate @f @ProtVer cppProtocolVersion
, bppMinPoolCost = cppMinPoolCost
, bppCoinsPerUTxOByte = cppCoinsPerUTxOByte
, bppCostModels = cppCostModels
import Cardano.Ledger.Conway.TxBody
import Cardano.Ledger.Conway.TxCert
import Cardano.Ledger.Crypto (Crypto)
import Cardano.Ledger.HKD (NoUpdate (..))
import Cardano.Ledger.Language (Language (..))
import Control.State.Transition.Extended (STS (Event))
import Data.Functor.Identity (Identity)
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> pure SNothing
<*> pure NoUpdate
<*> arbitrary
<*> arbitrary
<*> (fmap unFlexibleCostModels <$> arbitrary)
## 1.7.0.0
* Add `shelleyCommonPParamsHKDPairsV8`
* Add `ToExpr` instances for:
* `ShelleyPoolPredFailure`
* `ShelleyUtxowPredFailure`
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
-- * JSON helpers
shelleyCommonPParamsHKDPairs,
shelleyCommonPParamsHKDPairsV6,
shelleyCommonPParamsHKDPairsV8,
-- * Deprecated
updatePParams,
, PParamsHKD Identity era ~ ShelleyPParams Identity era
, ProtVerAtMost era 4
, ProtVerAtMost era 6
, ProtVerAtMost era 8
) =>
ToJSON (ShelleyPParams Identity era)
where
shelleyPParamsPairs ::
forall era a.
(EraPParams era, ProtVerAtMost era 4, ProtVerAtMost era 6, KeyValue a) =>
(EraPParams era, ProtVerAtMost era 4, ProtVerAtMost era 6, ProtVerAtMost era 8, KeyValue a) =>
PParamsHKD Identity era ->
[a]
shelleyPParamsPairs pp =
, PParamsHKD StrictMaybe era ~ ShelleyPParams StrictMaybe era
, ProtVerAtMost era 4
, ProtVerAtMost era 6
, ProtVerAtMost era 8
) =>
ToJSON (ShelleyPParams StrictMaybe era)
where
shelleyPParamsUpdatePairs ::
forall era a.
(EraPParams era, ProtVerAtMost era 4, ProtVerAtMost era 6, KeyValue a) =>
(EraPParams era, ProtVerAtMost era 4, ProtVerAtMost era 6, ProtVerAtMost era 8, KeyValue a) =>
PParamsHKD StrictMaybe era ->
[a]
shelleyPParamsUpdatePairs pp =
shelleyPParamsHKDPairs ::
forall f era.
(HKDFunctor f, EraPParams era, ProtVerAtMost era 4, ProtVerAtMost era 6) =>
(HKDFunctor f, EraPParams era, ProtVerAtMost era 4, ProtVerAtMost era 6, ProtVerAtMost era 8) =>
Proxy f ->
PParamsHKD f era ->
[(Key, HKD f Aeson.Value)]
shelleyPParamsHKDPairs px pp =
shelleyCommonPParamsHKDPairs px pp
++ shelleyCommonPParamsHKDPairsV6 px pp
++ shelleyCommonPParamsHKDPairsV8 px pp
++ [("minUTxOValue", hkdMap px (toJSON @Coin) (pp ^. hkdMinUTxOValueL @era @f))]
-- | These are the fields that are common only up to major protocol version 6
, ("extraEntropy", hkdMap px (toJSON @Nonce) (pp ^. hkdExtraEntropyL @era @f))
]
shelleyCommonPParamsHKDPairsV8 ::
forall f era.
(HKDFunctor f, EraPParams era, ProtVerAtMost era 8) =>
Proxy f ->
PParamsHKD f era ->
[(Key, HKD f Aeson.Value)]
shelleyCommonPParamsHKDPairsV8 px pp =
[ ("protocolVersion", hkdMap px (toJSON @ProtVer) (pp ^. hkdProtocolVersionL @era @f))
]
-- | These are the fields that are common across all eras
shelleyCommonPParamsHKDPairs ::
forall f era.
, ("a0", hkdMap px (toJSON @NonNegativeInterval) (pp ^. hkdA0L @era @f))
, ("rho", hkdMap px (toJSON @UnitInterval) (pp ^. hkdRhoL @era @f))
, ("tau", hkdMap px (toJSON @UnitInterval) (pp ^. hkdTauL @era @f))
, ("protocolVersion", hkdMap px (toJSON @ProtVer) (pp ^. hkdProtocolVersionL @era @f))
, ("minPoolCost", hkdMap px (toJSON @Coin) (pp ^. hkdMinPoolCostL @era @f))
]
instance
( EraGov era
, GovState era ~ ShelleyGovState era
, ProtVerAtMost era 8
) =>
STS (ShelleyNEWPP era)
where
forall era.
( GovState era ~ ShelleyGovState era
, EraGov era
, ProtVerAtMost era 8
) =>
TransitionRule (ShelleyNEWPP era)
newPpTransition = do
updatePpup ::
( EraPParams era
, GovState era ~ ShelleyGovState era
, ProtVerAtMost era 8
) =>
GovState era ->
PParams era ->
newtype PpupEvent era = NewEpoch EpochNo
instance EraPParams era => STS (ShelleyPPUP era) where
instance (EraPParams era, ProtVerAtMost era 8) => STS (ShelleyPPUP era) where
type State (ShelleyPPUP era) = ShelleyGovState era
type Signal (ShelleyPPUP era) = Maybe (Update era)
type Environment (ShelleyPPUP era) = PpupEnv era
pure (2, PVCannotFollowPPUP p)
k -> invalidKey k
ppupTransitionNonEmpty :: EraPParams era => TransitionRule (ShelleyPPUP era)
ppupTransitionNonEmpty :: (EraPParams era, ProtVerAtMost era 8) => TransitionRule (ShelleyPPUP era)
ppupTransitionNonEmpty = do
TRC
( PPUPEnv slot pp (GenDelegs _genDelegs)
( EraGov era
, Default (PParams era)
, GovState era ~ ShelleyGovState era
, ProtVerAtMost era 8
) =>
STS (ShelleyUPEC era)
where
-- | This is only good in the Shelley Era, used to define the genShelleyEraPParamsUpdate method for (EraGen (ShelleyEra c))
genShelleyPParamsUpdate ::
forall era.
(ProtVerAtMost era 4, ProtVerAtMost era 6, EraPParams era) =>
(ProtVerAtMost era 4, ProtVerAtMost era 6, ProtVerAtMost era 8, EraPParams era) =>
Constants ->
PParams era ->
Gen (PParamsUpdate era)
## 1.8.0.0
* Add `NoUpdate`, `HKDNoUpdate`
* Add `toNoUpdate` and `fromNoUpdate` methods to `HKDFunctor`
* Add `Updatable` instance for `NoUpdate`
* Change functions to methods of `EraPParams`:
* `ppProtocolVersionL`
* `ppuProtocolVersionL`
* Add `Generic` instance for `AuxiliaryDataHash`
* Add `ToExpr` instances for:
* `CompactAddr`
ppTauL,
ppDL,
ppExtraEntropyL,
ppProtocolVersionL,
ppMinUTxOValueL,
ppMinPoolCostL,
ppuTauL,
ppuDL,
ppuExtraEntropyL,
ppuProtocolVersionL,
ppuMinUTxOValueL,
ppuMinPoolCostL,
import Cardano.Ledger.Binary (DecCBOR, EncCBOR, FromCBOR, ToCBOR)
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Core.Era (Era (..), PreviousEra, ProtVerAtMost)
import Cardano.Ledger.HKD (HKD, HKDFunctor)
import Cardano.Ledger.HKD (HKD, HKDFunctor (..), NoUpdate (..))
import Control.DeepSeq (NFData)
import Control.Monad.Identity (Identity)
import Data.Aeson (FromJSON, ToJSON)
SJust x -> x
SNothing -> x'
instance Updatable (K1 t x a) (K1 t (NoUpdate x) u) where
applyUpdate (K1 x) (K1 NoUpdate) = K1 x
genericApplyPPUpdates ::
forall era a u.
( Generic (PParamsHKD Identity era)
hkdExtraEntropyL :: (HKDFunctor f, ProtVerAtMost era 6) => Lens' (PParamsHKD f era) (HKD f Nonce)
-- | Protocol version
hkdProtocolVersionL :: HKDFunctor f => Lens' (PParamsHKD f era) (HKD f ProtVer)
hkdProtocolVersionL :: (HKDFunctor f, ProtVerAtMost era 8) => Lens' (PParamsHKD f era) (HKD f ProtVer)
ppProtocolVersionL :: EraPParams era => Lens' (PParams era) ProtVer
default ppProtocolVersionL :: ProtVerAtMost era 8 => Lens' (PParams era) ProtVer
ppProtocolVersionL = ppLens . hkdProtocolVersionL @era @Identity
-- | PParamsUpdate Protocol version
ppuProtocolVersionL :: (ProtVerAtMost era 8, EraPParams era) => Lens' (PParamsUpdate era) (StrictMaybe ProtVer)
ppuProtocolVersionL = ppuLens . hkdProtocolVersionL @era @StrictMaybe
-- | Minimum UTxO value
hkdMinUTxOValueL :: HKDFunctor f => ProtVerAtMost era 4 => Lens' (PParamsHKD f era) (HKD f Coin)
ppExtraEntropyL :: forall era. (EraPParams era, ProtVerAtMost era 6) => Lens' (PParams era) Nonce
ppExtraEntropyL = ppLens . hkdExtraEntropyL @era @Identity
-- | Protocol version
ppProtocolVersionL :: forall era. EraPParams era => Lens' (PParams era) ProtVer
ppProtocolVersionL = ppLens . hkdProtocolVersionL @era @Identity
-- | Minimum UTxO value
ppMinUTxOValueL :: forall era. (EraPParams era, ProtVerAtMost era 4) => Lens' (PParams era) Coin
ppMinUTxOValueL = ppLens . hkdMinUTxOValueL @era @Identity
Lens' (PParamsUpdate era) (StrictMaybe Nonce)
ppuExtraEntropyL = ppuLens . hkdExtraEntropyL @era @StrictMaybe
-- | Protocol version
ppuProtocolVersionL :: forall era. EraPParams era => Lens' (PParamsUpdate era) (StrictMaybe ProtVer)
ppuProtocolVersionL = ppuLens . hkdProtocolVersionL @era @StrictMaybe
-- | Minimum UTxO value
ppuMinUTxOValueL ::
forall era.
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
-- | This module contains just the type of protocol parameters.
module Cardano.Ledger.HKD (
HKD,
HKDNoUpdate,
HKDFunctor (..),
NoUpdate (..),
)
where
import Cardano.Ledger.TreeDiff (ToExpr)
import Control.DeepSeq (NFData)
import Data.Functor.Identity (Identity)
import Data.Maybe.Strict (StrictMaybe (..))
import GHC.Generics (Generic)
import NoThunks.Class (NoThunks)
-- ====================================================================
HKD Identity a = a
HKD f a = f a
data NoUpdate a = NoUpdate
deriving (Eq, Ord, Show, Generic)
instance NoThunks (NoUpdate a)
instance NFData (NoUpdate a)
instance ToExpr (NoUpdate a)
type family HKDNoUpdate f a where
HKDNoUpdate Identity a = a
HKDNoUpdate StrictMaybe a = NoUpdate a
HKDNoUpdate Maybe a = NoUpdate a
HKDNoUpdate f a = f a
class HKDFunctor f where
hkdMap :: proxy f -> (a -> b) -> HKD f a -> HKD f b
toNoUpdate :: HKD f a -> HKDNoUpdate f a
fromNoUpdate :: HKDNoUpdate f a -> HKD f a
instance HKDFunctor Identity where
hkdMap _ f a = f a
hkdMap _ f = f
toNoUpdate = id
fromNoUpdate = id
instance HKDFunctor Maybe where
hkdMap _ f = fmap f
hkdMap _ = fmap
toNoUpdate _ = NoUpdate
fromNoUpdate _ = Nothing
instance HKDFunctor StrictMaybe where
hkdMap _ f = fmap f
hkdMap _ = fmap
toNoUpdate _ = NoUpdate
fromNoUpdate _ = SNothing
# Changelog for `cardano-ledger-pretty`
## 1.3.2.1
## 1.3.3.0
*
* Add `PrettyA` instance for `NoUpdate`
## 1.3.2.0
cabal-version: 3.0
name: cardano-ledger-pretty
version: 1.3.2.1
version: 1.3.3.0
license: Apache-2.0
maintainer: [email protected]
author: IOHK
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
Stake (..),
)
import qualified Cardano.Ledger.Era as Era (TxSeq)
import Cardano.Ledger.HKD (NoUpdate (..))
import Cardano.Ledger.Keys (
GKeys (..),
GenDelegPair (..),
]
ppPParamsUpdate ::
(ProtVerAtMost era 4, ProtVerAtMost era 6, EraPParams era) =>
(ProtVerAtMost era 4, ProtVerAtMost era 6, ProtVerAtMost era 8, EraPParams era) =>
PParamsUpdate era ->
PDoc
ppPParamsUpdate pp =
instance (PrettyA x, PrettyA y) => PrettyA (Map.Map x y) where
prettyA m = ppMap prettyA prettyA m
instance PrettyA (NoUpdate a) where
prettyA NoUpdate = "NoUpdate"
-- | turn on trace appromimately 1 in 'n' times it is called.
occaisionally :: Hashable.Hashable a => a -> Int -> String -> String
occaisionally x n s = if mod (Hashable.hash x) n == 0 then trace s s else s
instance PrettyA CoinPerByte where
prettyA = prettyA . unCoinPerByte
ppBabbagePParamsUpdate :: BabbageEraPParams era => PParamsUpdate era -> PDoc
ppBabbagePParamsUpdate :: (BabbageEraPParams era, ProtVerAtMost era 8) => PParamsUpdate era -> PDoc
ppBabbagePParamsUpdate pp =
ppRecord
"PParamsUdate"
) where
import Cardano.Ledger.Alonzo.Scripts (CostModels, ExUnits, Prices)
import Cardano.Ledger.BaseTypes (EpochNo, NonNegativeInterval, ProtVer, UnitInterval)
import Cardano.Ledger.BaseTypes (EpochNo, NonNegativeInterval, UnitInterval)
import Cardano.Ledger.Coin (Coin)
import Cardano.Ledger.Compactible (fromCompact)
import Cardano.Ledger.Conway (ConwayEra)
)
import Cardano.Ledger.Crypto
import Cardano.Ledger.DRepDistr (extractDRepDistr)
import Cardano.Ledger.HKD (HKD, HKDFunctor)
import Cardano.Ledger.HKD (HKD, HKDFunctor (..))
import Cardano.Ledger.Pretty (
PDoc,
PrettyA (..),
ppConwayPParams ::
forall era f.
( PrettyA (HKD f UnitInterval)
, PrettyA (HKD f ProtVer)
, PrettyA (HKD f Prices)
, PrettyA (HKD f PoolVotingThresholds)
, PrettyA (HKD f Coin)
n
[ ("Tau", prettyA $ pp ^. hkdTauL @era @f)
, ("Rho", prettyA $ pp ^. hkdRhoL @era @f)
, ("ProtocolVersion", prettyA $ pp ^. hkdProtocolVersionL @era @f)
, ("Prices", prettyA $ pp ^. hkdPricesL @era @f)
, ("PoolVotingThresholds", prettyA $ pp ^. hkdPoolVotingThresholdsL @era @f)
, ("PoolDeposit", prettyA $ pp ^. hkdPoolDepositL @era @f)
Alonzo builds