Skip to content

Commit

Permalink
Fix reading Plutus V2 cost models with 175 params in Babbage
Browse files Browse the repository at this point in the history
  • Loading branch information
carbolymer committed Jul 8, 2024
1 parent 19da63d commit a0311c6
Show file tree
Hide file tree
Showing 10 changed files with 1,879 additions and 33 deletions.
9 changes: 7 additions & 2 deletions cardano-api/cardano-api.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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
Expand Down Expand Up @@ -192,6 +192,7 @@ library internal
iproute,
memory,
microlens,
microlens-aeson,
mtl,
network,
optparse-applicative-fork,
Expand Down Expand Up @@ -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,
Expand All @@ -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,
Expand All @@ -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
Expand Down
130 changes: 126 additions & 4 deletions cardano-api/internal/Cardano/Api/Genesis.hs
Original file line number Diff line number Diff line change
@@ -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
Expand All @@ -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
Expand All @@ -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
Expand All @@ -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)

Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -243,7 +354,7 @@ alonzoGenesisDefaults =
where
apiCostModels =
mkCostModelsLenient $
Map.fromList
fromList
[ (fromIntegral $ fromEnum PlutusV1, defaultV1CostModel)
, (fromIntegral $ fromEnum PlutusV2, defaultV2CostModel)
]
Expand Down Expand Up @@ -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
]
Loading

0 comments on commit a0311c6

Please sign in to comment.