Merge pull request #5241 from IntersectMBO/lehins/fix-CostModel-json-parsing

Fix JSON parsing for CostModels

Author: teodanciu

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"

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
 

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": [

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.

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": "",

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.

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 "

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

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

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 =