diff --git a/bench/tx-generator/src/Cardano/Benchmarking/Script/Aeson.hs b/bench/tx-generator/src/Cardano/Benchmarking/Script/Aeson.hs index 353c2f5c2c1..ddaf6b5dbca 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/Script/Aeson.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/Script/Aeson.hs @@ -1,5 +1,6 @@ {-# OPTIONS_GHC -Wno-orphans #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -22,7 +23,7 @@ import qualified Data.Attoparsec.ByteString as Atto import qualified Data.Yaml as Yaml (encode) import Cardano.Api -import Cardano.Api.Shelley (ProtocolParameters) +import qualified Cardano.Ledger.Core as L import Cardano.Benchmarking.Script.Types import Cardano.TxGenerator.Internal.Orphans () @@ -158,5 +159,9 @@ parseJSONFile parser filePath = do parseScriptFileAeson :: FilePath -> IO [Action] parseScriptFileAeson = parseJSONFile fromJSON -readProtocolParametersFile :: FilePath -> IO ProtocolParameters -readProtocolParametersFile = parseJSONFile fromJSON +readProtocolParametersFile :: + () + => L.EraPParams era + => FilePath + -> IO (L.PParams era) +readProtocolParametersFile = parseJSONFile fromJSON diff --git a/bench/tx-generator/src/Cardano/Benchmarking/Script/Core.hs b/bench/tx-generator/src/Cardano/Benchmarking/Script/Core.hs index bee7f6757b1..0a707529442 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/Script/Core.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/Script/Core.hs @@ -18,9 +18,7 @@ module Cardano.Benchmarking.Script.Core where import Cardano.Api -import Cardano.Api.Shelley (PlutusScriptOrReferenceInput (..), ProtocolParameters, - ShelleyLedgerEra, convertToLedgerProtocolParameters, protocolParamMaxTxExUnits, - protocolParamPrices) +import Cardano.Api.Shelley (PlutusScriptOrReferenceInput (..), ShelleyLedgerEra (..), fromAlonzoExUnits, fromAlonzoPrices) import Cardano.Benchmarking.GeneratorTx as GeneratorTx (AsyncBenchmarkControl) import qualified Cardano.Benchmarking.GeneratorTx as GeneratorTx (waitBenchmark, walletBenchmark) @@ -38,6 +36,7 @@ import Cardano.Benchmarking.Script.Types import Cardano.Benchmarking.Types as Core (SubmissionErrorPolicy (..)) import Cardano.Benchmarking.Version as Version import Cardano.Benchmarking.Wallet as Wallet +import qualified Cardano.Ledger.Alonzo.Core as L import qualified Cardano.Ledger.Coin as L import qualified Cardano.Ledger.Core as Ledger import Cardano.Logging hiding (LocalSocket) @@ -62,6 +61,7 @@ import "contra-tracer" Control.Tracer (Tracer (..)) import Data.ByteString.Lazy.Char8 as BSL (writeFile) import Data.Ratio ((%)) import qualified Data.Text as Text (unpack) +import Lens.Micro import Streaming import qualified Streaming.Prelude as Streaming @@ -157,30 +157,62 @@ queryEra = do (return . AnyShelleyBasedEra) era -queryRemoteProtocolParameters :: ActionM ProtocolParameters -queryRemoteProtocolParameters = do +-- | Protocol parameters for an era that is not statically known +data AnyPParams where + AnyPParams :: Ledger.PParams (ShelleyLedgerEra era) -> AnyPParams + +queryRemoteProtocolParameters :: () + => ledgerera ~ (ShelleyLedgerEra era) + => L.AlonzoEraPParams ledgerera -- We need this constraint + -- to satisfy the ToJSON instance. But it's a bit meh, because + -- then we need the era to be alonzo onwards to bring the instance + -- into context (via API's alonzoEraOnwardsConstraints, see + -- https://github.com/IntersectMBO/cardano-api/blob/acc6d1fd427e024802cb74cbfa9a7fb4d669003c/cardano-api/internal/Cardano/Api/Eon/AlonzoEraOnwards.hs#L91). + -- + -- Could we instead define the instances for pre-alonzo here? That would be nicer, + -- because then this code would be Shelley onwards compatible, not Alonzo onwards compatible. + => ShelleyBasedEra era + -> ActionM (Ledger.PParams ledgerera) +queryRemoteProtocolParameters sbe = do localNodeConnectInfo <- getLocalConnectInfo chainTip <- liftIO $ getLocalChainTip localNodeConnectInfo - AnyShelleyBasedEra sbe <- queryEra - let - callQuery :: forall era. - QueryInEra era (Ledger.PParams (ShelleyLedgerEra era)) - -> ActionM ProtocolParameters - callQuery query@(QueryInShelleyBasedEra shelleyEra _) = do - pp <- liftEither . first (Env.TxGenError . TxGenError . show) =<< mapExceptT liftIO (modifyError (Env.TxGenError . TxGenError . show) $ - queryNodeLocalState localNodeConnectInfo (SpecificPoint $ chainTipToChainPoint chainTip) (QueryInEra query)) - let pp' = fromLedgerPParams shelleyEra pp - pparamsFile = "protocol-parameters-queried.json" - liftIO $ BSL.writeFile pparamsFile $ prettyPrintOrdered pp' - traceDebug $ "queryRemoteProtocolParameters : query result saved in: " ++ pparamsFile - return pp' - callQuery $ QueryInShelleyBasedEra sbe QueryProtocolParameters - -getProtocolParameters :: ActionM ProtocolParameters -getProtocolParameters = do + let query = QueryInShelleyBasedEra sbe QueryProtocolParameters + pp <- liftEither . first (Env.TxGenError . TxGenError . show) =<< mapExceptT liftIO (modifyError (Env.TxGenError . TxGenError . show) $ + queryNodeLocalState localNodeConnectInfo (SpecificPoint $ chainTipToChainPoint chainTip) (QueryInEra query)) + let pparamsFile = "protocol-parameters-queried.json" + liftIO $ BSL.writeFile pparamsFile $ prettyPrintOrdered pp + traceDebug $ "queryRemoteProtocolParameters : query result saved in: " ++ pparamsFile + return pp + +getProtocolParameters :: () + => ledgerera ~ (ShelleyLedgerEra era) + => L.AlonzoEraPParams ledgerera + => ShelleyBasedEra era + -> ActionM (Ledger.PParams (ShelleyLedgerEra era)) +getProtocolParameters sbe = do getProtoParamMode >>= \case - ProtocolParameterQuery -> queryRemoteProtocolParameters - ProtocolParameterLocal parameters -> return parameters + ProtocolParameterQuery -> queryRemoteProtocolParameters sbe + ProtocolParameterLocal parameters -> do + -- We can't do that: + -- + -- return parameters + -- + -- and that really is the gist of the problem of getting rid of ProtocolParameters. + -- We can't do that because ProtocolParameterMode is not parameterized by the era. + -- So when we "open" its ProtocolParameterLocal case, we get + -- an existentially quantified era, that doesn't unify with the one + -- we have from this function's prototype. + -- + -- There are two solutions to this: + -- + -- 1. We could make ProtocolParameterMode parameterized by the era. + -- but this propagates to 'Env', which can be OK; + -- because the era is not supposed to change (so far) during a run. + -- 2. We could reify the two eras and check for equality. I remember that + -- Mateusz has been doing that (in places I don't remember at the top of my head). + -- This wouldn't be contaminating the whole Env hierarchy. But could it cause + -- some failures at runtime? + undefined waitForEra :: AnyShelleyBasedEra -> ActionM () waitForEra era = do @@ -259,105 +291,100 @@ benchmarkTxStream sbe txStream targetNodes tps txCount = do evalGenerator :: ShelleyBasedEra era -> Generator -> TxGenTxParams -> ActionM (TxStream IO era) evalGenerator sbe generator txParams@TxGenTxParams{txParamFee = fee} = do networkId <- getEnvNetworkId - protocolParameters <- getProtocolParameters - case convertToLedgerProtocolParameters sbe protocolParameters of - Left err -> throwE (Env.TxGenError (ApiError err)) - Right ledgerParameters -> - case generator of - SecureGenesis wallet genesisKeyName destKeyName -> do - genesis <- getEnvGenesis - destKey <- getEnvKeys destKeyName - destWallet <- getEnvWallets wallet - genesisKey <- getEnvKeys genesisKeyName - (tx, fund) <- firstExceptT Env.TxGenError $ hoistEither $ - shelleyBasedEraConstraints sbe $ - Genesis.genesisSecureInitialFund sbe networkId genesis genesisKey destKey txParams - let - gen = do - walletRefInsertFund destWallet fund - return $ Right tx - return $ Streaming.effect (Streaming.yield <$> gen) - - -- 'Split' combines regular payments and payments for change. - -- There are lists of payments buried in the 'PayWithChange' - -- type conditionally sent back by 'Utils.includeChange', to - -- then be used while partially applied as the @valueSplitter@ - -- in 'sourceToStoreTransactionNew'. - Split walletName payMode payModeChange coins -> do - wallet <- getEnvWallets walletName - (toUTxO, addressOut) <- interpretPayMode sbe payMode - traceDebug $ "split output address : " ++ addressOut - (toUTxOChange, addressChange) <- interpretPayMode sbe payModeChange - traceDebug $ "split change address : " ++ addressChange - let - fundSource = walletSource wallet 1 - inToOut = Utils.includeChange fee coins - txGenerator = genTx sbe ledgerParameters (TxInsCollateralNone, []) feeInEra TxMetadataNone - sourceToStore = sourceToStoreTransactionNew txGenerator fundSource inToOut $ mangleWithChange toUTxOChange toUTxO - return $ Streaming.effect (Streaming.yield <$> sourceToStore) - - -- The 'SplitN' case's call chain is somewhat elaborate. - -- The division is done in 'Utils.inputsToOutputsWithFee' - -- but things are threaded through - -- 'Cardano.Benchmarking.Wallet.mangle' and packed into - -- the transaction assembled by 'sourceToStoreTransactionNew'. - SplitN walletName payMode count -> do - wallet <- getEnvWallets walletName - (toUTxO, addressOut) <- interpretPayMode sbe payMode - traceDebug $ "SplitN output address : " ++ addressOut - let - fundSource = walletSource wallet 1 - inToOut = Utils.inputsToOutputsWithFee fee count - txGenerator = genTx sbe ledgerParameters (TxInsCollateralNone, []) feeInEra TxMetadataNone - sourceToStore = sourceToStoreTransactionNew txGenerator fundSource inToOut (mangle $ repeat toUTxO) - return $ Streaming.effect (Streaming.yield <$> sourceToStore) - - NtoM walletName payMode inputs outputs metadataSize collateralWallet -> do - wallet <- getEnvWallets walletName - collaterals <- selectCollateralFunds sbe collateralWallet - (toUTxO, addressOut) <- interpretPayMode sbe payMode - traceDebug $ "NtoM output address : " ++ addressOut - let - fundSource = walletSource wallet inputs - inToOut = Utils.inputsToOutputsWithFee fee outputs - txGenerator = genTx sbe ledgerParameters collaterals feeInEra (toMetadata sbe metadataSize) - sourceToStore = sourceToStoreTransactionNew txGenerator fundSource inToOut (mangle $ repeat toUTxO) - - fundPreview <- liftIO $ walletPreview wallet inputs - case sourceTransactionPreview txGenerator fundPreview inToOut (mangle $ repeat toUTxO) of - Left err -> traceDebug $ "Error creating Tx preview: " ++ show err - Right tx -> do - let - txSize = txSizeInBytes sbe tx - txFeeEstimate = case toLedgerPParams sbe protocolParameters of - Left{} -> Nothing - Right ledgerPParams -> Just $ - evaluateTransactionFee sbe ledgerPParams (getTxBody tx) (fromIntegral $ inputs + 1) 0 0 -- 1 key witness per tx input + 1 collateral - traceDebug $ "Projected Tx size in bytes: " ++ show txSize - traceDebug $ "Projected Tx fee in Coin: " ++ show txFeeEstimate - -- TODO: possibly emit a warning when (Just txFeeEstimate) is lower than specified by config in TxGenTxParams.txFee - summary_ <- getEnvSummary - forM_ summary_ $ \summary -> do - let summary' = summary { projectedTxSize = Just txSize, projectedTxFee = txFeeEstimate } - setEnvSummary summary' - traceBenchTxSubmit TraceBenchPlutusBudgetSummary summary' - dumpBudgetSummaryIfExisting - - return $ Streaming.effect (Streaming.yield <$> sourceToStore) - - Sequence l -> do - gList <- forM l $ \g -> evalGenerator sbe g txParams - return $ Streaming.for (Streaming.each gList) id - - Cycle g -> Streaming.cycle <$> evalGenerator sbe g txParams - - Take count g -> Streaming.take count <$> evalGenerator sbe g txParams - - RoundRobin l -> do - _gList <- forM l $ \g -> evalGenerator sbe g txParams - error "return $ foldr1 Streaming.interleaves gList" - - OneOf _l -> error "todo: implement Quickcheck style oneOf generator" + let ledgerParameters = getProtocolParameters + case generator of + SecureGenesis wallet genesisKeyName destKeyName -> do + genesis <- getEnvGenesis + destKey <- getEnvKeys destKeyName + destWallet <- getEnvWallets wallet + genesisKey <- getEnvKeys genesisKeyName + (tx, fund) <- firstExceptT Env.TxGenError $ hoistEither $ + shelleyBasedEraConstraints sbe $ + Genesis.genesisSecureInitialFund sbe networkId genesis genesisKey destKey txParams + let + gen = do + walletRefInsertFund destWallet fund + return $ Right tx + return $ Streaming.effect (Streaming.yield <$> gen) + + -- 'Split' combines regular payments and payments for change. + -- There are lists of payments buried in the 'PayWithChange' + -- type conditionally sent back by 'Utils.includeChange', to + -- then be used while partially applied as the @valueSplitter@ + -- in 'sourceToStoreTransactionNew'. + Split walletName payMode payModeChange coins -> do + wallet <- getEnvWallets walletName + (toUTxO, addressOut) <- interpretPayMode sbe payMode + traceDebug $ "split output address : " ++ addressOut + (toUTxOChange, addressChange) <- interpretPayMode sbe payModeChange + traceDebug $ "split change address : " ++ addressChange + let + fundSource = walletSource wallet 1 + inToOut = Utils.includeChange fee coins + txGenerator = genTx sbe ledgerParameters (TxInsCollateralNone, []) feeInEra TxMetadataNone + sourceToStore = sourceToStoreTransactionNew txGenerator fundSource inToOut $ mangleWithChange toUTxOChange toUTxO + return $ Streaming.effect (Streaming.yield <$> sourceToStore) + + -- The 'SplitN' case's call chain is somewhat elaborate. + -- The division is done in 'Utils.inputsToOutputsWithFee' + -- but things are threaded through + -- 'Cardano.Benchmarking.Wallet.mangle' and packed into + -- the transaction assembled by 'sourceToStoreTransactionNew'. + SplitN walletName payMode count -> do + wallet <- getEnvWallets walletName + (toUTxO, addressOut) <- interpretPayMode sbe payMode + traceDebug $ "SplitN output address : " ++ addressOut + let + fundSource = walletSource wallet 1 + inToOut = Utils.inputsToOutputsWithFee fee count + txGenerator = genTx sbe ledgerParameters (TxInsCollateralNone, []) feeInEra TxMetadataNone + sourceToStore = sourceToStoreTransactionNew txGenerator fundSource inToOut (mangle $ repeat toUTxO) + return $ Streaming.effect (Streaming.yield <$> sourceToStore) + + NtoM walletName payMode inputs outputs metadataSize collateralWallet -> do + wallet <- getEnvWallets walletName + collaterals <- selectCollateralFunds sbe collateralWallet + (toUTxO, addressOut) <- interpretPayMode sbe payMode + traceDebug $ "NtoM output address : " ++ addressOut + let + fundSource = walletSource wallet inputs + inToOut = Utils.inputsToOutputsWithFee fee outputs + txGenerator = genTx sbe ledgerParameters collaterals feeInEra (toMetadata sbe metadataSize) + sourceToStore = sourceToStoreTransactionNew txGenerator fundSource inToOut (mangle $ repeat toUTxO) + + fundPreview <- liftIO $ walletPreview wallet inputs + case sourceTransactionPreview txGenerator fundPreview inToOut (mangle $ repeat toUTxO) of + Left err -> traceDebug $ "Error creating Tx preview: " ++ show err + Right tx -> do + let + txSize = txSizeInBytes sbe tx + txFeeEstimate = Just $ + evaluateTransactionFee sbe ledgerParameters (getTxBody tx) (fromIntegral $ inputs + 1) 0 0 -- 1 key witness per tx input + 1 collateral + traceDebug $ "Projected Tx size in bytes: " ++ show txSize + traceDebug $ "Projected Tx fee in Coin: " ++ show txFeeEstimate + -- TODO: possibly emit a warning when (Just txFeeEstimate) is lower than specified by config in TxGenTxParams.txFee + summary_ <- getEnvSummary + forM_ summary_ $ \summary -> do + let summary' = summary { projectedTxSize = Just txSize, projectedTxFee = txFeeEstimate } + setEnvSummary summary' + traceBenchTxSubmit TraceBenchPlutusBudgetSummary summary' + dumpBudgetSummaryIfExisting + + return $ Streaming.effect (Streaming.yield <$> sourceToStore) + + Sequence l -> do + gList <- forM l $ \g -> evalGenerator sbe g txParams + return $ Streaming.for (Streaming.each gList) id + + Cycle g -> Streaming.cycle <$> evalGenerator sbe g txParams + + Take count g -> Streaming.take count <$> evalGenerator sbe g txParams + + RoundRobin l -> do + _gList <- forM l $ \g -> evalGenerator sbe g txParams + error "return $ foldr1 Streaming.interleaves gList" + + OneOf _l -> error "todo: implement Quickcheck style oneOf generator" where feeInEra = Utils.mkTxFee sbe fee @@ -406,16 +433,11 @@ makePlutusContext :: ShelleyBasedEra era -> ScriptSpec -> ActionM (Witness WitCtxTxIn era, ScriptInAnyLang, ScriptData, L.Coin) makePlutusContext sbe ScriptSpec{..} = do - protocolParameters <- getProtocolParameters + protocolParameters <- getProtocolParameters sbe script <- liftIOSafe $ Plutus.readPlutusScript scriptSpecFile - executionUnitPrices <- case protocolParamPrices protocolParameters of - Just x -> return x - Nothing -> throwE $ WalletError "unexpected protocolParamPrices == Nothing in runPlutusBenchmark" - - perTxBudget <- case protocolParamMaxTxExUnits protocolParameters of - Nothing -> liftTxGenError $ TxGenError "Cannot determine protocolParamMaxTxExUnits" - Just b -> return b + let executionUnitPrices = fromAlonzoPrices $ protocolParameters ^. L.ppPricesL + perTxBudget = fromAlonzoExUnits $ protocolParameters ^. L.ppMaxTxExUnitsL traceDebug $ "Plutus auto mode : Available budget per TX: " ++ show perTxBudget (scriptData, scriptRedeemer, executionUnits) <- case scriptSpecBudget of @@ -493,7 +515,7 @@ makePlutusContext sbe ScriptSpec{..} = do liftTxGenError $ TxGenError "runPlutusBenchmark: only Plutus scripts supported" preExecuteScriptAction :: - ProtocolParameters + Ledger.PParams era -> ScriptInAnyLang -> ScriptData -> ScriptData diff --git a/bench/tx-generator/src/Cardano/Benchmarking/Script/Types.hs b/bench/tx-generator/src/Cardano/Benchmarking/Script/Types.hs index ad95fd7376f..5b0ed857b54 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/Script/Types.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/Script/Types.hs @@ -39,8 +39,8 @@ module Cardano.Benchmarking.Script.Types ( ) where import Cardano.Api -import qualified Cardano.Api.Ledger as L import Cardano.Api.Shelley +import qualified Cardano.Api.Ledger as L import Cardano.Benchmarking.OuroborosImports (SigningKeyFile) import Cardano.Node.Configuration.NodeAddress (NodeIPv4Address) @@ -214,4 +214,4 @@ newtype TxList era = TxList [Tx era] data ProtocolParameterMode where ProtocolParameterQuery :: ProtocolParameterMode - ProtocolParameterLocal :: ProtocolParameters -> ProtocolParameterMode + ProtocolParameterLocal :: L.PParams (ShelleyLedgerEra era) -> ProtocolParameterMode diff --git a/bench/tx-generator/src/Cardano/TxGenerator/PlutusContext.hs b/bench/tx-generator/src/Cardano/TxGenerator/PlutusContext.hs index f748286a96c..e7772be452a 100644 --- a/bench/tx-generator/src/Cardano/TxGenerator/PlutusContext.hs +++ b/bench/tx-generator/src/Cardano/TxGenerator/PlutusContext.hs @@ -26,9 +26,11 @@ module Cardano.TxGenerator.PlutusContext where import Cardano.Api -import Cardano.Api.Shelley (ProtocolParameters (..)) +import Cardano.Api.Shelley (fromAlonzoExUnits, toAlonzoExUnits, executionSteps, executionMemory) +import qualified Cardano.Ledger.Alonzo.Core as L import Cardano.Ledger.Coin (Coin) +import qualified Cardano.Ledger.Core as L import Cardano.TxGenerator.Setup.Plutus (preExecutePlutusScript) import Cardano.TxGenerator.Types @@ -38,6 +40,7 @@ import Data.List (maximumBy, minimumBy) import Data.Ord (comparing) import GHC.Generics (Generic) import GHC.Natural (Natural) +import Lens.Micro -- | This collects information describing the budget. It's only @@ -105,8 +108,9 @@ readScriptData jsonFilePath -- | Can find the optimal scaling factor for block expenditure, by aiming at highest -- loop count per block iff TargetBlockExpenditure Nothing is given; -- will calibrate loop for any fully specified fitting strategy otherwise -plutusAutoScaleBlockfit :: - ProtocolParameters +plutusAutoScaleBlockfit :: () + => L.AlonzoEraPParams era + => L.PParams era -> FilePath -> ScriptInAnyLang -> PlutusAutoBudget @@ -151,8 +155,9 @@ plutusAutoScaleBlockfit pparams fp script pab strategy txInputs -- termination value when counting down. -- 2. In the redeemer's argument structure, this value is the first numerical value -- that's encountered during traversal. -plutusAutoBudgetMaxOut :: - ProtocolParameters +plutusAutoBudgetMaxOut :: () + => L.AlonzoEraPParams era + => L.PParams era -> ScriptInAnyLang -> PlutusAutoBudget -> PlutusBudgetFittingStrategy @@ -161,10 +166,7 @@ plutusAutoBudgetMaxOut :: plutusAutoBudgetMaxOut _ _ _ (TargetBlockExpenditure Nothing) _ = Left $ TxGenError "plutusAutoBudgetMaxOut : a scaling factor is required for TargetBlockExpenditure" plutusAutoBudgetMaxOut - protocolParams@ProtocolParameters - { protocolParamMaxBlockExUnits = Just budgetPerBlock - , protocolParamMaxTxExUnits = Just budgetPerTx - } + pparams script pab@PlutusAutoBudget{..} target @@ -174,6 +176,8 @@ plutusAutoBudgetMaxOut let pab' = pab {autoBudgetUnits = targetBudget, autoBudgetRedeemer = unsafeHashableScriptData $ toLoopArgument n} pure (pab', fromIntegral n, limitFactors) where + budgetPerBlock = fromAlonzoExUnits $ pparams ^. L.ppMaxBlockExUnitsL + budgetPerTx = fromAlonzoExUnits $ pparams ^. L.ppMaxTxExUnitsL -- The highest loop counter that is tried - this is about 10 times the current mainnet limit. searchUpperBound = 20000 @@ -195,7 +199,7 @@ plutusAutoBudgetMaxOut -- the execution is considered within limits when there's no limiting factor, i.e. the list is empty isInLimits :: Integer -> Either TxGenError [PlutusAutoLimitingFactor] isInLimits n = do - used <- preExecutePlutusScript protocolParams script autoBudgetDatum (unsafeHashableScriptData $ toLoopArgument n) + used <- preExecutePlutusScript pparams script autoBudgetDatum (unsafeHashableScriptData $ toLoopArgument n) pure $ [ExceededStepLimit | executionSteps used > executionSteps targetBudget] ++ [ExceededMemoryLimit | executionMemory used > executionMemory targetBudget] @@ -207,8 +211,9 @@ plutusAutoBudgetMaxOut _ _ _ _ _ -- Some of the function arguments share names with the record fields -- mass imported with the @Constr{..}@ notation, setting the field -- of the final result to that argument. -plutusBudgetSummary :: - ProtocolParameters +plutusBudgetSummary :: () + => L.AlonzoEraPParams era + => L.PParams era -> FilePath -> PlutusBudgetFittingStrategy -> (PlutusAutoBudget, Int, [PlutusAutoLimitingFactor]) @@ -216,10 +221,7 @@ plutusBudgetSummary :: -> Int -> PlutusBudgetSummary plutusBudgetSummary - ProtocolParameters - { protocolParamMaxBlockExUnits = Just budgetPerBlock - , protocolParamMaxTxExUnits = Just budgetPerTx - } + pparams scriptId budgetStrategy (PlutusAutoBudget{..}, loopCounter, loopLimitingFactors) @@ -227,6 +229,8 @@ plutusBudgetSummary txInputs = PlutusBudgetSummary{..} where + budgetPerBlock = fromAlonzoExUnits $ pparams ^. L.ppMaxBlockExUnitsL + budgetPerTx = fromAlonzoExUnits $ pparams ^. L.ppMaxTxExUnitsL projectedTxSize = Nothing -- we defer this value until after splitting phase projectedTxFee = Nothing -- we defer this value until after splitting phase strategyMessage = Nothing @@ -287,10 +291,10 @@ minus :: ExecutionUnits -> ExecutionUnits -> ExecutionUnits minus (ExecutionUnits a b) (ExecutionUnits a' b') = ExecutionUnits (a - a') (b - b') -calc :: ExecutionUnits -> (Natural -> Natural -> Natural) -> Int -> ExecutionUnits +calc :: ExecutionUnits -> (Natural -> Natural -> Natural) -> Int -> ExecutionUnits calc (ExecutionUnits a b) op (fromIntegral -> n) = ExecutionUnits (a `op` n) (b `op` n) -bmin :: ExecutionUnits -> ExecutionUnits -> ExecutionUnits +bmin :: ExecutionUnits -> ExecutionUnits -> ExecutionUnits bmin (ExecutionUnits a b) (ExecutionUnits a' b') = ExecutionUnits (min a a') (min b b') diff --git a/bench/tx-generator/src/Cardano/TxGenerator/PureExample.hs b/bench/tx-generator/src/Cardano/TxGenerator/PureExample.hs index a7b7baa6b49..5da930138b3 100644 --- a/bench/tx-generator/src/Cardano/TxGenerator/PureExample.hs +++ b/bench/tx-generator/src/Cardano/TxGenerator/PureExample.hs @@ -7,7 +7,6 @@ module Cardano.TxGenerator.PureExample where import Cardano.Api -import Cardano.Api.Shelley (convertToLedgerProtocolParameters) import qualified Cardano.Ledger.Coin as L import Cardano.TxGenerator.FundQueue @@ -105,11 +104,7 @@ generateTx TxEnvironment{..} sbe = ShelleyBasedEraBabbage generator :: TxGenerator BabbageEra - generator = - case convertToLedgerProtocolParameters sbe txEnvProtocolParams of - Right ledgerParameters -> - genTx sbe ledgerParameters collateralFunds txEnvFee txEnvMetadata - Left err -> \_ _ -> Left (ApiError err) + generator = genTx ShelleyBasedEraBabbage txEnvProtocolParams collateralFunds txEnvFee txEnvMetadata where -- collateralFunds are needed for Plutus transactions collateralFunds :: (TxInsCollateral BabbageEra, [Fund]) @@ -158,11 +153,7 @@ generateTxPure TxEnvironment{..} inQueue sbe = ShelleyBasedEraBabbage generator :: TxGenerator BabbageEra - generator = - case convertToLedgerProtocolParameters sbe txEnvProtocolParams of - Right ledgerParameters -> - genTx ShelleyBasedEraBabbage ledgerParameters collateralFunds txEnvFee txEnvMetadata - Left err -> \_ _ -> Left (ApiError err) + generator = genTx ShelleyBasedEraBabbage txEnvProtocolParams collateralFunds txEnvFee txEnvMetadata where -- collateralFunds are needed for Plutus transactions collateralFunds :: (TxInsCollateral BabbageEra, [Fund]) diff --git a/bench/tx-generator/src/Cardano/TxGenerator/Setup/Plutus.hs b/bench/tx-generator/src/Cardano/TxGenerator/Setup/Plutus.hs index 9a2d1bad7c2..ec20fa50d29 100644 --- a/bench/tx-generator/src/Cardano/TxGenerator/Setup/Plutus.hs +++ b/bench/tx-generator/src/Cardano/TxGenerator/Setup/Plutus.hs @@ -3,6 +3,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-| Module : Cardano.TxGenerator.Setup.Plutus @@ -14,10 +15,10 @@ module Cardano.TxGenerator.Setup.Plutus ) where -import Data.Bifunctor + import Data.ByteString.Short (ShortByteString) -import Data.Int (Int64) -import Data.Map.Strict as Map (lookup) +import Data.Map.Strict as Map (lookup, Map) +import Lens.Micro import Control.Monad.Trans.Except import Control.Monad.Trans.Except.Extra @@ -26,8 +27,10 @@ import Control.Monad.Writer (runWriter) import Cardano.CLI.Read (readFileScriptInAnyLang) import Cardano.Api -import Cardano.Api.Shelley (PlutusScript (..), ProtocolParameters (..), fromAlonzoExUnits, - protocolParamCostModels, toPlutusData) +import Cardano.Api.Shelley (PlutusScript (..), fromAlonzoExUnits, toAlonzoLanguage, toPlutusData) +import qualified Cardano.Ledger.Alonzo.Core as L +import Cardano.Ledger.BaseTypes +import qualified Cardano.Ledger.Plutus as LP import Cardano.Ledger.Plutus.TxInfo (exBudgetToExUnits) import qualified PlutusLedgerApi.V1 as PlutusV1 @@ -81,13 +84,15 @@ readPlutusScript (Right fp) -- the script's binary representation to count the number of execution -- units needed. preExecutePlutusScript :: - ProtocolParameters + () + => L.AlonzoEraPParams era + => L.PParams era -> ScriptInAnyLang -> ScriptData -> ScriptRedeemer -> Either TxGenError ExecutionUnits preExecutePlutusScript - ProtocolParameters{protocolParamCostModels, protocolParamProtocolVersion} + pparams script@(ScriptInAnyLang scriptLang _) datum redeemer @@ -95,7 +100,7 @@ preExecutePlutusScript costModel <- hoistMaybe (TxGenError $ "preExecutePlutusScript: cost model unavailable for: " ++ show scriptLang) $ case script of ScriptInAnyLang _ (PlutusScript lang _) -> - AnyPlutusScriptVersion lang `Map.lookup` protocolParamCostModels + (toAlonzoLanguage (AnyPlutusScriptVersion lang)) `Map.lookup` langToCostModels _ -> Nothing @@ -109,15 +114,17 @@ preExecutePlutusScript _ -> throwE $ TxGenError $ "preExecutePlutusScript: script not supported: " ++ show scriptLang where - protocolVersion :: ProtocolVersion - protocolVersion = bimap fromIntegral fromIntegral protocolParamProtocolVersion + protocolParamCostModels :: LP.CostModels = pparams ^. L.ppCostModelsL + langToCostModels :: Map.Map LP.Language LP.CostModel = LP.costModelsValid protocolParamCostModels + protocolVersion :: ProtocolVersion = (getVersion @Int pvMajor, fromIntegral pvMinor) + ProtVer pvMajor pvMinor = pparams ^. L.ppProtocolVersionL preExecutePlutusV1 :: ProtocolVersion -> Script PlutusScriptV1 -> ScriptData -> ScriptRedeemer - -> CostModel + -> LP.CostModel -> Either TxGenError ExecutionUnits preExecutePlutusV1 protocolVersion_ (PlutusScript _ (PlutusScriptSerialised script)) datum redeemer costModel = fst $ runWriter $ runExceptT go -- for now, we discard warnings (:: PlutusCore.Evaluation.Machine.CostModelInterface.CostModelApplyWarn) @@ -126,7 +133,7 @@ preExecutePlutusV1 protocolVersion_ (PlutusScript _ (PlutusScriptSerialised scri go = do evaluationContext <- firstExceptT PlutusError $ - PlutusV1.mkEvaluationContext (flattenCostModel costModel) + PlutusV1.mkEvaluationContext (LP.getCostModelParams costModel) deserialisedScript <- firstExceptT PlutusError $ PlutusV1.deserialiseScript protocolVersion script exBudget <- firstExceptT PlutusError $ @@ -166,7 +173,7 @@ preExecutePlutusV2 :: -> Script PlutusScriptV2 -> ScriptData -> ScriptRedeemer - -> CostModel + -> LP.CostModel -> Either TxGenError ExecutionUnits preExecutePlutusV2 (major, _minor) (PlutusScript _ (PlutusScriptSerialised script)) datum redeemer costModel = fst $ runWriter $ runExceptT go -- for now, we discard warnings (:: PlutusCore.Evaluation.Machine.CostModelInterface.CostModelApplyWarn) @@ -175,7 +182,7 @@ preExecutePlutusV2 (major, _minor) (PlutusScript _ (PlutusScriptSerialised scrip go = do evaluationContext <- firstExceptT PlutusError $ - PlutusV2.mkEvaluationContext (flattenCostModel costModel) + PlutusV2.mkEvaluationContext (LP.getCostModelParams costModel) deserialisedScript <- firstExceptT PlutusError $ PlutusV2.deserialiseScript protocolVersion script @@ -218,7 +225,7 @@ preExecutePlutusV3 :: -> Script PlutusScriptV3 -> ScriptData -> ScriptRedeemer - -> CostModel + -> LP.CostModel -> Either TxGenError ExecutionUnits preExecutePlutusV3 (major, _minor) (PlutusScript _ (PlutusScriptSerialised (script :: ShortByteString {- a.k.a. SerialisedScript -}))) datum redeemer costModel = fst $ runWriter $ runExceptT go -- for now, we discard warnings (:: PlutusCore.Evaluation.Machine.CostModelInterface.CostModelApplyWarn) @@ -227,7 +234,7 @@ preExecutePlutusV3 (major, _minor) (PlutusScript _ (PlutusScriptSerialised (scri go = do evaluationContext <- firstExceptT PlutusError $ - PlutusV3.mkEvaluationContext (flattenCostModel costModel) + PlutusV3.mkEvaluationContext (LP.getCostModelParams costModel) scriptForEval <- withExceptT PlutusError $ PlutusV3.deserialiseScript protocolVersion script exBudget <- firstExceptT PlutusError $ @@ -272,7 +279,4 @@ preExecutePlutusV3 (major, _minor) (PlutusScript _ (PlutusScriptSerialised (scri , PlutusV3.txInfoProposalProcedures = [] , PlutusV3.txInfoCurrentTreasuryAmount = Nothing , PlutusV3.txInfoTreasuryDonation = Nothing - } - -flattenCostModel :: CostModel -> [Int64] -flattenCostModel (CostModel cm) = cm + } \ No newline at end of file diff --git a/bench/tx-generator/src/Cardano/TxGenerator/Tx.hs b/bench/tx-generator/src/Cardano/TxGenerator/Tx.hs index 30b494056d1..ca87a6752b1 100644 --- a/bench/tx-generator/src/Cardano/TxGenerator/Tx.hs +++ b/bench/tx-generator/src/Cardano/TxGenerator/Tx.hs @@ -7,9 +7,10 @@ module Cardano.TxGenerator.Tx where import Cardano.Api -import Cardano.Api.Shelley (LedgerProtocolParameters) +import Cardano.Api.Shelley import qualified Cardano.Ledger.Coin as L +import qualified Cardano.Ledger.Core as L import Cardano.TxGenerator.Fund import Cardano.TxGenerator.Types import Cardano.TxGenerator.UTxO (ToUTxOList) @@ -159,7 +160,7 @@ sourceTransactionPreview txGenerator inputFunds valueSplitter toStore = -- for a function type -- of two arguments. genTx :: () => ShelleyBasedEra era - -> LedgerProtocolParameters era + -> L.PParams (ShelleyLedgerEra era) -> (TxInsCollateral era, [Fund]) -> TxFee era -> TxMetadataInEra era @@ -179,7 +180,7 @@ genTx sbe ledgerParameters (collateral, collFunds) fee metadata inFunds outputs & setTxValidityLowerBound TxValidityNoLowerBound & setTxValidityUpperBound (defaultTxValidityUpperBound sbe) & setTxMetadata metadata - & setTxProtocolParams (BuildTxWith (Just ledgerParameters)) + & setTxProtocolParams (BuildTxWith (Just $ LedgerProtocolParameters ledgerParameters)) txSizeInBytes :: diff --git a/bench/tx-generator/src/Cardano/TxGenerator/Types.hs b/bench/tx-generator/src/Cardano/TxGenerator/Types.hs index 741fbe2794d..3778e343a7b 100644 --- a/bench/tx-generator/src/Cardano/TxGenerator/Types.hs +++ b/bench/tx-generator/src/Cardano/TxGenerator/Types.hs @@ -14,9 +14,10 @@ module Cardano.TxGenerator.Types where import Cardano.Api -import Cardano.Api.Shelley (ProtocolParameters) +import Cardano.Api.Shelley import qualified Cardano.Ledger.Coin as L +import qualified Cardano.Ledger.Core as L import Cardano.Ledger.Crypto (StandardCrypto) import qualified Cardano.Ledger.Shelley.API as Ledger (ShelleyGenesis) import Cardano.TxGenerator.Fund (Fund) @@ -67,7 +68,7 @@ data TxEnvironment era = TxEnvironment { txEnvNetworkId :: !NetworkId -- , txEnvGenesis :: !ShelleyGenesis -- , txEnvProtocolInfo :: !SomeConsensusProtocol - , txEnvProtocolParams :: !ProtocolParameters + , txEnvProtocolParams :: !(L.PParams (ShelleyLedgerEra era)) , txEnvFee :: TxFee era , txEnvMetadata :: TxMetadataInEra era } diff --git a/bench/tx-generator/test/ApiTest.hs b/bench/tx-generator/test/ApiTest.hs index efefedb38a5..fa06000a0a9 100644 --- a/bench/tx-generator/test/ApiTest.hs +++ b/bench/tx-generator/test/ApiTest.hs @@ -14,7 +14,7 @@ module Main (module Main) where import Cardano.Api import qualified Cardano.Api.Ledger as Api -import Cardano.Api.Shelley (ProtocolParameters (..), fromPlutusData) +import Cardano.Api.Shelley (fromPlutusData) #ifdef WITH_LIBRARY import Cardano.Benchmarking.PlutusScripts