Skip to content

Commit

Permalink
Add PlutusV3 CostModel to UpgradeConwayPParams
Browse files Browse the repository at this point in the history
Use `updateCostModels` to add them to Conway
PParams during tranlation/upgrade from Babbage
  • Loading branch information
aniketd committed Apr 16, 2024
1 parent 8193b4a commit c236b69
Show file tree
Hide file tree
Showing 14 changed files with 262 additions and 157 deletions.
11 changes: 10 additions & 1 deletion eras/conway/impl/CHANGELOG.md
@@ -1,8 +1,17 @@
# Version history for `cardano-ledger-conway`

## 1.14.0 0

* Add `ucppPlutusV3CostModel` to `UpgradeConwayPParams`. #4252
* Remove the `Default` instance for `ConwayGenesis`.
* Add `foldrVotingProcedures`.

### `testlib`

* Updated `exampleConwayGenesis` to `conway-genesis.json`. #4252

## 1.13.1.0

* Add `foldrVotingProcedures`
* Fix typo in `ToJSON` instance of `ConwayGovState`

### `testlib`
Expand Down
6 changes: 3 additions & 3 deletions eras/conway/impl/cardano-ledger-conway.cabal
@@ -1,6 +1,6 @@
cabal-version: 3.0
name: cardano-ledger-conway
version: 1.13.1.0
version: 1.14.0.0
license: Apache-2.0
maintainer: operations@iohk.io
author: IOHK
Expand Down Expand Up @@ -90,7 +90,7 @@ library
cardano-ledger-allegra ^>=1.4,
cardano-ledger-alonzo ^>=1.8,
cardano-ledger-babbage ^>=1.8,
cardano-ledger-core ^>=1.11,
cardano-ledger-core ^>=1.11.1,
cardano-ledger-mary ^>=1.5,
cardano-ledger-shelley ^>=1.10,
cardano-slotting,
Expand Down Expand Up @@ -126,6 +126,7 @@ library testlib
Test.Cardano.Ledger.Conway.Imp.RatifySpec
Test.Cardano.Ledger.Conway.Proposals
Test.Cardano.Ledger.Conway.TreeDiff
Test.Cardano.Ledger.Conway.Genesis

visibility: public
hs-source-dirs: testlib
Expand Down Expand Up @@ -183,7 +184,6 @@ test-suite tests
build-depends:
aeson,
base,
cardano-data,
cardano-ledger-core:testlib,
cardano-ledger-allegra,
cardano-ledger-alonzo:testlib,
Expand Down
4 changes: 0 additions & 4 deletions eras/conway/impl/src/Cardano/Ledger/Conway/Genesis.hs
Expand Up @@ -39,7 +39,6 @@ import Data.Aeson (
(.:),
(.:?),
)
import Data.Default.Class (Default (def))
import Data.Functor.Identity (Identity)
import Data.ListMap (ListMap)
import GHC.Generics (Generic)
Expand Down Expand Up @@ -98,6 +97,3 @@ toConwayGenesisPairs cg@(ConwayGenesis _ _ _ _ _) =
++ ["delegs" .= cgDelegs | not (null cgDelegs)]
++ ["initialDReps" .= cgInitialDReps | not (null cgInitialDReps)]
++ toUpgradeConwayPParamsUpdatePairs cgUpgradePParams

instance Crypto c => Default (ConwayGenesis c) where
def = ConwayGenesis def def def mempty mempty
53 changes: 35 additions & 18 deletions eras/conway/impl/src/Cardano/Ledger/Conway/PParams.hs
Expand Up @@ -100,14 +100,29 @@ import Cardano.Ledger.Coin (Coin (Coin))
import Cardano.Ledger.Conway.Era (ConwayEra)
import Cardano.Ledger.Core (EraPParams (..))
import Cardano.Ledger.Crypto
import Cardano.Ledger.HKD (HKD, HKDFunctor (..), HKDNoUpdate, NoUpdate (..))
import Cardano.Ledger.Plutus.CostModels (decodeValidAndUnknownCostModels)
import Cardano.Ledger.HKD (
HKD,
HKDApplicative (hkdLiftA2),
HKDFunctor (..),
HKDNoUpdate,
NoUpdate (..),
)
import Cardano.Ledger.Plutus.CostModels (
CostModel,
decodeCostModelFailHard,
decodeValidAndUnknownCostModels,
encodeCostModel,
mkCostModel,
mkCostModels,
)
import Cardano.Ledger.Plutus.Language (Language (PlutusV3))
import Cardano.Ledger.Val (Val (..))
import Control.DeepSeq (NFData (..), rwhnf)
import Data.Aeson hiding (Encoding, Value, decode, encode)
import qualified Data.Aeson as Aeson
import Data.Default.Class (Default (def))
import Data.Functor.Identity (Identity)
import qualified Data.Map.Strict as Map
import Data.Maybe.Strict (StrictMaybe (..), isSNothing)
import Data.Proxy
import Data.Set (Set)
Expand Down Expand Up @@ -580,6 +595,7 @@ data UpgradeConwayPParams f = UpgradeConwayPParams
, ucppDRepDeposit :: !(HKD f Coin)
, ucppDRepActivity :: !(HKD f EpochInterval)
, ucppMinFeeRefScriptCostPerByte :: !(HKD f NonNegativeInterval)
, ucppPlutusV3CostModel :: !(HKD f CostModel)
}
deriving (Generic)

Expand All @@ -603,20 +619,6 @@ instance NoThunks (UpgradeConwayPParams StrictMaybe)

instance NFData (UpgradeConwayPParams StrictMaybe)

instance Default (UpgradeConwayPParams Identity) where
def =
UpgradeConwayPParams
{ ucppPoolVotingThresholds = def
, ucppDRepVotingThresholds = def
, ucppCommitteeMinSize = 0
, ucppCommitteeMaxTermLength = EpochInterval 0
, ucppGovActionLifetime = EpochInterval 0
, ucppGovActionDeposit = Coin 0
, ucppDRepDeposit = Coin 0
, ucppDRepActivity = EpochInterval 0
, ucppMinFeeRefScriptCostPerByte = minBound
}

instance Default (UpgradeConwayPParams StrictMaybe) where
def =
UpgradeConwayPParams
Expand All @@ -629,6 +631,7 @@ instance Default (UpgradeConwayPParams StrictMaybe) where
, ucppDRepDeposit = SNothing
, ucppDRepActivity = SNothing
, ucppMinFeeRefScriptCostPerByte = SNothing
, ucppPlutusV3CostModel = SNothing
}

instance EncCBOR (UpgradeConwayPParams Identity) where
Expand All @@ -644,6 +647,7 @@ instance EncCBOR (UpgradeConwayPParams Identity) where
!> To ucppDRepDeposit
!> To ucppDRepActivity
!> To ucppMinFeeRefScriptCostPerByte
!> E encodeCostModel ucppPlutusV3CostModel

instance DecCBOR (UpgradeConwayPParams Identity) where
decCBOR =
Expand All @@ -658,6 +662,7 @@ instance DecCBOR (UpgradeConwayPParams Identity) where
<! From
<! From
<! From
<! D (decodeCostModelFailHard PlutusV3)

instance Crypto c => EraPParams (ConwayEra c) where
type PParamsHKD f (ConwayEra c) = ConwayPParams f (ConwayEra c)
Expand Down Expand Up @@ -1144,6 +1149,7 @@ upgradeConwayPParamsHKDPairs UpgradeConwayPParams {..} =
, ("dRepDeposit", (toJSON @Coin) ucppDRepDeposit)
, ("dRepActivity", (toJSON @EpochInterval) ucppDRepActivity)
, ("minFeeRefScriptCostPerByte", (toJSON @NonNegativeInterval) ucppMinFeeRefScriptCostPerByte)
, ("plutusV3CostModel", (toJSON @CostModel) ucppPlutusV3CostModel)
]

instance FromJSON (UpgradeConwayPParams Identity) where
Expand All @@ -1159,10 +1165,11 @@ instance FromJSON (UpgradeConwayPParams Identity) where
<*> o .: "dRepDeposit"
<*> o .: "dRepActivity"
<*> o .: "minFeeRefScriptCostPerByte"
<*> (either (fail . show) pure . mkCostModel PlutusV3 =<< o .: "plutusV3CostModel")

upgradeConwayPParams ::
forall f c.
HKDFunctor f =>
HKDApplicative f =>
UpgradeConwayPParams f ->
PParamsHKD f (BabbageEra c) ->
ConwayPParams f (ConwayEra c)
Expand All @@ -1183,7 +1190,17 @@ upgradeConwayPParams UpgradeConwayPParams {..} BabbagePParams {..} =
, cppProtocolVersion = toNoUpdate @f @ProtVer bppProtocolVersion
, cppMinPoolCost = THKD bppMinPoolCost
, cppCoinsPerUTxOByte = THKD bppCoinsPerUTxOByte
, cppCostModels = THKD bppCostModels
, cppCostModels =
THKD $
-- We add the PlutusV3 CostModel from ConwayGenesis to the ConwayPParams here
hkdLiftA2 @f
updateCostModels
bppCostModels
( hkdMap
(Proxy @f)
(mkCostModels . Map.singleton PlutusV3)
ucppPlutusV3CostModel
)
, cppPrices = THKD bppPrices
, cppMaxTxExUnits = THKD bppMaxTxExUnits
, cppMaxBlockExUnits = THKD bppMaxBlockExUnits
Expand Down
151 changes: 33 additions & 118 deletions eras/conway/impl/test/Test/Cardano/Ledger/Conway/GenesisSpec.hs
@@ -1,141 +1,56 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Test.Cardano.Ledger.Conway.GenesisSpec (spec) where
module Test.Cardano.Ledger.Conway.GenesisSpec (spec, expectedConwayGenesis) where

import Cardano.Ledger.BaseTypes (textToUrl)
import Cardano.Ledger.CertState (DRep (..), DRepState (..))
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Conway
import Cardano.Ledger.Conway.Genesis (ConwayGenesis (..))
import Cardano.Ledger.Conway.Governance (Anchor (..), Committee (..))
import Cardano.Ledger.Conway.TxCert (Delegatee (..))
import Cardano.Ledger.Core
import Cardano.Ledger.Credential
import Cardano.Ledger.Crypto (StandardCrypto)
import Cardano.Ledger.Keys
import Cardano.Ledger.Slot (EpochNo (..))
import Cardano.Ledger.Babbage (Babbage)
import Cardano.Ledger.Conway (Conway)
import Cardano.Ledger.Conway.Core
import Cardano.Ledger.Conway.PParams
import Cardano.Ledger.Plutus.CostModels (costModelsValid)
import Cardano.Ledger.Plutus.Language (Language (PlutusV3))
import Data.Aeson hiding (Encoding)
import Data.Default.Class (Default (def))
import qualified Data.ListMap as ListMap
import Data.Map as Map
import Data.Maybe (fromJust)
import Data.Maybe.Strict (StrictMaybe (..))
import Data.Ratio ((%))
import Data.Functor.Identity (Identity)
import qualified Data.Map.Strict as Map
import Lens.Micro
import Paths_cardano_ledger_conway (getDataFileName)
import Test.Cardano.Ledger.Common
import Test.Cardano.Ledger.Core.Utils (unsafeBoundRational)
import Test.Cardano.Ledger.Conway.Genesis (expectedConwayGenesis)
import Test.Cardano.Slotting.Numeric ()

spec :: Spec
spec = do
describe "Genesis Golden Spec" $ do
goldenConwayGenesisJSON
describe "ConwayGenesis" $ do
describe "Golden Spec" goldenConwayGenesisJSON
prop "Upgrades" propConwayPParamsUpgrade

fileName :: String
fileName = "test/data/conway-genesis.json"

goldenConwayGenesisJSON :: Spec
goldenConwayGenesisJSON =
it "should deserialize to the default value" $ do
let fileName = "test/data/conway-genesis.json"
credMember =
KeyHashObj
(KeyHash "4e88cc2d27c364aaf90648a87dfb95f8ee103ba67fa1f12f5e86c42a") ::
Credential 'ColdCommitteeRole StandardCrypto
scriptMember =
ScriptHashObj
(ScriptHash "4e88cc2d27c364aaf90648a87dfb95f8ee103ba67fa1f12f5e86c42a") ::
Credential 'ColdCommitteeRole StandardCrypto
comm =
Committee
( Map.fromList
[
( credMember
, EpochNo 1
)
,
( scriptMember
, EpochNo 2
)
]
)
(unsafeBoundRational (1 % 2)) ::
Committee Conway
file <- getDataFileName fileName
dec <- eitherDecodeFileStrict' file
cg <- case dec of
Left err -> error ("Failed to deserialize JSON: " ++ err)
Right x -> pure x
let
expectedCg =
def
{ cgCommittee = comm
, cgInitialDReps =
ListMap.fromList
[
( KeyHashObj
(KeyHash "78301005df84ba67fa1f12f95f8ee10335bc5e86c42afbc593ab4cdd")
, DRepState
{ drepExpiry = 1000
, drepAnchor = SNothing
, drepDeposit = Coin 5000
}
)
,
( ScriptHashObj
(ScriptHash "01305df84b078ac5e86c42afbc593ab4cdd67fa1f12f95f8ee10335b")
, DRepState
{ drepExpiry = 300
, drepAnchor =
SJust $
Anchor
{ anchorUrl = fromJust $ textToUrl 99 "example.com"
, anchorDataHash = def
}
, drepDeposit = Coin 6000
}
)
]
, cgDelegs =
ListMap.fromList
[
( KeyHashObj
(KeyHash "35bc5e86c42afbc593ab4cdd78301005df84ba67fa1f12f95f8ee103")
, DelegVote DRepAlwaysNoConfidence
)
,
( KeyHashObj
(KeyHash "4e88cc2d27c364aaf90648a87dfb95f8ee103ba67fa1f12f5e86c42a")
, DelegVote DRepAlwaysAbstain
)
,
( KeyHashObj
(KeyHash "5df84bcdd7a5f8ee93aafbc500b435bc5e83067fa1f12f9110386c42")
, DelegStake $ KeyHash "0335bc5e86c42afbc578301005df84ba67fa1f12f95f8ee193ab4cdd"
)
,
( KeyHashObj
(KeyHash "8ee93a5df84bc42cdd7a5fafbc500b435bc5e83067fa1f12f9110386")
, DelegStakeVote
(KeyHash "086c42afbc578301005df84ba67fa1f12f95f8ee193ab4cdd335bc5e")
DRepAlwaysAbstain
)
,
( KeyHashObj
(KeyHash "df93ab435bc5eafbc500583067fa1f12f9110386c42cdd784ba5f8ee")
, DelegVote $
DRepCredential
(ScriptHashObj (ScriptHash "01305df84b078ac5e86c42afbc593ab4cdd67fa1f12f95f8ee10335b"))
)
,
( ScriptHashObj
(ScriptHash "afbc5005df84ba5f8ee93ab435bc5e83067fa1f12f9c42cdd7110386")
, DelegVote $
DRepCredential
(KeyHashObj (KeyHash "78301005df84ba67fa1f12f95f8ee10335bc5e86c42afbc593ab4cdd"))
)
]
}
cg `shouldBe` expectedCg
cg `shouldBe` expectedConwayGenesis

propConwayPParamsUpgrade :: UpgradeConwayPParams Identity -> PParams Babbage -> Property
propConwayPParamsUpgrade ppu pp = property $ do
let pp' = upgradePParams ppu pp :: PParams Conway
pp' ^. ppPoolVotingThresholdsL `shouldBe` ucppPoolVotingThresholds ppu
pp' ^. ppDRepVotingThresholdsL `shouldBe` ucppDRepVotingThresholds ppu
pp' ^. ppCommitteeMinSizeL `shouldBe` ucppCommitteeMinSize ppu
pp' ^. ppCommitteeMaxTermLengthL `shouldBe` ucppCommitteeMaxTermLength ppu
pp' ^. ppGovActionLifetimeL `shouldBe` ucppGovActionLifetime ppu
pp' ^. ppGovActionDepositL `shouldBe` ucppGovActionDeposit ppu
pp' ^. ppDRepDepositL `shouldBe` ucppDRepDeposit ppu
pp' ^. ppDRepActivityL `shouldBe` ucppDRepActivity ppu
pp' ^. ppMinFeeRefScriptCostPerByteL `shouldBe` ucppMinFeeRefScriptCostPerByte ppu
Map.lookup PlutusV3 (costModelsValid (pp' ^. ppCostModelsL))
`shouldBe` Just (ucppPlutusV3CostModel ppu)
1 change: 1 addition & 0 deletions eras/conway/impl/test/data/conway-genesis.json
Expand Up @@ -25,6 +25,7 @@
"dRepDeposit": 0,
"dRepActivity": 0,
"minFeeRefScriptCostPerByte": 0,
"plutusV3CostModel": [0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0],
"constitution": {
"anchor": {
"url": "",
Expand Down
Expand Up @@ -51,6 +51,7 @@ import Cardano.Ledger.Conway.TxCert
import Cardano.Ledger.Conway.TxInfo (ConwayContextError)
import Cardano.Ledger.Crypto (Crypto)
import Cardano.Ledger.HKD (HKD, NoUpdate (..))
import Cardano.Ledger.Plutus (Language (PlutusV3))
import Control.State.Transition.Extended (STS (Event))
import Data.Default.Class (def)
import Data.Foldable (toList)
Expand All @@ -67,6 +68,7 @@ import Test.Cardano.Data (genNonEmptyMap)
import Test.Cardano.Data.Arbitrary ()
import Test.Cardano.Ledger.Alonzo.Arbitrary (
genValidAndUnknownCostModels,
genValidCostModel,
unFlexibleCostModels,
)
import Test.Cardano.Ledger.Babbage.Arbitrary ()
Expand Down Expand Up @@ -116,6 +118,7 @@ instance Arbitrary (UpgradeConwayPParams Identity) where
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> genValidCostModel PlutusV3

instance Crypto c => Arbitrary (Delegatee c) where
arbitrary =
Expand Down

0 comments on commit c236b69

Please sign in to comment.