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

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,
@@ -478,7 +479,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
@@ -633,7 +634,7 @@ getLanguageView pp lang =
         (serialize' version lang)
         costModelEncoding
   where
-    costModel = Map.lookup lang (unCostModels $ pp ^. ppCostModelsL)
+    costModel = Map.lookup lang (validCostModels $ 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 = validCostModels $ 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,
+  mkCostModels,
   encodeCostModel,
   getCostModelLanguage,
   getCostModelParams,
   getEvaluationContext,
   ExUnits (ExUnits, exUnitsMem, exUnitsSteps, ..),
   ExUnits',
   Prices (..),
-  decodeCostModelMap,
-  decodeCostModel,
+  decodeCostModelFailHard,
   CostModels (..),
   PV1.CostModelApplyError (..),
 )
@@ -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 = mkCostModels <$> 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,85 @@ 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.
+--
+-- It would be preferable to store the 'PV1.CostModelApplyError' type itself,
+-- but there is currently no 'Eq' instance for it, which we require.
+data CostModelError = CostModelError String
+  deriving stock (Eq, Show, Ord, Generic)
+
+instance NoThunks 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'.
+instance NFData CostModelError
+
+data CostModels = CostModels
+  { validCostModels :: Map Language CostModel
+  , costModelErrors :: Map Language CostModelError
+  , invalidCostModels :: 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 storted 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 lang params (CostModels validCMs errs invalidCMs) =
+  if minLang <= lang && lang <= maxLang
+    then case mkCostModel lang' params of
+      Right cm -> CostModels (Map.insert lang' cm validCMs) errs invalidCMs
+      Left e -> CostModels validCMs (addError lang' e errs) invalidCMs'
+    else CostModels validCMs errs invalidCMs'
+  where
+    minLang = fromIntegral . fromEnum $ (minBound :: Language)
+    maxLang = fromIntegral . fromEnum $ (maxBound :: Language)
+    lang' = toEnum . fromIntegral $ lang
+    invalidCMs' = Map.insert lang params invalidCMs
+    addError l e es = Map.insert l (CostModelError $ show e) es
+
+mkCostModels :: Map Word8 [Integer] -> CostModels
+mkCostModels = 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) = validCMs' `Map.union` invalidCMs
+  where
+    validCMs' = Map.fromList $ map f (Map.toList validCMs)
+    f (lang, cm) = (fromIntegral . fromEnum $ lang, cmMap cm)
+
+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 cm = encodeMap toCBOR toCBOR (flattenCostModel cm)
 
 instance ToJSON CostModel where
   toJSON = toJSON . getCostModelParams
 
 instance ToJSON CostModels where
-  toJSON = toJSON . unCostModels
+  toJSON = toJSON . validCostModels
 
 -- | Encoding for the `CostModel`. Important to note that it differs from `Encoding` used
 -- by `Cardano.Ledger.Alonzo.PParams.getLanguageView`
@@ -777,6 +850,8 @@ instance ToExpr CostModel where
   toExpr (CostModel lang cmmap _) =
     App "CostModel" [toExpr lang, toExpr cmmap, App "PV1.EvaluationContext" []]
 
+instance ToExpr CostModelError
+
 instance ToExpr CostModels
 
 instance ToExpr Prices

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

@@ -44,6 +44,7 @@ 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/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