11{-# LANGUAGE DataKinds #-}
2- {-# LANGUAGE DeriveAnyClass #-}
3- {-# LANGUAGE DeriveFunctor #-}
42{-# LANGUAGE DeriveGeneric #-}
53{-# LANGUAGE DerivingVia #-}
64{-# LANGUAGE FlexibleContexts #-}
75{-# LANGUAGE FlexibleInstances #-}
8- {-# LANGUAGE GeneralizedNewtypeDeriving #-}
9- {-# LANGUAGE LambdaCase #-}
106{-# LANGUAGE MultiParamTypeClasses #-}
11- {-# LANGUAGE NamedFieldPuns #-}
127{-# LANGUAGE OverloadedStrings #-}
13- {-# LANGUAGE PatternSynonyms #-}
148{-# LANGUAGE ScopedTypeVariables #-}
15- {-# LANGUAGE StandaloneDeriving #-}
169{-# LANGUAGE TypeApplications #-}
1710{-# LANGUAGE TypeFamilies #-}
18- {-# LANGUAGE TypeOperators #-}
1911{-# LANGUAGE UndecidableInstances #-}
2012
2113module Cardano.Ledger.Plutus.CostModels (
@@ -33,12 +25,17 @@ module Cardano.Ledger.Plutus.CostModels (
3325 costModelFromMap ,
3426 costModelParamsCount ,
3527 decodeCostModel ,
28+ costModelInitParamNames ,
29+ costModelInitParamCount ,
30+ parseCostModelAsMap ,
31+ parseCostModelAsArray ,
3632
3733 -- * Cost Models
3834 CostModels ,
3935 mkCostModels ,
4036 emptyCostModels ,
4137 updateCostModels ,
38+ parseCostModels ,
4239 decodeCostModelsLenient ,
4340 decodeCostModelsFailing ,
4441 costModelsValid ,
@@ -63,9 +60,10 @@ import Cardano.Ledger.Plutus.Language (
6360 nonNativeLanguages ,
6461 )
6562import Control.DeepSeq (NFData (.. ), deepseq )
66- import Control.Monad (forM , when )
63+ import Control.Monad (forM , unless , when )
6764import Control.Monad.Trans.Writer (WriterT (runWriterT ))
6865import Data.Aeson (
66+ Array ,
6967 FromJSON (.. ),
7068 Object ,
7169 ToJSON (.. ),
@@ -137,36 +135,72 @@ instance NFData CostModel where
137135 rnf (CostModel lang cm ectx) = lang `deepseq` cm `deepseq` rnf ectx
138136
139137instance FromJSON CostModels where
140- parseJSON = withObject " CostModels" $ \ o -> do
141- cms <- mapM (parseCostModel o) nonNativeLanguages
138+ parseJSON = parseCostModels True
139+
140+ parseCostModels ::
141+ -- | Do not restrict number of parameters to the initial count and allow parsing of cost models
142+ -- for unknown plutus versions.
143+ Bool ->
144+ Value ->
145+ Parser CostModels
146+ parseCostModels isLenient =
147+ withObject " CostModels" $ \ o -> do
148+ cms <- mapM (parseCostModel isLenient o) nonNativeLanguages
142149 let cmsMap = Map. fromList [(cmLanguage cm, cm) | Just cm <- cms]
143- unknown <- o .:? " Unknown" .!= mempty
144- unknownCostModels <- mkCostModelsLenient unknown
150+ unknownCostModels <-
151+ if isLenient
152+ then do
153+ unknown <- o .:? " Unknown" .!= mempty
154+ mkCostModelsLenient unknown
155+ else
156+ pure mempty
145157 pure $ mkCostModels cmsMap <> unknownCostModels
146158
147- -- | The costmodel parameters in Alonzo Genesis are represented as a map. Plutus API does
148- -- no longer require the map as a parameter to `mkEvaluationContext`, but the list of
149- -- integers representing the values of the map. The expectation on this list of integers
150- -- is that they are sorted in the order given by the `ParamName` enum, so even though we
151- -- just have to pass the list to plutus, we still need to use the names of the parameters
152- -- in order to sort the list. In new versions, we want to represent the costmodel
153- -- parameters directly as a list, so we can avoid this reordering.
154- parseCostModel :: Object -> Language -> Parser (Maybe CostModel )
155- parseCostModel o lang = do
159+ -- | The costmodel parameters in Alonzo Genesis are represented as a map. Plutus API does no longer
160+ -- require the map as a parameter to `mkEvaluationContext`, but the list of integers representing
161+ -- the values of the map. The expectation on this list of integers is that they are sorted in the
162+ -- order given by the `ParamName` enum, so even though we just have to pass the list to plutus, we
163+ -- still need to use the names of the parameters in order to sort the list. In new versions, we
164+ -- represent the costmodel parameters directly as a list, so we can avoid this reordering.
165+ parseCostModel :: Bool -> Object -> Language -> Parser (Maybe CostModel )
166+ parseCostModel isLenient o lang = do
156167 plutusCostModelValueMaybe <- o .:? fromString (show lang)
157168 forM plutusCostModelValueMaybe $ \ plutusCostModelValue ->
158169 case plutusCostModelValue of
159- Object _ -> costModelFromMap lang =<< parseJSON plutusCostModelValue
160- Array _ -> validateCostModel lang =<< parseJSON plutusCostModelValue
170+ Object m -> parseCostModelAsMap isLenient lang m
171+ Array a -> parseCostModelAsArray isLenient lang a
161172 _ -> fail $ " Expected either an Array or an Object, but got: " ++ show plutusCostModelValue
162173
174+ parseCostModelAsMap :: Bool -> Language -> Object -> Parser CostModel
175+ parseCostModelAsMap isLenient lang m = do
176+ costModel <- costModelFromMap lang =<< parseJSON (Object m)
177+ unless isLenient $ guardNumberOfParameters lang m
178+ pure costModel
179+
180+ parseCostModelAsArray :: Bool -> Language -> Array -> Parser CostModel
181+ parseCostModelAsArray isLenient lang a = do
182+ costModel <- validateCostModel lang =<< parseJSON (Array a)
183+ unless isLenient $ guardNumberOfParameters lang a
184+ pure costModel
185+
186+ guardNumberOfParameters :: (Foldable f , MonadFail m ) => Language -> f a -> m ()
187+ guardNumberOfParameters lang ps =
188+ let suppliedParameterCount = length ps
189+ expectedParameterCount = costModelInitParamCount lang
190+ in unless (suppliedParameterCount == expectedParameterCount) $
191+ fail $
192+ " Number of parameters supplied "
193+ <> show suppliedParameterCount
194+ <> " does not match the expected number of "
195+ <> show expectedParameterCount
196+
163197costModelFromMap :: MonadFail m => Language -> Map Text Int64 -> m CostModel
164198costModelFromMap lang cmMap =
165199 either (fail . unlines . (header : ) . NE. toList) (validateCostModel lang) $
166200 validationToEither (traverse lookupFail paramNames)
167201 where
168202 header = " Cost model language: " ++ show lang
169- paramNames = costModelParamNames lang
203+ paramNames = costModelInitParamNames lang
170204 lookupFail paramName =
171205 case Map. lookup paramName cmMap of
172206 Nothing -> failure $ " Parameter name missing from cost model: " ++ show paramName
@@ -180,6 +214,24 @@ costModelParamNames :: Language -> [Text]
180214costModelParamNames PlutusV1 = plutusV1ParamNames
181215costModelParamNames lang = plutusVXParamNames lang
182216
217+ -- | List of parameter names as when they were introduced upon a hard fork to a specific era for a
218+ -- corresponding plutus version.
219+ costModelInitParamNames :: Language -> [Text ]
220+ costModelInitParamNames lang = take (costModelInitParamCount lang) $ costModelParamNames lang
221+
222+ -- | Number of `CostModel` parameters for a specified plutus version as when it was initially
223+ -- added. This is useful for genesis files, which shouldn't have the number of parameters vary over
224+ -- time.
225+ costModelInitParamCount :: Language -> Int
226+ costModelInitParamCount lang =
227+ case lang of
228+ PlutusV1 -> 166
229+ PlutusV2 -> 175
230+ PlutusV3 -> 251
231+ PlutusV4 ->
232+ -- This number will continue to change until we are ready to hard fork into Dijkstra era
233+ 251
234+
183235-- | There is a difference in 6 parameter names between the ones appearing alonzo genesis
184236-- files and the values returned by plutus via `P.showParamName` on the `ParamName` enum.
185237-- 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
264316costModelParamsCount PlutusV2 = 175
265317costModelParamsCount PlutusV3 = 231
266318costModelParamsCount PlutusV4 = 231
319+ {-# DEPRECATED
320+ costModelParamsCount
321+ "Deprecated in favor of `costModelInitParamCount`, since this function provided an incorrect value of 231 for PlutusV3, where it should have been 251"
322+ #-}
267323
268324decodeCostModelLegacy :: Language -> Decoder s CostModel
269325decodeCostModelLegacy lang = do
@@ -272,7 +328,7 @@ decodeCostModelLegacy lang = do
272328 " Legacy CostModel decoding is not supported for " ++ show lang ++ " language version"
273329 values <- decCBOR
274330 let numValues = length values
275- expectedNumValues = costModelParamsCount lang
331+ expectedNumValues = costModelInitParamCount lang
276332 when (numValues /= expectedNumValues) $
277333 fail $
278334 " Expected array with "
0 commit comments