diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Genesis.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Genesis.hs index 55afa869f57..22fb17e4229 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Genesis.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Genesis.hs @@ -50,6 +50,7 @@ import Cardano.Ledger.Binary.Coders ( ) import Cardano.Ledger.Core import Cardano.Ledger.Genesis (EraGenesis (..)) +import Cardano.Ledger.Plutus.CostModels (parseCostModels) import Control.DeepSeq (NFData) import Data.Aeson (FromJSON (..), ToJSON (..), (.:), (.=)) import qualified Data.Aeson as Aeson @@ -171,7 +172,7 @@ instance ToCBOR AlonzoGenesis where instance FromJSON AlonzoGenesis where parseJSON = Aeson.withObject "Alonzo Genesis" $ \o -> do agCoinsPerUTxOWord <- o .: "lovelacePerUTxOWord" - agCostModels <- o .: "costModels" + agCostModels <- parseCostModels False =<< o .: "costModels" agPrices <- o .: "executionPrices" agMaxTxExUnits <- o .: "maxTxExUnits" agMaxBlockExUnits <- o .: "maxBlockExUnits" diff --git a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Binary/CostModelsSpec.hs b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Binary/CostModelsSpec.hs index f372546fa90..cf5f1c97415 100644 --- a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Binary/CostModelsSpec.hs +++ b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Binary/CostModelsSpec.hs @@ -57,7 +57,7 @@ validCostModelProp = do ppuRes <- expectRight ppuDecoded ppuRes `shouldSatisfy` \ppu -> (validCm <$> ppu ^. ppuCostModelsL) == SJust True where - genValidCostModelEnc lang = genCostModelEncForLanguage lang (costModelParamsCount lang) + genValidCostModelEnc lang = genCostModelEncForLanguage lang (costModelInitParamCount lang) validCm cms = not (null (costModelsValid cms)) && null (costModelsUnknown cms) @@ -84,7 +84,7 @@ underspecifiedCostModelProp = do cmRes `shouldSatisfy` not . null . costModelsValid where genUnderspecifiedCostModelEnc lang = do - let validCount = costModelParamsCount lang + let validCount = costModelInitParamCount lang count <- choose (0, validCount - 1) genCostModelEncForLanguage lang count diff --git a/eras/conway/impl/golden/pparams-update.json b/eras/conway/impl/golden/pparams-update.json index 95a55f02ef3..5e055bdfbf4 100644 --- a/eras/conway/impl/golden/pparams-update.json +++ b/eras/conway/impl/golden/pparams-update.json @@ -233,7 +233,27 @@ -962328041173442759, -4075615882692725743, -3352890667792537221, - 6875093762849820680 + 6875093762849820680, + -6602342814594595381, + 5951863540083319718, + -9200808190774891816, + -3949262931707447679, + -4457084894721383071, + -9165687560670498575, + 5292299755808348356, + 6269357501932927815, + -6707589547320281809, + -304719936039206445, + 3393469372630712782, + -7997979798890445295, + -8267055408668194327, + 1496797700699732113, + -4758699786657820125, + 8231926240690839101, + 8516908119870936999, + -6261418126182035165, + 7651136103253405349, + -6472673752314266831 ], "Unknown": { "10": [ diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/PParams.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/PParams.hs index 94ab46d07a2..b6a9e84adda 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/PParams.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/PParams.hs @@ -135,8 +135,8 @@ import Cardano.Ledger.Plutus.CostModels ( CostModel, decodeCostModel, encodeCostModel, - mkCostModel, mkCostModels, + parseCostModelAsArray, ) import Cardano.Ledger.Plutus.Language (Language (PlutusV3)) import Cardano.Ledger.Plutus.ToPlutusData (ToPlutusData (..)) @@ -1079,7 +1079,7 @@ instance FromJSON (UpgradeConwayPParams Identity) where <*> o .: "dRepDeposit" <*> o .: "dRepActivity" <*> o .: "minFeeRefScriptCostPerByte" - <*> (either (fail . show) pure . mkCostModel PlutusV3 =<< o .: "plutusV3CostModel") + <*> (parseCostModelAsArray False PlutusV3 =<< o .: "plutusV3CostModel") upgradeConwayPParams :: forall f. diff --git a/eras/conway/impl/test/data/conway-genesis.json b/eras/conway/impl/test/data/conway-genesis.json index 0e6ff170ee5..08e1aed42a3 100644 --- a/eras/conway/impl/test/data/conway-genesis.json +++ b/eras/conway/impl/test/data/conway-genesis.json @@ -25,7 +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], + "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,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0], "constitution": { "anchor": { "url": "", diff --git a/libs/cardano-ledger-core/CHANGELOG.md b/libs/cardano-ledger-core/CHANGELOG.md index 492c946e318..ead0e468aca 100644 --- a/libs/cardano-ledger-core/CHANGELOG.md +++ b/libs/cardano-ledger-core/CHANGELOG.md @@ -2,6 +2,8 @@ ## 1.18.0.0 +* Deprecate `costModelParamsCount` in favor of `costModelInitParamCount` +* Add `costModelInitParamNames`, `costModelInitParamCount`, `parseCostModelAsArray` and `parseCostModelAsMap` * Export `credToDRep` and `dRepToCred` * Deprecate `PoolParams` in favor of `StakePoolState`. #5196 * Move the `PoolParams` module to `Cardano.Ledger.State.StakePool` and export from there. diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/Plutus/CostModels.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/Plutus/CostModels.hs index f97e41a3654..2a9ece9b4a4 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/Plutus/CostModels.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/Plutus/CostModels.hs @@ -1,21 +1,13 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} module Cardano.Ledger.Plutus.CostModels ( @@ -33,12 +25,17 @@ module Cardano.Ledger.Plutus.CostModels ( costModelFromMap, costModelParamsCount, decodeCostModel, + costModelInitParamNames, + costModelInitParamCount, + parseCostModelAsMap, + parseCostModelAsArray, -- * Cost Models CostModels, mkCostModels, emptyCostModels, updateCostModels, + parseCostModels, decodeCostModelsLenient, decodeCostModelsFailing, costModelsValid, @@ -63,9 +60,10 @@ import Cardano.Ledger.Plutus.Language ( nonNativeLanguages, ) import Control.DeepSeq (NFData (..), deepseq) -import Control.Monad (forM, when) +import Control.Monad (forM, unless, when) import Control.Monad.Trans.Writer (WriterT (runWriterT)) import Data.Aeson ( + Array, FromJSON (..), Object, ToJSON (..), @@ -137,36 +135,72 @@ instance NFData CostModel where rnf (CostModel lang cm ectx) = lang `deepseq` cm `deepseq` rnf ectx instance FromJSON CostModels where - parseJSON = withObject "CostModels" $ \o -> do - cms <- mapM (parseCostModel o) nonNativeLanguages + parseJSON = parseCostModels True + +parseCostModels :: + -- | Do not restrict number of parameters to the initial count and allow parsing of cost models + -- for unknown plutus versions. + Bool -> + Value -> + Parser CostModels +parseCostModels isLenient = + withObject "CostModels" $ \o -> do + cms <- mapM (parseCostModel isLenient o) nonNativeLanguages let cmsMap = Map.fromList [(cmLanguage cm, cm) | Just cm <- cms] - unknown <- o .:? "Unknown" .!= mempty - unknownCostModels <- mkCostModelsLenient unknown + unknownCostModels <- + if isLenient + then do + unknown <- o .:? "Unknown" .!= mempty + mkCostModelsLenient unknown + else + pure mempty pure $ mkCostModels cmsMap <> unknownCostModels --- | The costmodel parameters in Alonzo Genesis are represented as a map. Plutus API does --- no longer require the map as a parameter to `mkEvaluationContext`, but the list of --- integers representing the values of the map. The expectation on this list of integers --- is that they are sorted in the order given by the `ParamName` enum, so even though we --- just have to pass the list to plutus, we still need to use the names of the parameters --- in order to sort the list. In new versions, we want to represent the costmodel --- parameters directly as a list, so we can avoid this reordering. -parseCostModel :: Object -> Language -> Parser (Maybe CostModel) -parseCostModel o lang = do +-- | The costmodel parameters in Alonzo Genesis are represented as a map. Plutus API does no longer +-- require the map as a parameter to `mkEvaluationContext`, but the list of integers representing +-- the values of the map. The expectation on this list of integers is that they are sorted in the +-- order given by the `ParamName` enum, so even though we just have to pass the list to plutus, we +-- still need to use the names of the parameters in order to sort the list. In new versions, we +-- represent the costmodel parameters directly as a list, so we can avoid this reordering. +parseCostModel :: Bool -> Object -> Language -> Parser (Maybe CostModel) +parseCostModel isLenient o lang = do plutusCostModelValueMaybe <- o .:? fromString (show lang) forM plutusCostModelValueMaybe $ \plutusCostModelValue -> case plutusCostModelValue of - Object _ -> costModelFromMap lang =<< parseJSON plutusCostModelValue - Array _ -> validateCostModel lang =<< parseJSON plutusCostModelValue + Object m -> parseCostModelAsMap isLenient lang m + Array a -> parseCostModelAsArray isLenient lang a _ -> fail $ "Expected either an Array or an Object, but got: " ++ show plutusCostModelValue +parseCostModelAsMap :: Bool -> Language -> Object -> Parser CostModel +parseCostModelAsMap isLenient lang m = do + costModel <- costModelFromMap lang =<< parseJSON (Object m) + unless isLenient $ guardNumberOfParameters lang m + pure costModel + +parseCostModelAsArray :: Bool -> Language -> Array -> Parser CostModel +parseCostModelAsArray isLenient lang a = do + costModel <- validateCostModel lang =<< parseJSON (Array a) + unless isLenient $ guardNumberOfParameters lang a + pure costModel + +guardNumberOfParameters :: (Foldable f, MonadFail m) => Language -> f a -> m () +guardNumberOfParameters lang ps = + let suppliedParameterCount = length ps + expectedParameterCount = costModelInitParamCount lang + in unless (suppliedParameterCount == expectedParameterCount) $ + fail $ + "Number of parameters supplied " + <> show suppliedParameterCount + <> " does not match the expected number of " + <> show expectedParameterCount + costModelFromMap :: MonadFail m => Language -> Map Text Int64 -> m CostModel costModelFromMap lang cmMap = either (fail . unlines . (header :) . NE.toList) (validateCostModel lang) $ validationToEither (traverse lookupFail paramNames) where header = "Cost model language: " ++ show lang - paramNames = costModelParamNames lang + paramNames = costModelInitParamNames lang lookupFail paramName = case Map.lookup paramName cmMap of Nothing -> failure $ " Parameter name missing from cost model: " ++ show paramName @@ -180,6 +214,24 @@ costModelParamNames :: Language -> [Text] costModelParamNames PlutusV1 = plutusV1ParamNames costModelParamNames lang = plutusVXParamNames lang +-- | List of parameter names as when they were introduced upon a hard fork to a specific era for a +-- corresponding plutus version. +costModelInitParamNames :: Language -> [Text] +costModelInitParamNames lang = take (costModelInitParamCount lang) $ costModelParamNames lang + +-- | Number of `CostModel` parameters for a specified plutus version as when it was initially +-- added. This is useful for genesis files, which shouldn't have the number of parameters vary over +-- time. +costModelInitParamCount :: Language -> Int +costModelInitParamCount lang = + case lang of + PlutusV1 -> 166 + PlutusV2 -> 175 + PlutusV3 -> 251 + PlutusV4 -> + -- This number will continue to change until we are ready to hard fork into Dijkstra era + 251 + -- | There is a difference in 6 parameter names between the ones appearing alonzo genesis -- files and the values returned by plutus via `P.showParamName` on the `ParamName` enum. -- This listed is sorted in the order given by `ParamName` enum, so we can use it to sort @@ -264,6 +316,10 @@ costModelParamsCount PlutusV1 = 166 costModelParamsCount PlutusV2 = 175 costModelParamsCount PlutusV3 = 231 costModelParamsCount PlutusV4 = 231 +{-# DEPRECATED + costModelParamsCount + "Deprecated in favor of `costModelInitParamCount`, since this function provided an incorrect value of 231 for PlutusV3, where it should have been 251" + #-} decodeCostModelLegacy :: Language -> Decoder s CostModel decodeCostModelLegacy lang = do @@ -272,7 +328,7 @@ decodeCostModelLegacy lang = do "Legacy CostModel decoding is not supported for " ++ show lang ++ " language version" values <- decCBOR let numValues = length values - expectedNumValues = costModelParamsCount lang + expectedNumValues = costModelInitParamCount lang when (numValues /= expectedNumValues) $ fail $ "Expected array with " diff --git a/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Core/Arbitrary.hs b/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Core/Arbitrary.hs index 13756a1c049..39457132527 100644 --- a/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Core/Arbitrary.hs +++ b/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Core/Arbitrary.hs @@ -86,7 +86,7 @@ import Cardano.Ledger.Keys (BootstrapWitness (..), ChainCode (..), VKey (..), Wi import Cardano.Ledger.Plutus.CostModels ( CostModel, CostModels, - costModelParamsCount, + costModelInitParamCount, mkCostModel, mkCostModels, mkCostModelsLenient, @@ -910,7 +910,7 @@ instance Arbitrary PV1.Data where genValidCostModel :: Language -> Gen CostModel genValidCostModel lang = do - newParamValues <- vectorOf (costModelParamsCount lang) arbitrary + newParamValues <- vectorOf (costModelInitParamCount lang) arbitrary either (\err -> error $ "Corrupt cost model: " ++ show err) pure $ mkCostModel lang newParamValues @@ -953,14 +953,14 @@ genUnknownCostModelValues = do genCostModelValues :: Language -> Gen (Word8, [Int64]) genCostModelValues lang = do Positive sub <- arbitrary - (,) lang' + (,) langWord8 <$> oneof - [ listAtLeast (costModelParamsCount lang) -- Valid Cost Model for known language + [ listAtLeast (costModelInitParamCount lang) -- Valid Cost Model for known language , take (tooFew sub) <$> arbitrary -- Invalid Cost Model for known language ] where - lang' = fromIntegral (fromEnum lang) - tooFew sub = costModelParamsCount lang - sub + langWord8 = fromIntegral (fromEnum lang) + tooFew sub = costModelInitParamCount lang - sub listAtLeast :: Int -> Gen [Int64] listAtLeast x = do NonNegative y <- arbitrary diff --git a/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Core/JSON.hs b/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Core/JSON.hs index a79896fcac3..e8658584d00 100644 --- a/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Core/JSON.hs +++ b/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Core/JSON.hs @@ -66,15 +66,15 @@ roundTripJsonEraSpec = goldenJsonPParamsSpec :: forall era. - EraPParams era => + (HasCallStack, EraPParams era) => SpecWith FilePath goldenJsonPParamsSpec = - it "Golden JSON specs for PParams " $ + it "Golden JSON specs for PParams" $ eitherDecodeFileStrict @(PParams era) >=> expectRightDeepExpr_ goldenJsonPParamsUpdateSpec :: forall era. - EraTest era => + (HasCallStack, EraTest era) => SpecWith FilePath goldenJsonPParamsUpdateSpec = it "Golden JSON specs for PParamsUpdate" $ \file -> do diff --git a/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Plutus.hs b/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Plutus.hs index 59709602101..d8a76c99117 100644 --- a/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Plutus.hs +++ b/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Plutus.hs @@ -1,6 +1,5 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE TypeApplications #-} module Test.Cardano.Ledger.Plutus ( PlutusArgs (..), @@ -32,7 +31,7 @@ import Cardano.Ledger.Binary.Plain (decodeFullFromHexText) import Cardano.Ledger.Plutus.CostModels ( CostModel, CostModels, - costModelParamsCount, + costModelInitParamCount, getCostModelEvaluationContext, mkCostModel, mkCostModels, @@ -62,7 +61,7 @@ import Test.Cardano.Ledger.Plutus.ScriptTestContext ( -- | Construct a test cost model where all parameters are set to the same value mkCostModelConst :: HasCallStack => Language -> Int64 -> CostModel -mkCostModelConst lang = mkCostModel' lang . replicate (costModelParamsCount lang) +mkCostModelConst lang = mkCostModel' lang . replicate (costModelInitParamCount lang) mkCostModel' :: (Integral i, Show i, HasCallStack) => Language -> [i] -> CostModel mkCostModel' lang params =