Merge pull request #5379 from IntersectMBO/ldan/alonzogen-cm-injection

Add ability to inject any cost models via `AlonzoGenesis`

Resolves #5342

Author: Lucsanszky

eras/alonzo/impl/CHANGELOG.md

@@ -2,6 +2,12 @@
 
 ## 1.15.0.0
 
+* Renamed `uappCostModels` to `uappPlutusV1CostModel`
+  and changed its type from `CostModels` to `CostModel`
+* Renamed `agCostModels` to `agPlutusV1CostModel`
+  and changed its type from `CostModels` to `CostModel`
+* Updated `AlonzoGenesis` with `extraConfig` field
+* Added `AlonzoExtraConfig` and its instances
 * Remove deprecated functions `nullRedeemers`, `lookupRedeemers`, `nullDats`
 * Remove deprecated type `AlonzoTxWits'` and its accessor functions:
   - `txwitsVKey'`
@@ -38,6 +44,7 @@
 
 ### `testlib`
 
+* Added `Arbitrary` instance for `AlonzoExtraConfig`
 * Add CDDL definitions for Plutus V1 types: `big_int`, `big_uint`, `big_nint`, `bounded_bytes`
 * Rename `plutus_script` -> `plutus_v1_script` in CDDL
 * Add `plutus_v1_script` to CDDL exports

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

@@ -3,101 +3,156 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE UndecidableInstances #-}
-{-# LANGUAGE ViewPatterns #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
 
 module Cardano.Ledger.Alonzo.Genesis (
   AlonzoGenesis (
     AlonzoGenesisWrapper,
     unAlonzoGenesisWrapper,
+    extraConfig,
     AlonzoGenesis,
     agCoinsPerUTxOWord,
-    agCostModels,
+    agPlutusV1CostModel,
     agPrices,
     agMaxTxExUnits,
     agMaxBlockExUnits,
     agMaxValSize,
     agCollateralPercentage,
-    agMaxCollateralInputs
+    agMaxCollateralInputs,
+    agExtraConfig
   ),
+  AlonzoExtraConfig (..),
 ) where
 
 import Cardano.Ledger.Alonzo.Era (AlonzoEra)
-import Cardano.Ledger.Alonzo.PParams (CoinPerWord, UpgradeAlonzoPParams (..))
-import Cardano.Ledger.Alonzo.Scripts (CostModels, ExUnits (..), Prices (..))
+import Cardano.Ledger.Alonzo.PParams (
+  CoinPerWord,
+  UpgradeAlonzoPParams (..),
+ )
+import Cardano.Ledger.Alonzo.Scripts (
+  CostModel,
+  CostModels,
+  ExUnits (..),
+  Prices (..),
+  costModelsValid,
+  decodeCostModel,
+  decodeCostModelsLenient,
+  encodeCostModel,
+  flattenCostModels,
+  mkCostModels,
+ )
 import Cardano.Ledger.BaseTypes (KeyValuePairs (..), ToKeyValuePairs (..))
 import Cardano.Ledger.Binary (
-  DecCBOR,
-  EncCBOR,
+  DecCBOR (..),
+  EncCBOR (..),
   FromCBOR (..),
   ToCBOR (..),
+  decodeNullMaybe,
+  encodeNullMaybe,
  )
-import Cardano.Ledger.Binary.Coders (
-  Decode (From, RecD),
-  Encode (Rec, To),
-  decode,
-  encode,
-  (!>),
-  (<!),
- )
+import Cardano.Ledger.Binary.Coders
 import Cardano.Ledger.Core
 import Cardano.Ledger.Genesis (EraGenesis (..))
+import Cardano.Ledger.Plutus (Language (PlutusV1))
 import Cardano.Ledger.Plutus.CostModels (parseCostModels)
 import Control.DeepSeq (NFData)
-import Data.Aeson (FromJSON (..), ToJSON (..), (.:), (.=))
+import Data.Aeson (FromJSON (..), ToJSON (..), (.:), (.:?), (.=))
 import qualified Data.Aeson as Aeson
 import Data.Functor.Identity (Identity)
+import qualified Data.List as List
+import qualified Data.Map.Strict as Map
 import GHC.Generics (Generic)
 import NoThunks.Class (NoThunks)
 import Numeric.Natural (Natural)
 
 -- | All configuration that is necessary to bootstrap AlonzoEra from ShelleyGenesis
-newtype AlonzoGenesis = AlonzoGenesisWrapper
+data AlonzoGenesis = AlonzoGenesisWrapper
   { unAlonzoGenesisWrapper :: UpgradeAlonzoPParams Identity
+  , extraConfig :: Maybe AlonzoExtraConfig
   }
-  deriving stock (Eq, Generic)
-  deriving newtype (Show, NoThunks, NFData)
+  deriving stock (Eq, Show, Generic)
   deriving (ToJSON) via KeyValuePairs AlonzoGenesis
 
+instance NoThunks AlonzoGenesis
+
+instance NFData AlonzoGenesis
+
+newtype AlonzoExtraConfig = AlonzoExtraConfig
+  { aecCostModels :: Maybe CostModels
+  }
+  deriving (Eq)
+  deriving newtype (NFData, NoThunks, Show)
+
+instance DecCBOR AlonzoExtraConfig
+
+instance EncCBOR AlonzoExtraConfig
+
+instance FromCBOR AlonzoExtraConfig where
+  fromCBOR =
+    eraDecoder @AlonzoEra $
+      decode $
+        RecD AlonzoExtraConfig
+          <! D (decodeNullMaybe decodeCostModelsLenient)
+
+instance ToCBOR AlonzoExtraConfig where
+  toCBOR x@(AlonzoExtraConfig _) =
+    let AlonzoExtraConfig {..} = x
+     in toEraCBOR @AlonzoEra . encode $
+          Rec AlonzoExtraConfig
+            !> E (encodeNullMaybe encCBOR) aecCostModels
+
+instance FromJSON AlonzoExtraConfig where
+  parseJSON = Aeson.withObject "Extra Config" $ \o ->
+    o .:? "costModels" >>= \case
+      Nothing -> pure $ AlonzoExtraConfig Nothing
+      Just val -> AlonzoExtraConfig . Just <$> parseCostModels True [] val
+
+instance ToJSON AlonzoExtraConfig where
+  toJSON (AlonzoExtraConfig cms) = Aeson.object ["costModels" .= cms]
+
 pattern AlonzoGenesis ::
   CoinPerWord ->
-  CostModels ->
+  CostModel ->
   Prices ->
   ExUnits ->
   ExUnits ->
   Natural ->
   Natural ->
   Natural ->
+  Maybe AlonzoExtraConfig ->
   AlonzoGenesis
 pattern AlonzoGenesis
   { agCoinsPerUTxOWord
-  , agCostModels
+  , agPlutusV1CostModel
   , agPrices
   , agMaxTxExUnits
   , agMaxBlockExUnits
   , agMaxValSize
   , agCollateralPercentage
   , agMaxCollateralInputs
+  , agExtraConfig
   } <-
-  ( unAlonzoGenesisWrapper ->
+  AlonzoGenesisWrapper
+    { unAlonzoGenesisWrapper =
       UpgradeAlonzoPParams
         { uappCoinsPerUTxOWord = agCoinsPerUTxOWord
-        , uappCostModels = agCostModels
+        , uappPlutusV1CostModel = agPlutusV1CostModel
         , uappPrices = agPrices
         , uappMaxTxExUnits = agMaxTxExUnits
         , uappMaxBlockExUnits = agMaxBlockExUnits
         , uappMaxValSize = agMaxValSize
         , uappCollateralPercentage = agCollateralPercentage
         , uappMaxCollateralInputs = agMaxCollateralInputs
         }
-    )
+    , extraConfig = agExtraConfig
+    }
   where
     AlonzoGenesis
       coinsPerUTxOWord_
@@ -107,18 +162,21 @@ pattern AlonzoGenesis
       maxBlockExUnits_
       maxValSize_
       collateralPercentage_
-      maxCollateralInputs_ =
-        AlonzoGenesisWrapper $
-          UpgradeAlonzoPParams
-            { uappCoinsPerUTxOWord = coinsPerUTxOWord_
-            , uappCostModels = costModels_
-            , uappPrices = prices_
-            , uappMaxTxExUnits = maxTxExUnits_
-            , uappMaxBlockExUnits = maxBlockExUnits_
-            , uappMaxValSize = maxValSize_
-            , uappCollateralPercentage = collateralPercentage_
-            , uappMaxCollateralInputs = maxCollateralInputs_
-            }
+      maxCollateralInputs_
+      extraConfig_ =
+        AlonzoGenesisWrapper
+          ( UpgradeAlonzoPParams
+              { uappCoinsPerUTxOWord = coinsPerUTxOWord_
+              , uappPlutusV1CostModel = costModels_
+              , uappPrices = prices_
+              , uappMaxTxExUnits = maxTxExUnits_
+              , uappMaxBlockExUnits = maxBlockExUnits_
+              , uappMaxValSize = maxValSize_
+              , uappCollateralPercentage = collateralPercentage_
+              , uappMaxCollateralInputs = maxCollateralInputs_
+              }
+          )
+          extraConfig_
 
 {-# COMPLETE AlonzoGenesis #-}
 
@@ -136,6 +194,7 @@ instance FromCBOR AlonzoGenesis where
       decode $
         RecD AlonzoGenesis
           <! From
+          <! D (decodeCostModel PlutusV1)
           <! From
           <! From
           <! From
@@ -145,49 +204,51 @@ instance FromCBOR AlonzoGenesis where
           <! From
 
 instance ToCBOR AlonzoGenesis where
-  toCBOR
-    AlonzoGenesis
-      { agCoinsPerUTxOWord
-      , agCostModels
-      , agPrices
-      , agMaxTxExUnits
-      , agMaxBlockExUnits
-      , agMaxValSize
-      , agCollateralPercentage
-      , agMaxCollateralInputs
-      } =
-      toEraCBOR @AlonzoEra
-        . encode
-        $ Rec AlonzoGenesis
-          !> To agCoinsPerUTxOWord
-          !> To agCostModels
-          !> To agPrices
-          !> To agMaxTxExUnits
-          !> To agMaxBlockExUnits
-          !> To agMaxValSize
-          !> To agCollateralPercentage
-          !> To agMaxCollateralInputs
+  toCBOR x@(AlonzoGenesis _ _ _ _ _ _ _ _ _) =
+    let AlonzoGenesis {..} = x
+     in toEraCBOR @AlonzoEra . encode $
+          Rec AlonzoGenesis
+            !> To agCoinsPerUTxOWord
+            !> E encodeCostModel agPlutusV1CostModel
+            !> To agPrices
+            !> To agMaxTxExUnits
+            !> To agMaxBlockExUnits
+            !> To agMaxValSize
+            !> To agCollateralPercentage
+            !> To agMaxCollateralInputs
+            !> To agExtraConfig
 
 instance FromJSON AlonzoGenesis where
   parseJSON = Aeson.withObject "Alonzo Genesis" $ \o -> do
     agCoinsPerUTxOWord <- o .: "lovelacePerUTxOWord"
-    agCostModels <- parseCostModels False =<< o .: "costModels"
+    cms <- parseCostModels False [PlutusV1] =<< o .: "costModels"
     agPrices <- o .: "executionPrices"
     agMaxTxExUnits <- o .: "maxTxExUnits"
     agMaxBlockExUnits <- o .: "maxBlockExUnits"
     agMaxValSize <- o .: "maxValueSize"
     agCollateralPercentage <- o .: "collateralPercentage"
     agMaxCollateralInputs <- o .: "maxCollateralInputs"
+    agExtraConfig <- o .:? "extraConfig"
+    agPlutusV1CostModel <-
+      case Map.toList (costModelsValid cms) of
+        [] -> fail "Expected \"PlutusV1\" cost model to be supplied"
+        [(PlutusV1, pv1CostModel)] -> pure pv1CostModel
+        _ ->
+          fail $
+            "Only PlutusV1 CostModel is allowed in the AlonzoGenesis, but "
+              <> List.intercalate ", " (map show . Map.keys $ flattenCostModels cms)
+              <> " were supplied. Use \"extraConfig\" if you need to inject other cost models for testing."
     return AlonzoGenesis {..}
 
 instance ToKeyValuePairs AlonzoGenesis where
   toKeyValuePairs ag =
     [ "lovelacePerUTxOWord" .= agCoinsPerUTxOWord ag
-    , "costModels" .= agCostModels ag
+    , "costModels" .= mkCostModels (Map.singleton PlutusV1 $ agPlutusV1CostModel ag)
     , "executionPrices" .= agPrices ag
     , "maxTxExUnits" .= agMaxTxExUnits ag
     , "maxBlockExUnits" .= agMaxBlockExUnits ag
     , "maxValueSize" .= agMaxValSize ag
     , "collateralPercentage" .= agCollateralPercentage ag
     , "maxCollateralInputs" .= agMaxCollateralInputs ag
     ]
+      ++ ["extraConfig" .= extraConfig | Just extraConfig <- [agExtraConfig ag]]

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

@@ -8,6 +8,7 @@
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
@@ -96,6 +97,7 @@ import Cardano.Ledger.Plutus.CostModels (
   emptyCostModels,
   getCostModelLanguage,
   getCostModelParams,
+  mkCostModels,
  )
 import Cardano.Ledger.Plutus.ExUnits (
   ExUnits (..),
@@ -106,10 +108,7 @@ import Cardano.Ledger.Plutus.Language (Language (..))
 import Cardano.Ledger.Plutus.ToPlutusData (ToPlutusData (..))
 import Cardano.Ledger.Shelley.PParams
 import Control.DeepSeq (NFData)
-import Data.Aeson as Aeson (
-  FromJSON,
-  ToJSON (..),
- )
+import Data.Aeson (FromJSON (..), ToJSON (..))
 import Data.ByteString (ByteString)
 import qualified Data.ByteString as BS
 import Data.Coerce (coerce)
@@ -410,7 +409,7 @@ instance Ord OrdExUnits where
 -- | Parameters that were added in Alonzo
 data UpgradeAlonzoPParams f = UpgradeAlonzoPParams
   { uappCoinsPerUTxOWord :: !(HKD f CoinPerWord)
-  , uappCostModels :: !(HKD f CostModels)
+  , uappPlutusV1CostModel :: !(HKD f CostModel)
   , uappPrices :: !(HKD f Prices)
   , uappMaxTxExUnits :: !(HKD f ExUnits)
   , uappMaxBlockExUnits :: !(HKD f ExUnits)
@@ -422,7 +421,15 @@ data UpgradeAlonzoPParams f = UpgradeAlonzoPParams
 
 emptyAlonzoUpgradePParamsUpdate :: UpgradeAlonzoPParams StrictMaybe
 emptyAlonzoUpgradePParamsUpdate =
-  UpgradeAlonzoPParams SNothing SNothing SNothing SNothing SNothing SNothing SNothing SNothing
+  UpgradeAlonzoPParams
+    SNothing
+    SNothing
+    SNothing
+    SNothing
+    SNothing
+    SNothing
+    SNothing
+    SNothing
 
 deriving instance Eq (UpgradeAlonzoPParams Identity)
 
@@ -436,7 +443,7 @@ instance Default (UpgradeAlonzoPParams StrictMaybe) where
   def =
     UpgradeAlonzoPParams
       { uappCoinsPerUTxOWord = SNothing
-      , uappCostModels = SNothing
+      , uappPlutusV1CostModel = SNothing
       , uappPrices = SNothing
       , uappMaxTxExUnits = SNothing
       , uappMaxBlockExUnits = SNothing
@@ -605,7 +612,7 @@ upgradeAlonzoPParams UpgradeAlonzoPParams {..} ShelleyPParams {..} =
     , appMinPoolCost = sppMinPoolCost
     , -- new in alonzo
       appCoinsPerUTxOWord = uappCoinsPerUTxOWord
-    , appCostModels = uappCostModels
+    , appCostModels = hkdMap (Proxy @f) (mkCostModels . Map.singleton PlutusV1) uappPlutusV1CostModel
     , appPrices = uappPrices
     , appMaxTxExUnits = hkdMap (Proxy @f) OrdExUnits uappMaxTxExUnits
     , appMaxBlockExUnits = hkdMap (Proxy @f) OrdExUnits uappMaxBlockExUnits