Fix reading Plutus V2 cost models with 175 params in Babbage

cardano-api/cardano-api.cabal

@@ -34,7 +34,7 @@ common project-config
     -Wredundant-constraints
     -Wunused-packages
 
-  if impl(ghc < 9)
+  if impl(ghc <9)
     ghc-options: -Wno-incomplete-patterns
 
 common maybe-unix
@@ -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
 import qualified Cardano.Crypto.Hash.Blake2b
@@ -44,6 +55,7 @@ import Cardano.Ledger.Conway.PParams
   )
 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
@@ -52,19 +64,31 @@ import Cardano.Ledger.Shelley.Genesis
   , emptyGenesisStaking
   )
 import qualified Cardano.Ledger.Shelley.Genesis as Ledger
+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 qualified Ouroboros.Consensus.Shelley.Eras as Shelley
+import qualified PlutusLedgerApi.V2 as V2
 import Test.Cardano.Ledger.Core.Rational ((%!))
 import Test.Cardano.Ledger.Plutus (testingCostModelV3)
 
@@ -151,7 +175,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
@@ -163,7 +187,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
@@ -214,8 +238,109 @@ 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
+-- Based on https://github.com/IntersectMBO/cardano-node/blob/master/cardano-testnet/src/Testnet/Defaults.hs
 alonzoGenesisDefaults :: AlonzoGenesis
 alonzoGenesisDefaults =
   AlonzoGenesis
@@ -243,7 +368,7 @@ alonzoGenesisDefaults =
  where
   apiCostModels =
     mkCostModelsLenient $
-      Map.fromList
+      fromList
         [ (fromIntegral $ fromEnum PlutusV1, defaultV1CostModel)
         , (fromIntegral $ fromEnum PlutusV2, defaultV2CostModel)
         ]
@@ -592,4 +717,15 @@ alonzoGenesisDefaults =
       , 38887044
       , 32947
       , 10
+      , -- New Conway costmodel parameters below
+        1292075
+      , 24469
+      , 74
+      , 0
+      , 1
+      , 936157
+      , 49601
+      , 237
+      , 0
+      , 1
       ]

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

@@ -98,7 +98,7 @@ import Cardano.Api.Block
 import Cardano.Api.Certificate
 import Cardano.Api.Eon.ShelleyBasedEra
 import Cardano.Api.Eras.Case
-import Cardano.Api.Eras.Core (forEraMaybeEon)
+import Cardano.Api.Eras.Core (CardanoEra, forEraMaybeEon)
 import Cardano.Api.Error as Api
 import Cardano.Api.Genesis
 import Cardano.Api.IO
@@ -183,7 +183,7 @@ import qualified Data.ByteArray
 import Data.ByteString (ByteString)
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Base16 as Base16
-import qualified Data.ByteString.Lazy as LB
+import qualified Data.ByteString.Lazy as LBS
 import Data.ByteString.Short as BSS
 import Data.Foldable
 import Data.IORef
@@ -321,7 +321,7 @@ initialLedgerState nodeConfigFile = do
   -- can remove the nodeConfigFile argument and much of the code in this
   -- module.
   config <- modifyError ILSEConfigFile (readNodeConfig nodeConfigFile)
-  genesisConfig <- modifyError ILSEGenesisFile (readCardanoGenesisConfig config)
+  genesisConfig <- modifyError ILSEGenesisFile (readCardanoGenesisConfig Nothing config)
   env <- modifyError ILSELedgerConsensusConfig (except (genesisConfigToEnv genesisConfig))
   let ledgerState = initLedgerStateVar genesisConfig
   return (env, ledgerState)
@@ -1357,12 +1357,13 @@ shelleyPraosNonce genesisHash =
 
 readCardanoGenesisConfig
   :: MonadIOTransError GenesisConfigError t m
-  => NodeConfig
+  => Maybe (CardanoEra era)
+  -> NodeConfig
   -> t m GenesisConfig
-readCardanoGenesisConfig enc = do
+readCardanoGenesisConfig mEra enc = do
   byronGenesis <- readByronGenesisConfig enc
   ShelleyConfig shelleyGenesis shelleyGenesisHash <- readShelleyGenesisConfig enc
-  alonzoGenesis <- readAlonzoGenesisConfig enc
+  alonzoGenesis <- readAlonzoGenesisConfig mEra enc
   conwayGenesis <- readConwayGenesisConfig enc
   let transCfg = Ledger.mkLatestTransitionConfig shelleyGenesis alonzoGenesis conwayGenesis
   pure $ GenesisCardano enc byronGenesis shelleyGenesisHash transCfg
@@ -1440,12 +1441,13 @@ readShelleyGenesisConfig enc = do
 
 readAlonzoGenesisConfig
   :: MonadIOTransError GenesisConfigError t m
-  => NodeConfig
+  => Maybe (CardanoEra era)
+  -> NodeConfig
   -> t m AlonzoGenesis
-readAlonzoGenesisConfig enc = do
+readAlonzoGenesisConfig mEra enc = do
   let file = ncAlonzoGenesisFile enc
   modifyError (NEAlonzoConfig (unFile file) . renderAlonzoGenesisError) $
-    readAlonzoGenesis file (ncAlonzoGenesisHash enc)
+    readAlonzoGenesis mEra file (ncAlonzoGenesisHash enc)
 
 -- | If the conway genesis file does not exist we simply put in a default.
 readConwayGenesisConfig
@@ -1518,17 +1520,19 @@ renderShelleyGenesisError sge =
         ]
 
 readAlonzoGenesis
-  :: forall m t
+  :: forall m t era
    . MonadIOTransError AlonzoGenesisError t m
-  => File AlonzoGenesis 'In
+  => Maybe (CardanoEra era)
+  -> File AlonzoGenesis 'In
   -> GenesisHashAlonzo
   -> t m AlonzoGenesis
-readAlonzoGenesis (File file) expectedGenesisHash = do
+readAlonzoGenesis mEra (File file) expectedGenesisHash = do
   content <-
-    modifyError id $ handleIOExceptT (AlonzoGenesisReadError file . textShow) $ BS.readFile file
-  let genesisHash = GenesisHashAlonzo (Cardano.Crypto.Hash.Class.hashWith id content)
+    modifyError id $ handleIOExceptT (AlonzoGenesisReadError file . textShow) $ LBS.readFile file
+  let genesisHash = GenesisHashAlonzo . Cardano.Crypto.Hash.Class.hashWith id $ LBS.toStrict content
   checkExpectedGenesisHash genesisHash
-  liftEither . first (AlonzoGenesisDecodeError file . Text.pack) $ Aeson.eitherDecodeStrict' content
+  modifyError (AlonzoGenesisDecodeError file . Text.pack) $
+    decodeAlonzoGenesis mEra content
  where
   checkExpectedGenesisHash :: GenesisHashAlonzo -> t m ()
   checkExpectedGenesisHash actual =
@@ -1641,8 +1645,7 @@ renderHash
   :: Cardano.Crypto.Hash.Class.Hash Cardano.Crypto.Hash.Blake2b.Blake2b_256 ByteString -> Text
 renderHash h = Text.decodeUtf8 $ Base16.encode (Cardano.Crypto.Hash.Class.hashToBytes h)
 
-newtype StakeCred
-  = StakeCred {_unStakeCred :: Ledger.Credential 'Ledger.Staking Consensus.StandardCrypto}
+newtype StakeCred = StakeCred {_unStakeCred :: Ledger.Credential 'Ledger.Staking Consensus.StandardCrypto}
   deriving (Eq, Ord)
 
 data Env = Env
@@ -1755,7 +1758,7 @@ unChainHash ch =
 
 data LeadershipError
   = LeaderErrDecodeLedgerStateFailure
-  | LeaderErrDecodeProtocolStateFailure (LB.ByteString, DecoderError)
+  | LeaderErrDecodeProtocolStateFailure (LBS.ByteString, DecoderError)
   | LeaderErrDecodeProtocolEpochStateFailure DecoderError
   | LeaderErrGenesisSlot
   | LeaderErrStakePoolHasNoStake PoolId
@@ -1932,7 +1935,8 @@ isLeadingSlotsTPraos slotRangeOfInterest poolid snapshotPoolDistr eNonce vrfSkey
   let certifiedVrf s = Crypto.evalCertified () (TPraos.mkSeed TPraos.seedL s eNonce) vrfSkey
 
   stakePoolStake <-
-    ShelleyAPI.individualPoolStake <$> Map.lookup poolHash snapshotPoolDistr
+    ShelleyAPI.individualPoolStake
+      <$> Map.lookup poolHash snapshotPoolDistr
       & note (LeaderErrStakePoolHasNoStake poolid)
 
   let isLeader s = TPraos.checkLeaderValue (Crypto.certifiedOutput (certifiedVrf s)) stakePoolStake activeSlotCoeff'