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,11 @@ module Cardano.Api.Genesis
   )
 where
 
+import Cardano.Api.Eon.AlonzoEraOnwards
+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 +56,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 +65,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)
 
@@ -163,7 +188,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 +239,94 @@ conwayGenesisDefaults =
         , dvtCommitteeNoConfidence = 0 %! 1
         }
 
+-- | TODO HADDOCKS
+decodeAlonzoGenesis
+  :: forall era t m
+   . MonadTransError String t m
+  => Maybe (AlonzoEraOnwards era)
+  -- ^ TODO HADDOCKS
+  -> LBS.ByteString
+  -> t m AlonzoGenesis
+decodeAlonzoGenesis Nothing genesisBs =
+  modifyError ("Cannot decode Alonzo genesis: " <>) $
+    liftEither $
+      A.eitherDecode genesisBs
+decodeAlonzoGenesis (Just aeo) 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 (M.fromList 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 < costModelExpectedLength ->
+          pure . A.Array . V.take costModelExpectedLength $
+            vec <> (A.toJSON . snd <$> optionalCostModelDefaultValues)
+      | V.length vec > costModelExpectedLength -> pure . A.Array $ V.take costModelExpectedLength vec
+    other -> pure other
+
+  costModelExpectedLength :: Int
+  costModelExpectedLength
+    -- use all available parameters >= conway
+    | isConwayOnwards = length allCostModelParams
+    -- use only required params in < conway
+    | otherwise = L.costModelParamsCount L.PlutusV2 -- Babbage
+  optionalCostModelDefaultValues :: (Item l ~ (V2.ParamName, Int64), IsList l) => l
+  optionalCostModelDefaultValues = fromList $ map (,maxBound) optionalV2costModelParams
+
+  allCostModelParams :: [V2.ParamName]
+  allCostModelParams = [minBound .. maxBound]
+
+  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 (toCardanoEra aeo)
+
 -- | 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 +354,7 @@ alonzoGenesisDefaults =
  where
   apiCostModels =
     mkCostModelsLenient $
-      Map.fromList
+      fromList
         [ (fromIntegral $ fromEnum PlutusV1, defaultV1CostModel)
         , (fromIntegral $ fromEnum PlutusV2, defaultV2CostModel)
         ]
@@ -592,4 +703,15 @@ alonzoGenesisDefaults =
       , 38887044
       , 32947
       , 10
+      , -- TODO add here those new alonzo cost parametes in conway era
+        1
+      , 2
+      , 3
+      , 4
+      , 5
+      , 6
+      , 7
+      , 8
+      , 9
+      , 0 -- FIXME: REMOVEME
       ]