From 03691911d0dc8611f28944776738f80205a476be Mon Sep 17 00:00:00 2001 From: Mateusz Galazyn Date: Mon, 1 Jul 2024 22:53:53 +0200 Subject: [PATCH] simplify shit --- cardano-api/internal/Cardano/Api/Genesis.hs | 99 ++++++++++--------- cardano-api/internal/Cardano/Api/Orphans.hs | 19 ++++ .../Test/Cardano/Api/Genesis.hs | 13 +-- 3 files changed, 79 insertions(+), 52 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/Genesis.hs b/cardano-api/internal/Cardano/Api/Genesis.hs index 0929a8482a..1bb7dfbcb3 100644 --- a/cardano-api/internal/Cardano/Api/Genesis.hs +++ b/cardano-api/internal/Cardano/Api/Genesis.hs @@ -1,8 +1,11 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralisedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} module Cardano.Api.Genesis ( ShelleyGenesis(..) @@ -32,17 +35,15 @@ module Cardano.Api.Genesis import Cardano.Api.Eon.AlonzoEraOnwards import Cardano.Api.Eon.ConwayEraOnwards -import Cardano.Api.Eon.ShelleyBasedEra import Cardano.Api.Eras.Core import Cardano.Api.IO -import Cardano.Api.Monad.Error (MonadError (throwError), liftEither, liftMaybe) +import Cardano.Api.Monad.Error import Cardano.Api.Utils (unsafeBoundedRational) import qualified Cardano.Chain.Genesis import qualified Cardano.Crypto.Hash.Blake2b import qualified Cardano.Crypto.Hash.Class import Cardano.Ledger.Alonzo.Genesis (AlonzoGenesis (..)) -import qualified Cardano.Ledger.Alonzo.Genesis as L import Cardano.Ledger.Alonzo.Scripts (ExUnits (..), Prices (..)) import Cardano.Ledger.Api (CoinPerWord (..)) import Cardano.Ledger.BaseTypes as Ledger @@ -62,26 +63,24 @@ import qualified Ouroboros.Consensus.Shelley.Eras as Shelley import qualified PlutusLedgerApi.Common as V2 import qualified PlutusLedgerApi.V2 as V2 -import Control.Monad -import Control.Monad.Error.Class (modifyError) import Control.Monad.Trans.Fail.String (errorFail) -import Control.Monad.Trans.Maybe import qualified Data.Aeson as A -import qualified Data.Aeson.KeyMap as A -import Data.Bifunctor (first) 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 Data.Map (Map) import qualified Data.Map.Strict as M -import qualified Data.Map.Strict as Map import Data.Maybe import Data.Ratio 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 @@ -164,7 +163,7 @@ shelleyGenesisDefaults = & 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 @@ -219,29 +218,52 @@ conwayGenesisDefaults = ConwayGenesis { cgUpgradePParams = defaultUpgradeConwayP , dvtCommitteeNoConfidence = 0 %! 1 } -decodeAlonzoGenesis :: MonadError String m +decodeAlonzoGenesis :: forall era t m. MonadTransError String t m => AlonzoEraOnwards era -> LBS.ByteString - -> m AlonzoGenesis + -> t m AlonzoGenesis decodeAlonzoGenesis aeo genesisBs = modifyError ("Cannot decode Alonzo genesis: " <>) $ do genesisValue :: A.Value <- liftEither $ A.eitherDecode genesisBs - let genesisValue' = (AL.key "costModels" . AL.key "PlutusV2" . AL._Object) %~ setDefaultValues $ genesisValue - genesis <- case A.fromJSON genesisValue' of - A.Success a -> pure a - A.Error e -> throwError e - forEraInEon @ConwayEraOnwards (toCardanoEra aeo) - -- chop off v2 params if we're < Conway - (chopOffOptionalV2Params genesis) - (pure . const genesis) + -- 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 - setDefaultValues cm = A.union cm costModelV2Extension + setCostModelDefaultValues :: A.Value -> ExceptT String m A.Value + setCostModelDefaultValues = \case - costModelV2Extension :: A.Object - costModelV2Extension = errorFail $ do - A.Object obj <- pure . A.toJSON . M.fromList $ - zip optionalV2costModelParams (repeat @Int64 maxBound) - pure obj + obj@(A.Object _) -> do + -- decode cost model into a map first + costModel :: Map V2.ParamName Int64 <- modifyError ("Decoding cost model object: " <> ) $ fromJsonE obj + setCostModelDefaultValues + . A.toJSON -- convert to an array representation of Int64 values + . fmap snd + . sortOn fst -- ensure proper order of params in the list + . toList + . (`M.union` costModelDefaultValues) -- add default values of missing params + $ costModel + A.Array vec + | V.length vec < costModelExpectedLength -> pure . A.Array . V.take costModelExpectedLength $ vec <> (A.toJSON <$> optionalCostModelDefaultValues) + | V.length vec > costModelExpectedLength -> pure . A.Array $ V.take costModelExpectedLength vec + + other -> pure other + + costModelExpectedLength :: Int + costModelExpectedLength + | isConwayOnwards = length allCostModelParams + | otherwise = L.costModelParamsCount L.PlutusV2 -- Babbage + + optionalCostModelDefaultValues :: (Item l ~ Int64, IsList l) => l + optionalCostModelDefaultValues = fromList $ replicate (length optionalV2costModelParams) maxBound + + costModelDefaultValues :: Map V2.ParamName Int64 + costModelDefaultValues = fromList $ map (, maxBound) allCostModelParams + + allCostModelParams :: [V2.ParamName] + allCostModelParams = [minBound..maxBound] + + optionalV2costModelParams :: [Text] optionalV2costModelParams = map V2.showParamName [ V2.IntegerToByteString'cpu'arguments'c0 , V2.IntegerToByteString'cpu'arguments'c1 @@ -255,24 +277,13 @@ decodeAlonzoGenesis aeo genesisBs = modifyError ("Cannot decode Alonzo genesis: , V2.ByteStringToInteger'memory'arguments'slope ] - chopOffOptionalV2Params g = fmap (fromMaybe g) . runMaybeT $ do - costModelValues <- hoistMaybe - . fmap L.getCostModelParams - . M.lookup L.PlutusV2 - . L.costModelsValid - $ L.agCostModels g - let expectedParamsCount = L.costModelParamsCount L.PlutusV2 - trimmedParams = take expectedParamsCount costModelValues - -- this is a redundant check, but lets us know that we're doing right things here - when (length trimmedParams /= expectedParamsCount) $ do - throwError $ "Expected " <> show expectedParamsCount <> " V2 cost model parameters, but got " <> show (length trimmedParams) - updatedCostModel <- liftEither . first show $ L.mkCostModel L.PlutusV2 trimmedParams - let updatedCostModels = L.updateCostModels - (L.agCostModels g) - (L.mkCostModels $ M.singleton L.PlutusV2 updatedCostModel) - - pure $ g { L.agCostModels = updatedCostModels } + 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 @@ -293,7 +304,7 @@ alonzoGenesisDefaults = AlonzoGenesis { agPrices = Prices { prSteps = 721 %! 100 , agCoinsPerUTxOWord = CoinPerWord $ Coin 34482 } where - apiCostModels = mkCostModelsLenient $ Map.fromList [ (fromIntegral $ fromEnum PlutusV1, defaultV1CostModel) + apiCostModels = mkCostModelsLenient $ fromList [ (fromIntegral $ fromEnum PlutusV1, defaultV1CostModel) , (fromIntegral $ fromEnum PlutusV2, defaultV2CostModel) ] where diff --git a/cardano-api/internal/Cardano/Api/Orphans.hs b/cardano-api/internal/Cardano/Api/Orphans.hs index dcac5f67a3..cbf9b43e40 100644 --- a/cardano-api/internal/Cardano/Api/Orphans.hs +++ b/cardano-api/internal/Cardano/Api/Orphans.hs @@ -75,10 +75,13 @@ import Ouroboros.Consensus.Shelley.Ledger.Block (ShelleyHash (..)) import qualified Ouroboros.Consensus.Shelley.Ledger.Query as Consensus import Ouroboros.Network.Block (HeaderHash, Tip (..)) import Ouroboros.Network.Mux (MuxError) +import qualified PlutusLedgerApi.Common as P +import qualified PlutusLedgerApi.V2 as V2 import qualified Codec.Binary.Bech32 as Bech32 import qualified Codec.CBOR.Read as CBOR import Data.Aeson (KeyValue ((.=)), ToJSON (..), ToJSONKey (..), object, pairs) +import qualified Data.Aeson as A import qualified Data.Aeson as Aeson import qualified Data.ByteString.Base16 as Base16 import qualified Data.ByteString.Short as SBS @@ -86,6 +89,7 @@ import Data.Data (Data) import Data.Kind (Constraint, Type) import Data.Maybe.Strict (StrictMaybe (..)) import Data.Monoid +import qualified Data.Text as T import qualified Data.Text.Encoding as Text import Data.Typeable (Typeable) import GHC.Generics @@ -479,3 +483,18 @@ lastMappendWithTHKD f a b = Ledger.THKD $ lastMappendWith (Ledger.unTHKD . f) a instance Pretty MuxError where pretty err = "Mux layer error:" <+> prettyException err + +instance A.FromJSON V2.ParamName where + parseJSON = A.withText "ParamName" parsePlutusV2paramName + +instance A.FromJSONKey V2.ParamName where + fromJSONKey = A.FromJSONKeyTextParser parsePlutusV2paramName + +parsePlutusV2paramName :: (P.IsParamName a, MonadFail f) => T.Text -> f a +parsePlutusV2paramName t = + case P.readParamName t of + Just p -> pure p + Nothing -> fail $ "Cannot parse cost model parameter name: " <> T.unpack t + +deriving instance Show V2.ParamName + diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Genesis.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Genesis.hs index 3463b026fc..0ae1509543 100644 --- a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Genesis.hs +++ b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Genesis.hs @@ -1,18 +1,14 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} -{-# OPTIONS_GHC -Wno-orphans #-} - module Test.Cardano.Api.Genesis ( tests ) where import Cardano.Api.Eras import Cardano.Api.Genesis -import Cardano.Api.SerialiseCBOR import Cardano.Api.Shelley import qualified Cardano.Ledger.Alonzo.Genesis as L @@ -39,7 +35,7 @@ prop_reading_plutus_v2_costmodel prop_reading_plutus_v2_costmodel aeo cmf = H.propertyOnce $ do H.noteShow_ $ "Era: " <> pshow aeo H.noteShow_ $ "Cost model type: " <> show cmf - (genesis, costModelValues) <- loadPlutusV2CostModelFromGenesis aeo (getGenesisFile cmf) + (_genesis, costModelValues) <- loadPlutusV2CostModelFromGenesis aeo (getGenesisFile cmf) H.noteShow_ costModelValues @@ -55,6 +51,9 @@ prop_reading_plutus_v2_costmodel aeo cmf = H.propertyOnce $ do else length costModelValues === 175 + -- let genesisBs = CBOR.serialize' genesis + -- genesis' <- H.leftFail $ CBOR.decodeFullDecoder "AlonzoGenesis" CBOR.fromCBOR (LBS.fromStrict genesisBs) -- :: Either CBOR.DecoderError L.AlonzoGenesis + -- TODO test cbor round trip here! -- genesis' -- genesis' === genesis @@ -111,15 +110,13 @@ loadPlutusV2CostModelFromGenesis -> m (L.AlonzoGenesis, [Int64]) loadPlutusV2CostModelFromGenesis aeo filePath = withFrozenCallStack $ do genesisBs <- H.lbsReadFile filePath - genesis <- H.leftFail $ decodeAlonzoGenesis aeo genesisBs + genesis <- H.leftFailM . runExceptT $ decodeAlonzoGenesis aeo genesisBs fmap ((genesis,) . L.getCostModelParams) . H.nothingFail . M.lookup L.PlutusV2 . L.costModelsValid $ L.agCostModels genesis -deriving instance Show V2.ParamName - -- * List all test cases tests :: TestTree