From 41c4a2e8339eafed26b70e9274b18ad91afb9c12 Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Tue, 18 May 2021 16:03:05 +0100 Subject: [PATCH] Fix chairman test by generating the shelley genesis JSON with Alonzo parameters --- .../src/Cardano/CLI/Shelley/Orphans.hs | 135 ++++++++++++-- .../src/Cardano/CLI/Shelley/Run/Genesis.hs | 172 +++++++++--------- cardano-node/cardano-node.cabal | 1 + cardano-node/src/Cardano/Node/Orphans.hs | 100 +++++++--- .../src/Cardano/Node/Protocol/Alonzo.hs | 73 +------- .../cardano/shelley_qa-shelley-genesis.json | 2 +- scripts/byron-to-alonzo/mkfiles.sh | 2 +- 7 files changed, 292 insertions(+), 193 deletions(-) diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Orphans.hs b/cardano-cli/src/Cardano/CLI/Shelley/Orphans.hs index d989b846bf8..be86cc27f78 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Orphans.hs +++ b/cardano-cli/src/Cardano/CLI/Shelley/Orphans.hs @@ -16,15 +16,22 @@ module Cardano.CLI.Shelley.Orphans () where import Cardano.Prelude +import Control.Monad import Control.SetAlgebra as SetAlgebra import Data.Aeson +import qualified Data.Aeson as Aeson +import Data.Aeson.Types (toJSONKeyText) import qualified Data.ByteString.Base16 as Base16 +import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString.Short as SBS +import qualified Data.Map.Strict as Map +import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import Cardano.Api.Orphans () import Cardano.Crypto.Hash.Class as Crypto +import Cardano.Ledger.Alonzo.Language (Language) import Ouroboros.Consensus.Byron.Ledger.Block (ByronHash (..)) import Ouroboros.Consensus.HardFork.Combinator (OneEraHash (..)) @@ -46,10 +53,16 @@ import Shelley.Spec.Ledger.TxBody (TxId (..)) import qualified Cardano.Ledger.Mary.Value as Ledger.Mary +import qualified Cardano.Ledger.Alonzo.Language as Alonzo import qualified Cardano.Ledger.Alonzo.Scripts as Alonzo import Cardano.Ledger.Alonzo.Translation (AlonzoGenesis (..)) import qualified Cardano.Ledger.Alonzo.Translation as Alonzo +import qualified PlutusCore.Evaluation.Machine.ExBudgeting as Plutus +import qualified PlutusCore.Evaluation.Machine.ExBudgetingDefaults as Plutus + +import Data.MemoBytes (MemoBytes) + instance ToJSON (OneEraHash xs) where toJSON = toJSON . Text.decodeLatin1 @@ -103,8 +116,6 @@ instance (ToJSONKey k, ToJSON v) => ToJSON (SetAlgebra.BiMap v k v) where -deriving instance FromJSON Alonzo.ExUnits -deriving instance FromJSON Alonzo.Prices -- We defer parsing of the cost model so that we can -- read it as a filepath. This is to reduce further pollution @@ -112,20 +123,106 @@ deriving instance FromJSON Alonzo.Prices instance FromJSON Alonzo.AlonzoGenesis where parseJSON = withObject "Alonzo Genesis" $ \o -> do - adaPerUTxOWord <- o .: "adaPerUTxOWord" - prices <- o .: "executionPrices" - maxTxExUnits <- o .: "maxTxExUnits" - maxBlockExUnits <- o .: "maxBlockExUnits" - maxValSize <- o .: "maxValueSize" - collateralPercentage <- o .: "collateralPercentage" - maxCollateralInputs <- o .: "maxCollateralInputs" - return Alonzo.AlonzoGenesis { - adaPerUTxOWord, - costmdls = mempty, - prices, - maxTxExUnits, - maxBlockExUnits, - maxValSize, - collateralPercentage, - maxCollateralInputs - } + adaPerUTxOWord <- o .: "adaPerUTxOWord" + cModels <- o .:? "costModels" + prices <- o .: "executionPrices" + maxTxExUnits <- o .: "maxTxExUnits" + maxBlockExUnits <- o .: "maxBlockExUnits" + maxValSize <- o .: "maxValueSize" + collateralPercentage <- o .: "collateralPercentage" + maxCollateralInputs <- o .: "maxCollateralInputs" + case cModels of + Nothing -> + case Plutus.extractModelParams Plutus.defaultCostModel of + Just m -> + return Alonzo.AlonzoGenesis { + adaPerUTxOWord, + costmdls = Map.singleton Alonzo.PlutusV1 (Alonzo.CostModel m), + prices, + maxTxExUnits, + maxBlockExUnits, + maxValSize, + collateralPercentage, + maxCollateralInputs + } + Nothing -> fail "Failed to extract the cost model params from Plutus.defaultCostModel" + Just costmdls -> + return Alonzo.AlonzoGenesis { + adaPerUTxOWord, + costmdls, + prices, + maxTxExUnits, + maxBlockExUnits, + maxValSize, + collateralPercentage, + maxCollateralInputs + } + + +-- We don't render the cost model so that we can +-- render it later in 'AlonzoGenWrapper' as a filepath +-- and keep the cost model (which is chunky) as a separate file. +instance ToJSON AlonzoGenesis where + toJSON v = object + [ "adaPerUTxOWord" .= adaPerUTxOWord v + , "costModels" .= costmdls v + , "executionPrices" .= prices v + , "maxTxExUnits" .= maxTxExUnits v + , "maxBlockExUnits" .= maxBlockExUnits v + , "maxValueSize" .= maxValSize v + , "collateralPercentage" .= collateralPercentage v + , "maxCollateralInputs" .= maxCollateralInputs v + ] + +instance ToJSON Alonzo.ExUnits +deriving instance FromJSON Alonzo.ExUnits + +instance ToJSON Language where + toJSON Alonzo.PlutusV1 = Aeson.String "PlutusV1" + +instance FromJSON Language where + parseJSON v = + case v of + Aeson.String "PlutusV1" -> return Alonzo.PlutusV1 + wrong -> fail $ "Error decoding Language. \ + \Expected a JSON string but got: " <> show wrong + +instance ToJSON Alonzo.CostModel +instance FromJSON Alonzo.CostModel + +instance FromJSON (Data.MemoBytes.MemoBytes (Map Text Integer)) +instance ToJSON (Data.MemoBytes.MemoBytes (Map Text Integer)) + + +instance ToJSONKey Language where + toJSONKey = toJSONKeyText (Text.decodeLatin1 . LBS.toStrict . encode) + +instance FromJSONKey Language where + fromJSONKey = FromJSONKeyText parseLang + where + parseLang :: Text -> Language + parseLang lang = + case eitherDecode $ LBS.fromStrict $ Text.encodeUtf8 lang of + Left err -> panic $ Text.pack err + Right lang' -> lang' + + + +instance ToJSON Alonzo.Prices +deriving instance FromJSON Alonzo.Prices + +instance ToJSON SBS.ShortByteString where + toJSON = Aeson.String + . Text.decodeLatin1 + . Base16.encode + . SBS.fromShort + + +instance FromJSON SBS.ShortByteString where + parseJSON v = case v of + Aeson.String b16 -> + case Base16.decode $ Text.encodeUtf8 b16 of + Right decoded -> return $ SBS.toShort decoded + Left err -> fail err + wrong -> fail $ "Error decoding ShortByteString. \ + \Expected a JSON string but got: " <> show wrong diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Run/Genesis.hs b/cardano-cli/src/Cardano/CLI/Shelley/Run/Genesis.hs index a7fff589a7f..f98d217c70d 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Run/Genesis.hs +++ b/cardano-cli/src/Cardano/CLI/Shelley/Run/Genesis.hs @@ -21,7 +21,6 @@ import Prelude (id) import Data.Aeson import qualified Data.Aeson as Aeson import Data.Aeson.Encode.Pretty (encodePretty) -import qualified Data.Aeson.Types as Aeson import qualified Data.Binary.Get as Bin import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as LBS @@ -64,6 +63,7 @@ import Ouroboros.Consensus.Shelley.Protocol (StandardCrypto) import qualified Cardano.Ledger.Alonzo.Language as Alonzo import qualified Cardano.Ledger.Alonzo.Scripts as Alonzo +import Cardano.Ledger.Alonzo.Translation (AlonzoGenesis (..)) import qualified Cardano.Ledger.Alonzo.Translation as Alonzo import Cardano.Ledger.Coin (Coin (..)) import qualified Shelley.Spec.Ledger.API as Ledger @@ -359,7 +359,11 @@ runGenesisCreate (GenesisDir rootdir) utxoAddrs <- readInitialFundAddresses utxodir network start <- maybe (SystemStart <$> getCurrentTimePlus30) pure mStart - let finalGenesis = updateTemplate start genDlgs mAmount utxoAddrs mempty (Lovelace 0) [] [] template + let finalGenesis = updateTemplate + -- Shelley genesis parameters + start genDlgs mAmount utxoAddrs mempty (Lovelace 0) [] [] template + -- Alono genesis parameters TODO: Parameterize + (Lovelace 10) (Lovelace 1, Lovelace 1) (1,1) (1,1) 1 1 1 writeShelleyGenesis (rootdir "genesis.json") finalGenesis where @@ -442,7 +446,11 @@ runGenesisCreateStaked (GenesisDir rootdir) let poolMap :: Map (Ledger.KeyHash Ledger.Staking StandardCrypto) (Ledger.PoolParams StandardCrypto) poolMap = Map.fromList $ mkDelegationMapEntry <$> delegations delegAddrs = dInitialUtxoAddr <$> delegations - finalGenesis = updateTemplate start genDlgs mNonDlgAmount nonDelegAddrs poolMap stDlgAmount delegAddrs stuffedUtxoAddrs template + finalGenesis = updateTemplate + -- Shelley genesis parameters + start genDlgs mNonDlgAmount nonDelegAddrs poolMap stDlgAmount delegAddrs stuffedUtxoAddrs template + -- Alonzo genesis parameters TODO: Parameterize + (Lovelace 10) (Lovelace 1, Lovelace 1) (1,1) (1,1) 1 1 1 writeShelleyGenesis (rootdir "genesis.json") finalGenesis liftIO $ Text.putStrLn $ mconcat $ @@ -725,29 +733,64 @@ updateTemplate -> [AddressInEra ShelleyEra] -> [AddressInEra ShelleyEra] -> ShelleyGenesis StandardShelley - -> ShelleyGenesis StandardShelley + -- Alonzo genesis parameters + -> Lovelace + -- ^ Ada per UTxO word + -> (Lovelace, Lovelace) + -- ^ Execution prices (memory, steps) + -> (Word64, Word64) + -- ^ Max Tx execution units + -> (Word64, Word64) + -- ^ Max block execution units + -> Natural + -- ^ Max value size + -> Natural + -- ^ Collateral percentage + -> Natural + -- ^ Max collateral inputs + -> (ShelleyGenesis StandardShelley, Alonzo.AlonzoGenesis) updateTemplate (SystemStart start) genDelegMap mAmountNonDeleg utxoAddrsNonDeleg poolSpecs (Lovelace amountDeleg) utxoAddrsDeleg stuffedUtxoAddrs - template = - template - { sgSystemStart = start - , sgMaxLovelaceSupply = fromIntegral $ nonDelegCoin + delegCoin - , sgGenDelegs = shelleyDelKeys - , sgInitialFunds = Map.fromList - [ (toShelleyAddr addr, toShelleyLovelace v) - | (addr, v) <- - distribute nonDelegCoin utxoAddrsNonDeleg ++ - distribute delegCoin utxoAddrsDeleg ++ - mkStuffedUtxo stuffedUtxoAddrs ] - , sgStaking = - ShelleyGenesisStaking - { sgsPools = Map.fromList - [ (Ledger._poolId poolParams, poolParams) - | poolParams <- Map.elems poolSpecs ] - , sgsStake = Ledger._poolId <$> poolSpecs + template adaPerUtxoWrd' (exMem,exStep) (maxTxMem, maxTxStep) + (maxBlkMem, maxBlkStep) maxValSize' collPercent maxColInputs = do + + let shelleyGenesis = template + { sgSystemStart = start + , sgMaxLovelaceSupply = fromIntegral $ nonDelegCoin + delegCoin + , sgGenDelegs = shelleyDelKeys + , sgInitialFunds = Map.fromList + [ (toShelleyAddr addr, toShelleyLovelace v) + | (addr, v) <- + distribute nonDelegCoin utxoAddrsNonDeleg ++ + distribute delegCoin utxoAddrsDeleg ++ + mkStuffedUtxo stuffedUtxoAddrs ] + , sgStaking = + ShelleyGenesisStaking + { sgsPools = Map.fromList + [ (Ledger._poolId poolParams, poolParams) + | poolParams <- Map.elems poolSpecs ] + , sgsStake = Ledger._poolId <$> poolSpecs + } } - } + cModel = case Plutus.extractModelParams Plutus.defaultCostModel of + Just m -> + if Alonzo.validateCostModelParams m + then Map.singleton Alonzo.PlutusV1 $ Alonzo.CostModel m + else panic "updateTemplate: Plutus.defaultCostModel is invalid" + + Nothing -> panic "updateTemplate: Could not extract cost model params from Plutus.defaultCostModel" + alonzoGenesis = AlonzoGenesis + { adaPerUTxOWord = toShelleyLovelace adaPerUtxoWrd' + , costmdls = cModel + , prices = Alonzo.Prices (toShelleyLovelace exMem) (toShelleyLovelace exStep) + , maxTxExUnits = Alonzo.ExUnits maxTxMem maxTxStep + , maxBlockExUnits = Alonzo.ExUnits maxBlkMem maxBlkStep + , maxValSize = maxValSize' + , collateralPercentage = collPercent + , maxCollateralInputs = maxColInputs + } + (shelleyGenesis, alonzoGenesis) where nonDelegCoin, delegCoin :: Integer nonDelegCoin = fromIntegral $ fromMaybe (sgMaxLovelaceSupply template) (unLovelace <$> mAmountNonDeleg) @@ -784,11 +827,22 @@ updateTemplate (SystemStart start) unLovelace :: Integral a => Lovelace -> a unLovelace (Lovelace coin) = fromIntegral coin -writeShelleyGenesis :: FilePath -> ShelleyGenesis StandardShelley -> ExceptT ShelleyGenesisCmdError IO () -writeShelleyGenesis fpath sg = - handleIOExceptT (ShelleyGenesisCmdGenesisFileError . FileIOError fpath) $ LBS.writeFile fpath (encodePretty sg) - - +-- We need to include Alonzo genesis parameters +writeShelleyGenesis + :: FilePath + -> (ShelleyGenesis StandardShelley, AlonzoGenesis) + -> ExceptT ShelleyGenesisCmdError IO () +writeShelleyGenesis fpath (sg, ag) = do + let sgValue = toJSON sg + agValue = toJSON ag + genesisCombined <- hoistEither $ combineAndEncode sgValue agValue + handleIOExceptT + (ShelleyGenesisCmdGenesisFileError . FileIOError fpath) + $ LBS.writeFile fpath genesisCombined + where + combineAndEncode :: Aeson.Value -> Aeson.Value -> Either ShelleyGenesisCmdError LBS.ByteString + combineAndEncode (Object sgO) (Object agO) = Right $ encodePretty $ sgO <> agO + combineAndEncode _sgWrong _agWrong = panic "combineAndEncode: Implement ShelleyGenesisCmdError constuctor" -- ------------------------------------------------------------------------------------------------- readGenDelegsMap :: FilePath -> FilePath @@ -946,67 +1000,17 @@ readAlonzoGenesis :: FilePath -> ExceptT ShelleyGenesisCmdError IO Alonzo.AlonzoGenesis readAlonzoGenesis fpath = do - alonzoGenWrapper <- readAndDecode - `catchError` \err -> - case err of - ShelleyGenesisCmdGenesisFileError (FileIOError _ ioe) - | isDoesNotExistError ioe -> panic "Shelley genesis file not found." - _ -> left err - createAlonzoGenesis alonzoGenWrapper + readAndDecode + `catchError` \err -> + case err of + ShelleyGenesisCmdGenesisFileError (FileIOError _ ioe) + | isDoesNotExistError ioe -> panic "Shelley genesis file not found." + _ -> left err where - readAndDecode :: ExceptT ShelleyGenesisCmdError IO AlonzoGenWrapper + readAndDecode :: ExceptT ShelleyGenesisCmdError IO AlonzoGenesis readAndDecode = do lbs <- handleIOExceptT (ShelleyGenesisCmdGenesisFileError . FileIOError fpath) $ LBS.readFile fpath firstExceptT (ShelleyGenesisCmdAesonDecodeError fpath . Text.pack) . hoistEither $ Aeson.eitherDecode' lbs - -createAlonzoGenesis - :: AlonzoGenWrapper - -> ExceptT ShelleyGenesisCmdError IO Alonzo.AlonzoGenesis -createAlonzoGenesis (AlonzoGenWrapper costModelFp' alonzoGenesis) = - case costModelFp' of - Just fp -> do - costModel <- readAndDecode fp - case Plutus.extractModelParams costModel of - -- TODO: We should not be using functions directly from the plutus repo - -- These should be exposed via the ledger - Just m -> -- if Plutus.validateCostModelParams m - -- then left $ ShelleyGenesisCmdCostModelsError costModelFp' - -- else - --TODO: Plutus repo needs to expose a cost model validation function - return $ alonzoGenesis { Alonzo.costmdls = Map.singleton Alonzo.PlutusV1 $ Alonzo.CostModel m } - - Nothing -> panic "createAlonzoGenesis: not implemented yet" - Nothing -> - case Plutus.extractModelParams Plutus.defaultCostModel of - Just m -> - if Alonzo.validateCostModelParams m - then return $ alonzoGenesis { Alonzo.costmdls = Map.singleton Alonzo.PlutusV1 $ Alonzo.CostModel m } - else panic "createAlonzoGenesis: Plutus.defaultCostModel is invalid" - - Nothing -> panic "createAlonzoGenesis: Could not extract cost model params from Plutus.defaultCostModel" - where - readAndDecode :: FilePath -> ExceptT ShelleyGenesisCmdError IO Plutus.CostModel - readAndDecode fp = do - lbs <- handleIOExceptT (ShelleyGenesisCmdGenesisFileError . FileIOError fp) $ LBS.readFile fp - firstExceptT (ShelleyGenesisCmdAesonDecodeError fp . Text.pack) - . hoistEither $ Aeson.eitherDecode' lbs - - -data AlonzoGenWrapper = - AlonzoGenWrapper { costModelFp :: Maybe FilePath - , genesis :: Alonzo.AlonzoGenesis - } - -instance FromJSON AlonzoGenWrapper where - parseJSON = withObject "Alonzo Genesis Wrapper" $ \o -> do - -- NB: This has an empty map for the cost model - alonzoGenensis <- parseJSON (Aeson.Object o) :: Aeson.Parser Alonzo.AlonzoGenesis - cModelFp <- o .:? "costModel" - return $ AlonzoGenWrapper - { costModelFp = cModelFp - , genesis = alonzoGenensis - } - diff --git a/cardano-node/cardano-node.cabal b/cardano-node/cardano-node.cabal index f80bc89ed0b..9076fdd49b5 100644 --- a/cardano-node/cardano-node.cabal +++ b/cardano-node/cardano-node.cabal @@ -142,6 +142,7 @@ library , safe-exceptions , scientific , shelley-spec-ledger + , small-steps , stm , text , time diff --git a/cardano-node/src/Cardano/Node/Orphans.hs b/cardano-node/src/Cardano/Node/Orphans.hs index ee5c56c4960..37461792175 100644 --- a/cardano-node/src/Cardano/Node/Orphans.hs +++ b/cardano-node/src/Cardano/Node/Orphans.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE StandaloneDeriving #-} @@ -13,20 +12,32 @@ import Prelude (fail) import Cardano.Api.Orphans () -import Data.Aeson (FromJSON (..), ToJSON (..), ToJSONKey, Value (..), - withObject, (.:)) +import Data.Aeson (eitherDecode) +import qualified Data.Aeson as Aeson +import Data.Aeson.Types +import qualified Data.ByteString.Base16 as Base16 +import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString.Short as SBS +import qualified Data.Map.Strict as Map +import Data.MemoBytes (MemoBytes) import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text import Cardano.BM.Data.Tracer (TracingVerbosity (..)) import qualified Cardano.Chain.Update as Update import qualified Cardano.Ledger.Alonzo as Alonzo +import Cardano.Ledger.Alonzo.Language import qualified Cardano.Ledger.Alonzo.Language as Alonzo import qualified Cardano.Ledger.Alonzo.PParams as Alonzo import qualified Cardano.Ledger.Alonzo.Scripts as Alonzo -import Cardano.Ledger.Alonzo.Translation (AlonzoGenesis (..)) +import Cardano.Ledger.Alonzo.Translation as Alonzo import Ouroboros.Consensus.Shelley.Protocol.Crypto (StandardCrypto) import qualified Shelley.Spec.Ledger.CompactAddr as Shelley +-- TODO: Remove me, cli should not depend directly on plutus repo. +import qualified PlutusCore.Evaluation.Machine.ExBudgeting as Plutus +import qualified PlutusCore.Evaluation.Machine.ExBudgetingDefaults as Plutus + instance FromJSON TracingVerbosity where parseJSON (String str) = case str of "MinimalVerbosity" -> pure MinimalVerbosity @@ -67,23 +78,68 @@ instance FromJSON Update.ApplicationName where -- We defer parsing of the cost model so that we can -- read it as a filepath. This is to reduce further pollution -- of the genesis file. -instance FromJSON AlonzoGenesis where +instance FromJSON Alonzo.AlonzoGenesis where parseJSON = withObject "Alonzo Genesis" $ \o -> do - adaPerUTxOWord <- o .: "adaPerUTxOWord" - prices <- o .: "executionPrices" - maxTxExUnits <- o .: "maxTxExUnits" - maxBlockExUnits <- o .: "maxBlockExUnits" - maxValSize <- o .: "maxValueSize" - collateralPercentage <- o .: "collateralPercentage" - maxCollateralInputs <- o .: "maxCollateralInputs" - return AlonzoGenesis { - adaPerUTxOWord, - costmdls = mempty, - prices, - maxTxExUnits, - maxBlockExUnits, - maxValSize, - collateralPercentage, - maxCollateralInputs - } + adaPerUTxOWord <- o .: "adaPerUTxOWord" + cModels <- o .:? "costModels" + prices <- o .: "executionPrices" + maxTxExUnits <- o .: "maxTxExUnits" + maxBlockExUnits <- o .: "maxBlockExUnits" + maxValSize <- o .: "maxValueSize" + collateralPercentage <- o .: "collateralPercentage" + maxCollateralInputs <- o .: "maxCollateralInputs" + case cModels of + Nothing -> + case Plutus.extractModelParams Plutus.defaultCostModel of + Just m -> + return Alonzo.AlonzoGenesis { + adaPerUTxOWord, + costmdls = Map.singleton Alonzo.PlutusV1 (Alonzo.CostModel m), + prices, + maxTxExUnits, + maxBlockExUnits, + maxValSize, + collateralPercentage, + maxCollateralInputs + } + Nothing -> fail "Failed to extract the cost model params from Plutus.defaultCostModel" + Just costmdls -> + return Alonzo.AlonzoGenesis { + adaPerUTxOWord, + costmdls, + prices, + maxTxExUnits, + maxBlockExUnits, + maxValSize, + collateralPercentage, + maxCollateralInputs + } + +instance FromJSON Language where + parseJSON v = + case v of + Aeson.String "PlutusV1" -> return Alonzo.PlutusV1 + wrong -> fail $ "Error decoding Language. \ + \Expected a JSON string but got: " <> show wrong + +instance FromJSONKey Language where + fromJSONKey = FromJSONKeyText parseLang + where + parseLang :: Text -> Language + parseLang lang = + case eitherDecode $ LBS.fromStrict $ Text.encodeUtf8 lang of + Left err -> panic $ Text.pack err + Right lang' -> lang' + +instance FromJSON Alonzo.CostModel +instance FromJSON (Data.MemoBytes.MemoBytes (Map Text Integer)) + +instance FromJSON SBS.ShortByteString where + parseJSON v = case v of + Aeson.String b16 -> + case Base16.decode $ Text.encodeUtf8 b16 of + Right decoded -> return $ SBS.toShort decoded + Left err -> fail err + wrong -> fail $ "Error decoding ShortByteString. \ + \Expected a JSON string but got: " <> show wrong diff --git a/cardano-node/src/Cardano/Node/Protocol/Alonzo.hs b/cardano-node/src/Cardano/Node/Protocol/Alonzo.hs index b1b78bb3a11..ce889b0bc04 100644 --- a/cardano-node/src/Cardano/Node/Protocol/Alonzo.hs +++ b/cardano-node/src/Cardano/Node/Protocol/Alonzo.hs @@ -1,5 +1,4 @@ {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} module Cardano.Node.Protocol.Alonzo @@ -14,22 +13,13 @@ import Cardano.Prelude import Cardano.Api import Control.Monad.Trans.Except.Extra (firstExceptT, handleIOExceptT, hoistEither, left) -import Data.Aeson (FromJSON (..), withObject, (.:?)) import qualified Data.Aeson as Aeson -import qualified Data.Aeson.Types as Aeson import qualified Data.ByteString.Lazy as LBS -import qualified Data.Map as Map import qualified Data.Text as Text import System.IO.Error (isDoesNotExistError) -import qualified Cardano.Ledger.Alonzo.Language as Alonzo -import qualified Cardano.Ledger.Alonzo.Scripts as Alonzo import qualified Cardano.Ledger.Alonzo.Translation as Alonzo --- TODO: Remove me, cli should not depend directly on plutus repo. -import qualified PlutusCore.Evaluation.Machine.ExBudgeting as Plutus -import qualified PlutusCore.Evaluation.Machine.ExBudgetingDefaults as Plutus - import Cardano.Node.Orphans () @@ -50,69 +40,20 @@ readAlonzoGenesis :: FilePath -> ExceptT AlonzoProtocolInstantiationError IO Alonzo.AlonzoGenesis readAlonzoGenesis fpath = do - alonzoGenWrapper <- readAndDecode - `catchError` \err -> - case err of - AlonzoGenesisFileError (FileIOError _ ioe) - | isDoesNotExistError ioe -> left $ GenesisFileNotFound fpath - _ -> left err - createAlonzoGenesis alonzoGenWrapper - + readAndDecode + `catchError` \err -> + case err of + AlonzoGenesisFileError (FileIOError _ ioe) + | isDoesNotExistError ioe -> left $ GenesisFileNotFound fpath + _ -> left err where - readAndDecode :: ExceptT AlonzoProtocolInstantiationError IO AlonzoGenWrapper + readAndDecode :: ExceptT AlonzoProtocolInstantiationError IO Alonzo.AlonzoGenesis readAndDecode = do lbs <- handleIOExceptT (AlonzoGenesisFileError . FileIOError fpath) $ LBS.readFile fpath firstExceptT (AlonzoGenesisDecodeError fpath . Text.pack) . hoistEither $ Aeson.eitherDecode' lbs -createAlonzoGenesis - :: AlonzoGenWrapper - -> ExceptT AlonzoProtocolInstantiationError IO Alonzo.AlonzoGenesis -createAlonzoGenesis (AlonzoGenWrapper costModelFp' alonzoGenesis) = - case costModelFp' of - Just fp -> do - costModel <- readAndDecode fp - case Plutus.extractModelParams costModel of - -- TODO: We should not be using functions directly from the plutus repo - -- These should be exposed via the ledger - Just m -> -- if Plutus.validateCostModelParams m - -- then left $ ShelleyGenesisCmdCostModelsError costModelFp' - -- else - --TODO: Plutus repo needs to expose a cost model validation function - return $ alonzoGenesis { Alonzo.costmdls = Map.singleton Alonzo.PlutusV1 $ Alonzo.CostModel m } - - Nothing -> panic "createAlonzoGenesis: not implemented yet" - Nothing -> - case Plutus.extractModelParams Plutus.defaultCostModel of - Just m -> - if Alonzo.validateCostModelParams m - then return $ alonzoGenesis { Alonzo.costmdls = Map.singleton Alonzo.PlutusV1 $ Alonzo.CostModel m } - else panic "createAlonzoGenesis: Plutus.defaultCostModel is invalid" - Nothing -> panic "createAlonzoGenesis: Could not extract cost model params from Plutus.defaultCostModel" - where - readAndDecode :: FilePath -> ExceptT AlonzoProtocolInstantiationError IO Plutus.CostModel - readAndDecode fp = do - lbs <- handleIOExceptT (AlonzoCostModelFileError . FileIOError fp) $ LBS.readFile fp - firstExceptT (AlonzoCostModelDecodeError fp . Text.pack) - . hoistEither $ Aeson.eitherDecode' lbs - - -data AlonzoGenWrapper = - AlonzoGenWrapper { costModelFp :: Maybe FilePath - , genesis :: Alonzo.AlonzoGenesis - } - -instance FromJSON AlonzoGenWrapper where - parseJSON = withObject "Alonzo Genesis Wrapper" $ \o -> do - -- NB: This has an empty map for the cost model - alonzoGenensis <- parseJSON (Aeson.Object o) :: Aeson.Parser Alonzo.AlonzoGenesis - cModelFp <- o .:? "costModel" - return $ AlonzoGenWrapper - { costModelFp = cModelFp - , genesis = alonzoGenensis - } - data AlonzoProtocolInstantiationError = InvalidCostModelError !FilePath | CostModelExtractionError !FilePath diff --git a/configuration/cardano/shelley_qa-shelley-genesis.json b/configuration/cardano/shelley_qa-shelley-genesis.json index 2dd3bcb5bf3..b82c0c166cc 100644 --- a/configuration/cardano/shelley_qa-shelley-genesis.json +++ b/configuration/cardano/shelley_qa-shelley-genesis.json @@ -55,6 +55,6 @@ "maxTxExUnits": 42, "maxBlockExUnits": 42, "maxValueSize": 42, - "costModel": "configuration/cardano/alonzo/shelley_qa_cost-model.json" + "costModels": "configuration/cardano/alonzo/shelley_qa_cost-model.json" } \ No newline at end of file diff --git a/scripts/byron-to-alonzo/mkfiles.sh b/scripts/byron-to-alonzo/mkfiles.sh index 8d92215d2f6..81725e28250 100755 --- a/scripts/byron-to-alonzo/mkfiles.sh +++ b/scripts/byron-to-alonzo/mkfiles.sh @@ -561,7 +561,7 @@ if [ "$1" = "alonzo" ]; then -e 's/LastKnownBlockVersion-Major: 1/LastKnownBlockVersion-Major: 5/' # Update shelley genesis with required Alonzo fields. - alonzogenesisparams='.+ {adaPerUTxOWord: 0, executionPrices: {prMem: 1, prSteps: 1}, maxTxExUnits: {exUnitsMem: 1, exUnitsSteps: 1}, maxBlockExUnits: {exUnitsMem: 1, exUnitsSteps: 1}, maxValueSize: 1000, costModel: "example/shelley/alonzo/costmodel.json", collateralPercentage: 100, maxCollateralInputs: 1}' + alonzogenesisparams='.+ {adaPerUTxOWord: 0, executionPrices: {prMem: 1, prSteps: 1}, maxTxExUnits: {exUnitsMem: 1, exUnitsSteps: 1}, maxBlockExUnits: {exUnitsMem: 1, exUnitsSteps: 1}, maxValueSize: 1000, costModels: "example/shelley/alonzo/costmodel.json", collateralPercentage: 100, maxCollateralInputs: 1}' alonzogenesis=$(jq "${alonzogenesisparams}" < ${ROOT}/shelley/genesis.json) echo "${alonzogenesis}" > ${ROOT}/shelley/genesis.json # Copy the cost model