introduce flexible cost model decoding

Starting in version 9, 'CostModels' can now be deserialized
from any map from Word8 values to lists of integers.
Only valid cost models are actual converted to cost models.

resolves #2902

CHANGELOG.md

@@ -283,6 +283,12 @@ in the naming of release branches.
   - Replaced `PredicateFailure (EraRule "UPEC" era)` with `UpecPredFailure era`
 - Changed the type of the first field of `ShelleyBbodyState` to  #3216
   `State (EraRule "LEDGERS" era)`
+- Starting in version 9, CostModels can now be deserialized from any map of Word8 values to lists of integers.
+  Only valid cost models are actually converted to evaluation contexts that can be used.
+  Errors and unrecognized language versions are stored in the CostModels type so that:
+    - they can accept cost models that they do not yet understand
+    - upon deserializing after a software update, new cost models are available from the prior serialization.
+  #3283
 
 ### Removed
 

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

@@ -61,6 +61,7 @@ import Cardano.Ledger.Alonzo.Scripts (
   CostModels (..),
   ExUnits (..),
   Prices (..),
+  emptyCostModels,
   getCostModelLanguage,
   getCostModelParams,
   zipSemiExUnits,
@@ -482,7 +483,7 @@ emptyAlonzoPParams =
     , appMinPoolCost = mempty
     , -- new/updated for alonzo
       appCoinsPerUTxOWord = CoinPerWord (Coin 0)
-    , appCostModels = CostModels mempty
+    , appCostModels = emptyCostModels
     , appPrices = Prices minBound minBound
     , appMaxTxExUnits = OrdExUnits $ ExUnits 0 0
     , appMaxBlockExUnits = OrdExUnits $ ExUnits 0 0
@@ -637,7 +638,7 @@ getLanguageView pp lang =
         (serialize' version lang)
         costModelEncoding
   where
-    costModel = Map.lookup lang (unCostModels $ pp ^. ppCostModelsL)
+    costModel = Map.lookup lang (costModelsValid $ pp ^. ppCostModelsL)
     costModelEncoding = serializeEncoding' version $ maybe encodeNull encodeCostModel costModel
     version = BT.pvMajor $ pp ^. ppProtocolVersionL
 

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

@@ -153,7 +153,7 @@ collectTwoPhaseScriptInputs ::
   Either [CollectError (EraCrypto era)] [(ShortByteString, Language, [Data era], ExUnits, CostModel)]
 collectTwoPhaseScriptInputs ei sysS pp tx utxo =
   let usedLanguages = Set.fromList [lang | (_, lang, _) <- neededAndConfirmedToBePlutus]
-      costModels = unCostModels $ pp ^. ppCostModelsL
+      costModels = costModelsValid $ pp ^. ppCostModelsL
       missingCMs = Set.filter (`Map.notMember` costModels) usedLanguages
    in case Set.lookupMin missingCMs of
         Just l -> Left [NoCostModel l]

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

@@ -33,16 +33,18 @@ module Cardano.Ledger.Alonzo.Scripts (
 
   -- * Cost Model
   CostModel,
+  CostModelError (..),
+  emptyCostModels,
   mkCostModel,
+  mkCostModelsLenient,
   encodeCostModel,
   getCostModelLanguage,
   getCostModelParams,
   getEvaluationContext,
   ExUnits (ExUnits, exUnitsMem, exUnitsSteps, ..),
   ExUnits',
   Prices (..),
-  decodeCostModelMap,
-  decodeCostModel,
+  decodeCostModelFailHard,
   CostModels (..),
   PV1.CostModelApplyError (..),
 )
@@ -67,7 +69,6 @@ import Cardano.Ledger.Binary (
   cborError,
   decodeMapByKey,
   encodeFoldableAsDefLenList,
-  encodeMap,
   getVersion64,
   ifDecoderVersionAtLeast,
  )
@@ -85,6 +86,7 @@ import Cardano.Ledger.Binary.Version (natVersion)
 import Cardano.Ledger.Coin (Coin (..))
 import Cardano.Ledger.Core
 import Cardano.Ledger.Crypto (Crypto)
+import Cardano.Ledger.Language (mkLanguageEnum)
 import Cardano.Ledger.SafeHash (SafeToHash (..))
 import Cardano.Ledger.Shelley.Scripts (nativeMultiSigTag)
 import Cardano.Ledger.TreeDiff (Expr (App), ToExpr (..), defaultExprViaShow)
@@ -120,7 +122,7 @@ import Data.Typeable (Typeable)
 import Data.Vector as Vector (toList)
 import Data.Word (Word64, Word8)
 import GHC.Generics (Generic)
-import NoThunks.Class (InspectHeapNamed (..), NoThunks)
+import NoThunks.Class (InspectHeapNamed (..), NoThunks (..), allNoThunks)
 import Numeric.Natural (Natural)
 import PlutusCore.Evaluation.Machine.CostModelInterface (CostModelApplyWarn)
 import qualified PlutusLedgerApi.V1 as PV1 (
@@ -328,7 +330,7 @@ instance FromJSON CostModels where
   parseJSON = withObject "CostModels" $ \o -> do
     v1CostModels <- legacyParseCostModels o
     v2CostModels <- parseCostModels o
-    pure $ CostModels $ Map.fromList (v1CostModels ++ v2CostModels)
+    pure $ CostModels (Map.fromList (v1CostModels ++ v2CostModels)) mempty mempty
 
 -- | 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
@@ -560,12 +562,19 @@ getCostModelLanguage (CostModel lang _ _) = lang
 getCostModelParams :: CostModel -> [Integer]
 getCostModelParams (CostModel _ cm _) = cm
 
-decodeCostModelMap :: Decoder s (Map Language CostModel)
-decodeCostModelMap =
+decodeCostModelsCollectingErrors :: Decoder s CostModels
+decodeCostModelsCollectingErrors = mkCostModelsLenient <$> fromCBOR
+
+decodeCostModelsFailingOnError :: Decoder s CostModels
+decodeCostModelsFailingOnError =
+  CostModels <$> decodeMapByKey fromCBOR legacyDecodeCostModel <*> pure mempty <*> pure mempty
+
+decodeCostModels :: Decoder s CostModels
+decodeCostModels =
   ifDecoderVersionAtLeast
     (natVersion @9)
-    (decodeMapByKey fromCBOR decodeCostModel)
-    (decodeMapByKey fromCBOR legacyDecodeCostModel)
+    decodeCostModelsCollectingErrors
+    decodeCostModelsFailingOnError
 
 -- | Prior to version 9, each 'CostModel' was expected to be serialized as
 -- an array of integers of a specific length (depending on the version of Plutus).
@@ -600,8 +609,8 @@ legacyDecodeCostModel lang = do
     Left e -> fail $ show e
     Right cm -> pure cm
 
-decodeCostModel :: Language -> Decoder s CostModel
-decodeCostModel lang = do
+decodeCostModelFailHard :: Language -> Decoder s CostModel
+decodeCostModelFailHard lang = do
   checked <- mkCostModel lang <$> fromCBOR
   case checked of
     Left e -> fail $ show e
@@ -610,21 +619,94 @@ decodeCostModel lang = do
 getEvaluationContext :: CostModel -> PV1.EvaluationContext
 getEvaluationContext (CostModel _ _ ec) = ec
 
-newtype CostModels = CostModels {unCostModels :: Map Language CostModel}
+-- | See 'CostModels' for an explanation of how 'CostModelError' is used.
+newtype CostModelError = CostModelError PV1.CostModelApplyError
+  deriving stock (Show, Generic)
+
+instance Eq CostModelError where
+  CostModelError x1 == CostModelError x2 = show x1 == show x2
+
+instance Ord CostModelError where
+  CostModelError x1 <= CostModelError x2 = show x1 <= show x2
+
+instance ToExpr CostModelError where
+  toExpr (CostModelError x1) = toExpr (show x1)
+
+instance NoThunks PV1.CostModelApplyError where
+  showTypeOf _ = "CostModelApplyError"
+  wNoThunks _ctxt _error = allNoThunks []
+
+instance NoThunks CostModelError
+
+instance NFData PV1.CostModelApplyError where
+  rnf = rwhnf
+
+instance NFData CostModelError
+
+-- | For a known version of Plutus, attempting to construct a cost model with
+-- too few parameters (depending on the version) will result in an error.
+-- 'CostModelApplyError' exists to collect these errors in the 'CostModels' type.
+-- The 'CostModels' type itself needs to be flexible enough to accept any map
+-- of 'Word8' to '[Integer]', so that cost models can be placed in the protocol parameters
+-- ahead of changes to the Plutus evaluation context. In this way, serializing a cost model,
+-- updating software, and deserializing can result in errors going away.
+--
+-- Additionally, 'CostModels' needs to be able to store cost models for future version
+-- of Plutus, which we cannot yet even validate. These are stored in 'invalidCostModels'.
+data CostModels = CostModels
+  { costModelsValid :: !(Map Language CostModel)
+  , costModelsErrors :: !(Map Language CostModelError)
+  , costModelsUnknown :: !(Map Word8 [Integer])
+  }
   deriving stock (Eq, Show, Ord, Generic)
-  deriving newtype (NFData, NoThunks)
+
+emptyCostModels :: CostModels
+emptyCostModels = CostModels mempty mempty mempty
+
+-- | This function attempts to add a new cost model to a given 'CostModels'.
+-- If it is a valid cost model for a known version of Plutus, it is added to
+-- 'validCostModels'. If it is an invalid cost model for a known version of Plutus,
+-- the error is sorted in 'costModelErrors' and the cost model is stored in
+-- 'invalidCostModels'. Lastly, if the Plutus version is unknown,
+-- the cost model is also stored in 'invalidCostModels'.
+addRawCostModel :: Word8 -> [Integer] -> CostModels -> CostModels
+addRawCostModel langW8 cmIds (CostModels validCMs errs invalidCMs) =
+  case mkLanguageEnum (fromIntegral langW8) of
+    Just lang ->
+      case mkCostModel lang cmIds of
+        Right cm -> CostModels (Map.insert lang cm validCMs) errs invalidCMs
+        Left e -> CostModels validCMs (addError lang e errs) updatedInvalidCMs
+    Nothing -> CostModels validCMs errs updatedInvalidCMs
+  where
+    updatedInvalidCMs = Map.insert langW8 cmIds invalidCMs
+    addError l e es = Map.insert l (CostModelError e) es
+
+mkCostModelsLenient :: Map Word8 [Integer] -> CostModels
+mkCostModelsLenient = Map.foldrWithKey addRawCostModel (CostModels mempty mempty mempty)
+
+-- | Turn a 'CostModels' into a mapping of potential language versions and
+-- cost model values, with no distinction between valid and invalid cost models.
+-- This is used for serialization, so that judgements about validity can be made
+-- upon deserialization.
+flattenCostModel :: CostModels -> Map Word8 [Integer]
+flattenCostModel (CostModels validCMs _ invalidCMs) =
+  Map.foldrWithKey (\lang cm -> Map.insert (fromIntegral $ fromEnum lang) (cmMap cm)) invalidCMs validCMs
+
+instance NoThunks CostModels
+
+instance NFData CostModels
 
 instance FromCBOR CostModels where
-  fromCBOR = CostModels <$> decodeCostModelMap
+  fromCBOR = decodeCostModels
 
 instance ToCBOR CostModels where
-  toCBOR = encodeMap toCBOR encodeCostModel . unCostModels
+  toCBOR = toCBOR . flattenCostModel
 
 instance ToJSON CostModel where
   toJSON = toJSON . getCostModelParams
 
 instance ToJSON CostModels where
-  toJSON = toJSON . unCostModels
+  toJSON = toJSON . costModelsValid
 
 -- | Encoding for the `CostModel`. Important to note that it differs from `Encoding` used
 -- by `Cardano.Ledger.Alonzo.PParams.getLanguageView`

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

@@ -75,7 +75,7 @@ import Cardano.Ledger.Allegra.Scripts (ValidityInterval (..))
 import Cardano.Ledger.Alonzo.Scripts (
   AlonzoScript (..),
   ExUnits (..),
-  decodeCostModel,
+  decodeCostModelFailHard,
   encodeCostModel,
   getEvaluationContext,
   transProtocolVersion,
@@ -615,7 +615,7 @@ instance
     let lang = fromSLanguage $ isLanguage @l
     when (fromEnum lang /= fromIntegral tag) $ fail $ "Unexpected language: " <> show tag
     slang <- fromCBOR
-    costModel <- decodeCostModel lang
+    costModel <- decodeCostModelFailHard lang
     exUnits <- fromCBOR
     sbs <- fromCBOR
     pData <- fromCBOR

eras/alonzo/test-suite/cardano-ledger-alonzo-test.cabal

@@ -27,6 +27,7 @@ source-repository head
 library
     exposed-modules:
         Test.Cardano.Ledger.Alonzo.AlonzoEraGen
+        Test.Cardano.Ledger.Alonzo.CostModel
         Test.Cardano.Ledger.Alonzo.EraMapping
         Test.Cardano.Ledger.Alonzo.Examples.Consensus
         Test.Cardano.Ledger.Alonzo.PlutusScripts

eras/alonzo/test-suite/src/Test/Cardano/Ledger/Alonzo/AlonzoEraGen.hs

@@ -22,12 +22,9 @@ import Cardano.Ledger.Alonzo.PlutusScriptApi as Alonzo (language)
 import Cardano.Ledger.Alonzo.Rules (vKeyLocked)
 import Cardano.Ledger.Alonzo.Scripts as Alonzo (
   AlonzoScript (..),
-  CostModel,
-  CostModels (..),
   ExUnits (..),
   Prices (..),
   isPlutusScript,
-  mkCostModel,
   pointWiseExUnits,
   txscriptfee,
  )
@@ -84,7 +81,6 @@ import Cardano.Ledger.UTxO (
  )
 import Cardano.Ledger.Val (Val (isAdaOnly, (<+>), (<×>)))
 import Control.Monad (replicateM)
-import Data.Either (fromRight)
 import qualified Data.List as List
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
@@ -95,13 +91,12 @@ import qualified Data.Sequence.Strict as Seq (fromList)
 import Data.Set as Set
 import Lens.Micro
 import Numeric.Natural (Natural)
-import qualified PlutusLedgerApi.V1 as PV1 (Data, ParamName)
-import qualified PlutusLedgerApi.V2 as PV2 (ParamName)
-import PlutusPrelude (enumerate)
+import qualified PlutusLedgerApi.V1 as PV1 (Data)
 import qualified PlutusTx as P (Data (..))
 import qualified PlutusTx as Plutus
 import System.Random
 import Test.Cardano.Ledger.AllegraEraGen (genValidityInterval)
+import Test.Cardano.Ledger.Alonzo.CostModel (freeV1CostModels)
 import Test.Cardano.Ledger.Alonzo.PlutusScripts (
   evenRedeemer2,
   evendata3,
@@ -196,21 +191,6 @@ genAlonzoMint startvalue = do
       let assetname = AssetName "purple"
       pure (multiAssetFromList [(PolicyID shash, assetname, count)] <> startvalue, [script])
 
--- ================================================================
-
-costModelParamsCount :: Language -> Int
-costModelParamsCount lang = case lang of
-  PlutusV1 -> length (enumerate @PV1.ParamName)
-  PlutusV2 -> length (enumerate @PV2.ParamName)
-
--- | A cost model that sets everything as being free
-freeCostModel :: Language -> CostModel
-freeCostModel lang =
-  fromRight (error "freeCostModel is not well-formed") $
-    Alonzo.mkCostModel lang (replicate (costModelParamsCount lang) 0)
-
--- ================================================================
-
 genPair :: Gen a -> Gen b -> Gen (a, b)
 genPair x y = (,) <$> x <*> y
 
@@ -336,7 +316,7 @@ genAlonzoPParamsUpdate constants pp = do
   let alonzoUpgrade =
         UpgradeAlonzoPParams
           { uappCoinsPerUTxOWord = coinPerWord
-          , uappCostModels = SJust $ CostModels $ Map.singleton PlutusV1 (freeCostModel PlutusV1)
+          , uappCostModels = SJust freeV1CostModels
           , uappPrices = prices
           , uappMaxTxExUnits = maxTxExUnits
           , uappMaxBlockExUnits = maxBlockExUnits
@@ -370,7 +350,7 @@ genAlonzoPParams constants = do
   let alonzoUpgrade =
         UpgradeAlonzoPParams
           { uappCoinsPerUTxOWord = coinPerWord
-          , uappCostModels = CostModels $ Map.singleton PlutusV1 (freeCostModel PlutusV1)
+          , uappCostModels = freeV1CostModels
           , uappPrices = prices
           , uappMaxTxExUnits = maxTxExUnits
           , uappMaxBlockExUnits = maxBlockExUnits

eras/alonzo/test-suite/src/Test/Cardano/Ledger/Alonzo/CostModel.hs

@@ -0,0 +1,39 @@
+{-# LANGUAGE TypeApplications #-}
+
+module Test.Cardano.Ledger.Alonzo.CostModel (
+  costModelParamsCount,
+  freeCostModel,
+  freeV1CostModels,
+  freeV1V2CostModels,
+)
+where
+
+import Cardano.Ledger.Alonzo.Language (Language (..))
+import Cardano.Ledger.Alonzo.Scripts as Alonzo (
+  CostModel,
+  CostModels (..),
+  mkCostModel,
+ )
+import Data.Either (fromRight)
+import qualified Data.Map.Strict as Map
+import qualified PlutusLedgerApi.V1 as PV1 (ParamName)
+import qualified PlutusLedgerApi.V2 as PV2 (ParamName)
+import PlutusPrelude (enumerate)
+
+costModelParamsCount :: Language -> Int
+costModelParamsCount lang = case lang of
+  PlutusV1 -> length (enumerate @PV1.ParamName)
+  PlutusV2 -> length (enumerate @PV2.ParamName)
+
+-- | A cost model that sets everything as being free
+freeCostModel :: Language -> CostModel
+freeCostModel lang =
+  fromRight (error "freeCostModel is not well-formed") $
+    Alonzo.mkCostModel lang (replicate (costModelParamsCount lang) 0)
+
+freeV1CostModels :: CostModels
+freeV1CostModels = CostModels (Map.singleton PlutusV1 (freeCostModel PlutusV1)) mempty mempty
+
+freeV1V2CostModels :: CostModels
+freeV1V2CostModels =
+  CostModels (Map.fromList [(l, freeCostModel l) | l <- [PlutusV1, PlutusV2]]) mempty mempty

eras/alonzo/test-suite/src/Test/Cardano/Ledger/Alonzo/Examples/Consensus.hs

@@ -170,7 +170,7 @@ exampleAlonzoGenesis :: AlonzoGenesis
 exampleAlonzoGenesis =
   AlonzoGenesis
     { agCoinsPerUTxOWord = CoinPerWord $ Coin 1
-    , agCostModels = CostModels $ Map.fromList [(PlutusV1, testingCostModelV1)]
+    , agCostModels = CostModels (Map.fromList [(PlutusV1, testingCostModelV1)]) mempty mempty
     , agPrices = Prices (boundRational' 90) (boundRational' 91)
     , agMaxTxExUnits = ExUnits 123 123
     , agMaxBlockExUnits = ExUnits 223 223