Added DijkstraPParams, made Conway GoldenSpec era-specific

Co-authored-by: Alexey Kuleshevich <alexey.kuleshevich@iohk.io>

Author: Soupstraw

eras/alonzo/impl/CHANGELOG.md

@@ -2,6 +2,7 @@
 
 ## 1.14.0.0
 
+* Add `emptyUpgradePParamsUpdate` method to `AlonzoEraPParams`
 * Add `mkBasicBlockBodyAlonzo` and `txSeqBlockBodyAlonzoL` to use in Babbage, Conway and Dijkstra.
 * Added `eraUnsupportedLanguage`
 * Changed return type of `mkPlutusScript` and `mkBinaryPlutusScript` from `Maybe` to `MonadFail`

eras/alonzo/impl/src/Cardano/Ledger/Alonzo/PParams.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DefaultSignatures #-}
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DerivingStrategies #-}
@@ -17,6 +18,7 @@
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE UndecidableSuperClasses #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
@@ -312,6 +314,7 @@ instance EraPParams AlonzoEra where
 
   upgradePParamsHKD = upgradeAlonzoPParams
   downgradePParamsHKD = downgradeAlonzoPParams
+  emptyUpgradePParamsUpdate = emptyAlonzoUpgradePParamsUpdate
 
   hkdMinFeeAL = lens appMinFeeA $ \pp x -> pp {appMinFeeA = x}
   hkdMinFeeBL = lens appMinFeeB $ \pp x -> pp {appMinFeeB = x}
@@ -420,6 +423,10 @@ data UpgradeAlonzoPParams f = UpgradeAlonzoPParams
   }
   deriving (Generic)
 
+emptyAlonzoUpgradePParamsUpdate :: UpgradeAlonzoPParams StrictMaybe
+emptyAlonzoUpgradePParamsUpdate =
+  UpgradeAlonzoPParams SNothing SNothing SNothing SNothing SNothing SNothing SNothing SNothing
+
 deriving instance Eq (UpgradeAlonzoPParams Identity)
 
 deriving instance Show (UpgradeAlonzoPParams Identity)

eras/conway/impl/CHANGELOG.md

@@ -2,6 +2,16 @@
 
 ## 1.20.0.0
 
+* Removed:
+  * `maxRefScriptSizePerTx`
+  * `maxRefScriptSizePerBlock`
+  * `refScriptCostMultiplier`
+  * `refScriptCostStride`
+* Added:
+  * `ppMaxRefScriptSizePerTxG`
+  * `ppMaxRefScriptSizePerBlockG`
+  * `ppRefScriptCostMultiplierG`
+  * `ppRefScriptCostStrideG`
 * Add `mkDelegatee` and `getDRepDelegatee`
 * Depercated `getVoteDelegatee` in favor of `getDRepDelegatee`
 * Add `conwayRegisterInitialFundsThenStaking`

eras/conway/impl/cardano-ledger-conway.cabal

@@ -137,7 +137,6 @@ library testlib
     Test.Cardano.Ledger.Conway.Era
     Test.Cardano.Ledger.Conway.Genesis
     Test.Cardano.Ledger.Conway.GenesisSpec
-    Test.Cardano.Ledger.Conway.GoldenSpec
     Test.Cardano.Ledger.Conway.GovActionReorderSpec
     Test.Cardano.Ledger.Conway.Imp
     Test.Cardano.Ledger.Conway.Imp.BbodySpec
@@ -251,6 +250,7 @@ test-suite tests
   other-modules:
     Paths_cardano_ledger_conway
     Test.Cardano.Ledger.Conway.Binary.CddlSpec
+    Test.Cardano.Ledger.Conway.GoldenSpec
     Test.Cardano.Ledger.Conway.GoldenTranslation
 
   default-language: Haskell2010

eras/conway/impl/src/Cardano/Ledger/Conway/PParams.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DefaultSignatures #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE FlexibleContexts #-}
@@ -9,13 +10,15 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE UndecidableSuperClasses #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
@@ -77,14 +80,13 @@ module Cardano.Ledger.Conway.PParams (
   DRepGroup (..),
   PPGroups (..),
   StakePoolGroup (..),
-  conwayModifiedPPGroups,
   pvtHardForkInitiationL,
   pvtMotionNoConfidenceL,
-  conwayApplyPPUpdates,
   emptyConwayPParams,
   emptyConwayPParamsUpdate,
   asNaturalHKD,
   asBoundedIntegralHKD,
+  ppGroup,
 ) where
 
 import Cardano.Ledger.Alonzo.PParams
@@ -99,12 +101,16 @@ import Cardano.Ledger.Babbage (BabbageEra)
 import Cardano.Ledger.Babbage.Core
 import Cardano.Ledger.Babbage.PParams
 import Cardano.Ledger.BaseTypes (
+  BoundedRational (..),
   EpochInterval (..),
   NonNegativeInterval,
+  NonZero,
+  PositiveInterval,
   ProtVer (ProtVer),
   ToKeyValuePairs (..),
   UnitInterval,
   integralToBounded,
+  knownNonZeroBounded,
   strictMaybeToMaybe,
  )
 import Cardano.Ledger.Binary (
@@ -141,22 +147,31 @@ import Data.Foldable (foldlM)
 import Data.Functor.Identity (Identity)
 import qualified Data.IntMap as IntMap
 import qualified Data.Map.Strict as Map
-import Data.Maybe (mapMaybe)
+import Data.Maybe (fromJust, mapMaybe)
 import Data.Maybe.Strict (StrictMaybe (..))
 import Data.Proxy
 import Data.Set (Set)
 import qualified Data.Set as Set
 import Data.Typeable
 import Data.Word (Word16, Word32)
-import GHC.Generics (Generic)
+import GHC.Generics (Generic (..), K1 (..), M1 (..), (:*:) (..))
 import GHC.Stack (HasCallStack)
-import Lens.Micro
+import Lens.Micro (Lens', SimpleGetter, lens, set, (^.))
+import qualified Lens.Micro as L
 import NoThunks.Class (NoThunks (..))
 import Numeric.Natural (Natural)
 import qualified PlutusLedgerApi.Common as P (Data (..))
 
 class BabbageEraPParams era => ConwayEraPParams era where
   modifiedPPGroups :: PParamsUpdate era -> Set PPGroups
+  default modifiedPPGroups ::
+    forall a.
+    ( Generic (PParamsHKD StrictMaybe era)
+    , CollectModifiedPPGroups (Rep (PParamsHKD StrictMaybe era) a)
+    ) =>
+    PParamsUpdate era ->
+    Set PPGroups
+  modifiedPPGroups (PParamsUpdate ppu) = collectModifiedPPGroups $ from @_ @a ppu
   ppuWellFormed :: ProtVer -> PParamsUpdate era -> Bool
 
   hkdPoolVotingThresholdsL :: HKDFunctor f => Lens' (PParamsHKD f era) (HKD f PoolVotingThresholds)
@@ -169,6 +184,10 @@ class BabbageEraPParams era => ConwayEraPParams era where
   hkdDRepActivityL :: HKDFunctor f => Lens' (PParamsHKD f era) (HKD f EpochInterval)
   hkdMinFeeRefScriptCostPerByteL ::
     HKDFunctor f => Lens' (PParamsHKD f era) (HKD f NonNegativeInterval)
+  ppMaxRefScriptSizePerTxG :: SimpleGetter (PParams era) Word32
+  ppMaxRefScriptSizePerBlockG :: SimpleGetter (PParams era) Word32
+  ppRefScriptCostMultiplierG :: SimpleGetter (PParams era) PositiveInterval
+  ppRefScriptCostStrideG :: SimpleGetter (PParams era) (NonZero Word32)
 
 instance ConwayEraPParams era => ToPlutusData (PParamsUpdate era) where
   toPlutusData ppu = P.Map $ mapMaybe ppToData (eraPParams @era)
@@ -779,6 +798,7 @@ instance EraPParams ConwayEra where
   emptyPParamsIdentity = emptyConwayPParams
   emptyPParamsStrictMaybe = emptyConwayPParamsUpdate
 
+  emptyUpgradePParamsUpdate = emptyConwayUpgradePParamsUpdate
   upgradePParamsHKD = upgradeConwayPParams
   downgradePParamsHKD () = downgradeConwayPParams
 
@@ -798,7 +818,7 @@ instance EraPParams ConwayEra where
   hkdMinPoolCostL = lens (unTHKD . cppMinPoolCost) $ \pp x -> pp {cppMinPoolCost = THKD x}
   ppProtocolVersionL = ppLensHKD . lens cppProtocolVersion (\pp x -> pp {cppProtocolVersion = x})
 
-  ppDG = to (const minBound)
+  ppDG = L.to (const minBound)
   ppuProtocolVersionL = notSupportedInThisEraL
   hkdDL = notSupportedInThisEraL
   hkdExtraEntropyL = notSupportedInThisEraL
@@ -838,6 +858,20 @@ instance EraPParams ConwayEra where
     , ppMinFeeRefScriptCostPerByte
     ]
 
+emptyConwayUpgradePParamsUpdate :: UpgradePParams StrictMaybe ConwayEra
+emptyConwayUpgradePParamsUpdate =
+  UpgradeConwayPParams
+    SNothing
+    SNothing
+    SNothing
+    SNothing
+    SNothing
+    SNothing
+    SNothing
+    SNothing
+    SNothing
+    SNothing
+
 instance AlonzoEraPParams ConwayEra where
   hkdCoinsPerUTxOWordL = notSupportedInThisEraL
   hkdCostModelsL = lens (unTHKD . cppCostModels) $ \pp x -> pp {cppCostModels = THKD x}
@@ -871,7 +905,6 @@ instance BabbageEraPParams ConwayEra where
     lens (unTHKD . cppCoinsPerUTxOByte) $ \pp x -> pp {cppCoinsPerUTxOByte = THKD x}
 
 instance ConwayEraPParams ConwayEra where
-  modifiedPPGroups (PParamsUpdate ppu) = conwayModifiedPPGroups ppu
   ppuWellFormed pv ppu =
     and
       [ -- Numbers
@@ -918,6 +951,10 @@ instance ConwayEraPParams ConwayEra where
     lens (unTHKD . cppDRepActivity) $ \pp x -> pp {cppDRepActivity = THKD x}
   hkdMinFeeRefScriptCostPerByteL =
     lens (unTHKD . cppMinFeeRefScriptCostPerByte) $ \pp x -> pp {cppMinFeeRefScriptCostPerByte = THKD x}
+  ppMaxRefScriptSizePerTxG = L.to . const $ 200 * 1024
+  ppMaxRefScriptSizePerBlockG = L.to . const $ 1024 * 1024
+  ppRefScriptCostMultiplierG = L.to . const . fromJust $ boundRational 1.2
+  ppRefScriptCostStrideG = L.to . const $ knownNonZeroBounded @25_600
 
 -- | Returns a basic "empty" `PParams` structure with all zero values.
 emptyConwayPParams :: forall era. Era era => ConwayPParams Identity era
@@ -1173,73 +1210,30 @@ conwayApplyPPUpdates pp ppu =
         THKD SNothing -> cppGet pp
         THKD (SJust ppNewValue) -> THKD ppNewValue
 
-conwayModifiedPPGroups :: ConwayPParams StrictMaybe era -> Set PPGroups
-conwayModifiedPPGroups
-  ( ConwayPParams
-      p01
-      p02
-      p03
-      p04
-      p05
-      p06
-      p07
-      p08
-      p09
-      p10
-      p11
-      p12
-      _protocolVersion
-      p14
-      p15
-      p16
-      p17
-      p18
-      p19
-      p20
-      p21
-      p22
-      p23
-      p24
-      p25
-      p26
-      p27
-      p28
-      p29
-      p30
-      p31
-    ) =
-    mconcat
-      [ ppGroup p01
-      , ppGroup p02
-      , ppGroup p03
-      , ppGroup p04
-      , ppGroup p05
-      , ppGroup p06
-      , ppGroup p07
-      , ppGroup p08
-      , ppGroup p09
-      , ppGroup p10
-      , ppGroup p11
-      , ppGroup p12
-      , ppGroup p14
-      , ppGroup p15
-      , ppGroup p16
-      , ppGroup p17
-      , ppGroup p18
-      , ppGroup p19
-      , ppGroup p20
-      , ppGroup p21
-      , ppGroup p22
-      , ppGroup p23
-      , ppGroup p24
-      , ppGroup p25
-      , ppGroup p26
-      , ppGroup p27
-      , ppGroup p28
-      , ppGroup p29
-      , ppGroup p30
-      , ppGroup p31
-      ]
+class CollectModifiedPPGroups x where
+  collectModifiedPPGroups :: x -> Set PPGroups
+
+instance
+  ( CollectModifiedPPGroups (x u)
+  , CollectModifiedPPGroups (y u)
+  ) =>
+  CollectModifiedPPGroups ((x :*: y) u)
+  where
+  collectModifiedPPGroups (x :*: y) = collectModifiedPPGroups x <> collectModifiedPPGroups y
+
+instance
+  ( ToDRepGroup g
+  , ToStakePoolGroup h
+  ) =>
+  CollectModifiedPPGroups (K1 i (THKD ('PPGroups g h) StrictMaybe a) p)
+  where
+  collectModifiedPPGroups (K1 x) = ppGroup x
+
+instance CollectModifiedPPGroups (K1 i (NoUpdate a) p) where
+  collectModifiedPPGroups _ = mempty
+
+instance CollectModifiedPPGroups (a u) => CollectModifiedPPGroups (M1 i c a u) where
+  collectModifiedPPGroups (M1 x) = collectModifiedPPGroups x
 
 -- | Care should be taken to not apply this function to signed values, otherwise it will result in
 -- an `ArithmeticUnderflow` exception for negative numbers.

eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Bbody.hs

@@ -19,7 +19,6 @@
 module Cardano.Ledger.Conway.Rules.Bbody (
   ConwayBBODY,
   ConwayBbodyPredFailure (..),
-  maxRefScriptSizePerBlock,
   alonzoToConwayBbodyPredFailure,
   shelleyToConwayBbodyPredFailure,
   totalRefScriptSizeInBlock,
@@ -56,6 +55,7 @@ import Cardano.Ledger.Binary (DecCBOR (..), EncCBOR (..))
 import Cardano.Ledger.Binary.Coders (Decode (..), Encode (..), decode, encode, (!>), (<!))
 import Cardano.Ledger.Block (Block (..))
 import Cardano.Ledger.Conway.Era (ConwayBBODY, ConwayEra)
+import Cardano.Ledger.Conway.PParams (ConwayEraPParams (..))
 import Cardano.Ledger.Conway.Rules.Cert (ConwayCertPredFailure)
 import Cardano.Ledger.Conway.Rules.Certs (ConwayCertsPredFailure)
 import Cardano.Ledger.Conway.Rules.Deleg (ConwayDelegPredFailure)
@@ -97,16 +97,11 @@ import Data.Monoid (Sum (getSum))
 import qualified Data.Monoid as Monoid (Sum (..))
 import Data.Sequence (Seq)
 import Data.Sequence.Strict (StrictSeq (..))
+import Data.Word (Word32)
 import GHC.Generics (Generic)
 import Lens.Micro
 import NoThunks.Class (NoThunks (..))
 
--- | In the next era this will become a proper protocol parameter.
--- For now this is a hard coded limit on the total number of bytes of all reference scripts
--- combined from all transactions within a block.
-maxRefScriptSizePerBlock :: Int
-maxRefScriptSizePerBlock = 1024 * 1024 -- 1MiB
-
 data ConwayBbodyPredFailure era
   = WrongBlockBodySizeBBODY (Mismatch 'RelEQ Int)
   | InvalidBodyHashBBODY (Mismatch 'RelEQ (Hash HASH EraIndependentBlockBody))
@@ -258,6 +253,7 @@ instance
   , EraRule "BBODY" era ~ ConwayBBODY era
   , AlonzoEraTx era
   , BabbageEraTxBody era
+  , ConwayEraPParams era
   ) =>
   STS (ConwayBBODY era)
   where
@@ -288,6 +284,7 @@ conwayBbodyTransition ::
   , AlonzoEraTx era
   , EraBlockBody era
   , BabbageEraTxBody era
+  , ConwayEraPParams era
   ) =>
   TransitionRule (EraRule "BBODY" era)
 conwayBbodyTransition = do
@@ -301,6 +298,7 @@ conwayBbodyTransition = do
         let utxo = utxosUtxo (lsUTxOState ls)
             txs = txsSeq ^. txSeqBlockBodyL
             totalRefScriptSize = totalRefScriptSizeInBlock (pp ^. ppProtocolVersionL) txs utxo
+            maxRefScriptSizePerBlock = fromIntegral @Word32 @Int $ pp ^. ppMaxRefScriptSizePerBlockG
         totalRefScriptSize
           <= maxRefScriptSizePerBlock
             ?! injectFailure