Fix reading of Plutus V2 cost models with different lengths in AlonzoGenesis in different eras

cardano-api/cardano-api.cabal

@@ -46,7 +46,7 @@ common maybe-Win32
     build-depends: Win32
 
 common text
-  if impl(ghc == 8.10.7)&& os(darwin)&& arch(aarch64)
+  if impl(ghc == 8.10.7)&& os(osx)&& arch(aarch64)
     build-depends: text >=1.2.5.0
   else
     build-depends: text >=2.0
@@ -192,6 +192,7 @@ library internal
     iproute,
     memory,
     microlens,
+    microlens-aeson,
     mtl,
     network,
     optparse-applicative-fork,
@@ -313,11 +314,13 @@ test-suite cardano-api-test
     cardano-crypto-class ^>=2.1.2,
     cardano-crypto-test ^>=1.5,
     cardano-crypto-tests ^>=2.1,
+    cardano-ledger-alonzo,
     cardano-ledger-api ^>=1.9,
     cardano-ledger-binary,
     cardano-ledger-core:{cardano-ledger-core, testlib} >=1.8,
     cardano-protocol-tpraos,
     cardano-slotting,
+    cborg,
     containers,
     directory,
     hedgehog >=1.1,
@@ -329,6 +332,7 @@ test-suite cardano-api-test
     ouroboros-consensus-cardano,
     ouroboros-consensus-protocol,
     ouroboros-network-api,
+    plutus-ledger-api,
     tasty,
     tasty-hedgehog,
     tasty-quickcheck,
@@ -338,6 +342,7 @@ test-suite cardano-api-test
     Test.Cardano.Api.Crypto
     Test.Cardano.Api.EpochLeadership
     Test.Cardano.Api.Eras
+    Test.Cardano.Api.Genesis
     Test.Cardano.Api.IO
     Test.Cardano.Api.Json
     Test.Cardano.Api.KeysByron

cardano-api/internal/Cardano/Api/Genesis.hs

@@ -1,10 +1,18 @@
 {-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GADTs #-}
 {-# LANGUAGE GeneralisedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeOperators #-}
 
 module Cardano.Api.Genesis
   ( ShelleyGenesis (..)
   , shelleyGenesisDefaults
   , alonzoGenesisDefaults
+  , decodeAlonzoGenesis
   , conwayGenesisDefaults
 
     -- ** Configuration
@@ -26,7 +34,10 @@ module Cardano.Api.Genesis
   )
 where
 
+import           Cardano.Api.Eon.ConwayEraOnwards
+import           Cardano.Api.Eras.Core
 import           Cardano.Api.IO
+import           Cardano.Api.Monad.Error
 import           Cardano.Api.Utils (unsafeBoundedRational)
 
 import qualified Cardano.Chain.Genesis
@@ -42,25 +53,38 @@ import           Cardano.Ledger.Conway.PParams (DRepVotingThresholds (..),
                    PoolVotingThresholds (..), UpgradeConwayPParams (..))
 import           Cardano.Ledger.Crypto (StandardCrypto)
 import           Cardano.Ledger.Plutus (Language (..))
+import qualified Cardano.Ledger.Plutus as L
 import           Cardano.Ledger.Plutus.CostModels (mkCostModelsLenient)
 import           Cardano.Ledger.Shelley.Core
 import           Cardano.Ledger.Shelley.Genesis (NominalDiffTimeMicro, ShelleyGenesis (..),
                    emptyGenesisStaking)
 import qualified Cardano.Ledger.Shelley.Genesis as Ledger
 import qualified Ouroboros.Consensus.Shelley.Eras as Shelley
+import qualified PlutusLedgerApi.V2 as V2
 
+import           Control.Monad
 import           Control.Monad.Trans.Fail.String (errorFail)
+import qualified Data.Aeson as A
 import           Data.ByteString (ByteString)
+import qualified Data.ByteString.Lazy as LBS
 import qualified Data.Default.Class as DefaultClass
 import           Data.Functor.Identity (Identity)
+import           Data.Int (Int64)
+import           Data.List (sortOn)
 import qualified Data.ListMap as ListMap
-import qualified Data.Map.Strict as Map
+import           Data.Map (Map)
+import qualified Data.Map.Strict as M
+import           Data.Maybe
 import           Data.Ratio
+import qualified Data.Set as S
 import           Data.Text (Text)
 import qualified Data.Time as Time
 import           Data.Typeable
+import qualified Data.Vector as V
+import           GHC.Exts (IsList (..))
 import           GHC.Stack (HasCallStack)
 import           Lens.Micro
+import qualified Lens.Micro.Aeson as AL
 
 import           Test.Cardano.Ledger.Core.Rational ((%!))
 import           Test.Cardano.Ledger.Plutus (testingCostModelV3)
@@ -148,7 +172,7 @@ shelleyGenesisDefaults =
           & ppRhoL .~ unsafeBR (1 % 10) -- How much of reserves goes into pot
           & ppTauL .~ unsafeBR (1 % 10) -- τ * remaining_reserves is sent to treasury every epoch
     , -- genesis keys and initial funds
-      sgGenDelegs = Map.empty
+      sgGenDelegs = M.empty
     , sgStaking = emptyGenesisStaking
     , sgInitialFunds = ListMap.empty
     , sgMaxLovelaceSupply = 0
@@ -160,7 +184,7 @@ shelleyGenesisDefaults =
   unsafeBR = unsafeBoundedRational
 
 -- | Some reasonable starting defaults for constructing a 'ConwayGenesis'.
--- | Based on https://github.com/IntersectMBO/cardano-node/blob/master/cardano-testnet/src/Testnet/Defaults.hs
+-- Based on https://github.com/IntersectMBO/cardano-node/blob/master/cardano-testnet/src/Testnet/Defaults.hs
 conwayGenesisDefaults :: ConwayGenesis StandardCrypto
 conwayGenesisDefaults =
   ConwayGenesis
@@ -211,10 +235,116 @@ conwayGenesisDefaults =
         , dvtCommitteeNoConfidence = 0 %! 1
         }
 
+-- | Decode Alonzo genesis in an optionally era sensitive way.
+--
+-- Because the Plutus V2 cost model has changed between Babbage and Conway era, we need to know the era if we
+-- want to decde Alonzo Genesis with a cost model baked in. If the V2 cost model is present in genesis, you
+-- need to provide an era witness.
+--
+-- When an era witness is provided, for Plutus V2 model the function additionally:
+-- 1. Does extra cost model parameters name validation: Checks for mandatory 175 parameters if provided in
+--    a map form.
+-- 2. If >= Conway: adds defaults for new 10 parameters, if they were not provided (maxBound)
+-- 3. Removes extra parameters above the max count: Babbage - 175, Conway - 185.
+decodeAlonzoGenesis
+  :: forall era t m
+   . MonadTransError String t m
+  => Maybe (CardanoEra era)
+  -- ^ An optional era witness in which we're reading the genesis
+  -> LBS.ByteString
+  -- ^ Genesis JSON
+  -> t m AlonzoGenesis
+decodeAlonzoGenesis Nothing genesisBs =
+  modifyError ("Cannot decode Alonzo genesis: " <>) $
+    liftEither $
+      A.eitherDecode genesisBs
+decodeAlonzoGenesis (Just era) genesisBs = modifyError ("Cannot decode era-sensitive Alonzo genesis: " <>) $ do
+  genesisValue :: A.Value <- liftEither $ A.eitherDecode genesisBs
+  -- Making a fixup of a costmodel is easier before JSON deserialization. This also saves us from building
+  -- plutus' EvaluationContext one more time after cost model update.
+  genesisValue' <-
+    (AL.key "costModels" . AL.key "PlutusV2" . AL._Value) setCostModelDefaultValues genesisValue
+  fromJsonE genesisValue'
+ where
+  setCostModelDefaultValues :: A.Value -> ExceptT String m A.Value
+  setCostModelDefaultValues = \case
+    obj@(A.Object _) -> do
+      -- decode cost model into a map first
+      costModel :: Map V2.ParamName Int64 <-
+        modifyError ("Decoding cost model object: " <>) $ fromJsonE obj
+
+      let costModelWithDefaults =
+            sortOn fst
+              . toList
+              $ M.union costModel optionalCostModelDefaultValues
+
+      -- check that we have all required params
+      unless (allCostModelParams == (fst <$> costModelWithDefaults)) $ do
+        let allCostModelParamsSet = fromList allCostModelParams
+            providedCostModelParamsSet = fromList $ fst <$> costModelWithDefaults
+        throwError $
+          "Missing V2 Plutus cost model parameters: "
+            <> show (toList $ S.difference allCostModelParamsSet providedCostModelParamsSet)
+
+      -- We have already have required params, we already added optional ones (which are trimmed later
+      -- if required). Continue processing further in array representation.
+      setCostModelDefaultValues . A.toJSON $ map snd costModelWithDefaults
+    A.Array vec
+      -- here we rely on an assumption that params are in correct order, so that we can take only the
+      -- required ones for an era
+      | V.length vec < costModelExpectedCount ->
+          pure . A.Array . V.take costModelExpectedCount $
+            vec <> (A.toJSON . snd <$> optionalCostModelDefaultValues)
+      | V.length vec > costModelExpectedCount -> pure . A.Array $ V.take costModelExpectedCount vec
+    other -> pure other
+
+  -- Plutus V2 params expected count depending on an era
+  costModelExpectedCount :: Int
+  costModelExpectedCount
+    -- use all available parameters >= conway
+    | isConwayOnwards = length allCostModelParams
+    -- use only required params in < conway
+    | otherwise = L.costModelParamsCount L.PlutusV2 -- Babbage
+
+  -- A list-like of tuples (param name, value) with default maxBound value
+  optionalCostModelDefaultValues :: (Item l ~ (V2.ParamName, Int64), IsList l) => l
+  optionalCostModelDefaultValues = fromList $ map (,maxBound) optionalV2costModelParams
+
+  allCostModelParams :: [V2.ParamName]
+  allCostModelParams = [minBound .. maxBound]
+
+  -- The new V2 cost model params introduced in Conway
+  optionalV2costModelParams :: [V2.ParamName]
+  optionalV2costModelParams =
+    [ V2.IntegerToByteString'cpu'arguments'c0
+    , V2.IntegerToByteString'cpu'arguments'c1
+    , V2.IntegerToByteString'cpu'arguments'c2
+    , V2.IntegerToByteString'memory'arguments'intercept
+    , V2.IntegerToByteString'memory'arguments'slope
+    , V2.ByteStringToInteger'cpu'arguments'c0
+    , V2.ByteStringToInteger'cpu'arguments'c1
+    , V2.ByteStringToInteger'cpu'arguments'c2
+    , V2.ByteStringToInteger'memory'arguments'intercept
+    , V2.ByteStringToInteger'memory'arguments'slope
+    ]
+
+  fromJsonE :: A.FromJSON a => A.Value -> ExceptT String m a
+  fromJsonE v =
+    case A.fromJSON v of
+      A.Success a -> pure a
+      A.Error e -> throwError e
+
+  isConwayOnwards = isJust $ forEraMaybeEon @ConwayEraOnwards era
+
 -- | Some reasonable starting defaults for constructing a 'AlonzoGenesis'.
--- | Based on https://github.com/IntersectMBO/cardano-node/blob/master/cardano-testnet/src/Testnet/Defaults.hs
-alonzoGenesisDefaults :: AlonzoGenesis
-alonzoGenesisDefaults =
+-- Based on https://github.com/IntersectMBO/cardano-node/blob/master/cardano-testnet/src/Testnet/Defaults.hs
+-- The era determines Plutus V2 cost model parameters:
+-- * Conway: 185
+-- * <= Babbage: 175
+alonzoGenesisDefaults
+  :: CardanoEra era
+  -> AlonzoGenesis
+alonzoGenesisDefaults era =
   AlonzoGenesis
     { agPrices =
         Prices
@@ -240,7 +370,7 @@ alonzoGenesisDefaults =
  where
   apiCostModels =
     mkCostModelsLenient $
-      Map.fromList
+      fromList
         [ (fromIntegral $ fromEnum PlutusV1, defaultV1CostModel)
         , (fromIntegral $ fromEnum PlutusV2, defaultV2CostModel)
         ]
@@ -590,3 +720,20 @@ alonzoGenesisDefaults =
       , 32947
       , 10
       ]
+        <> defaultV2CostModelNewConwayParams
+
+    -- New Conway cost model parameters
+    defaultV2CostModelNewConwayParams =
+      monoidForEraInEon @ConwayEraOnwards era $
+        const
+          [ 1292075
+          , 24469
+          , 74
+          , 0
+          , 1
+          , 936157
+          , 49601
+          , 237
+          , 0
+          , 1
+          ]