diff --git a/CODEOWNERS b/CODEOWNERS index 25093cf2abf..d7acc0e1edb 100644 --- a/CODEOWNERS +++ b/CODEOWNERS @@ -19,7 +19,8 @@ cabal.project @LaurenceIO doc @docs-access README.* @docs-access - +bench/tx-generator @deepfire @MarcFontaine +bench @deepfire @denisshevchenko @jutaro @MarcFontaine nix/workbench @deepfire @denisshevchenko @jutaro @MarcFontaine nix/supervisord-cluster @deepfire @denisshevchenko @jutaro @MarcFontaine Makefile @deepfire diff --git a/bench/tx-generator/LICENSE b/bench/tx-generator/LICENSE new file mode 100644 index 00000000000..bb85f41c129 --- /dev/null +++ b/bench/tx-generator/LICENSE @@ -0,0 +1,202 @@ + + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright 2019 Input Output (Hong Kong) Ltd. + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/bench/tx-generator/NOTICE b/bench/tx-generator/NOTICE new file mode 100644 index 00000000000..92e8a4f8690 --- /dev/null +++ b/bench/tx-generator/NOTICE @@ -0,0 +1,13 @@ +Copyright 2019-2021 Input Output (Hong Kong) Ltd. + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/bench/tx-generator/README.md b/bench/tx-generator/README.md new file mode 100644 index 00000000000..071d87bae17 --- /dev/null +++ b/bench/tx-generator/README.md @@ -0,0 +1 @@ +# Transaction Generator diff --git a/bench/tx-generator/app/tx-generator.hs b/bench/tx-generator/app/tx-generator.hs new file mode 100644 index 00000000000..b30f930a0ba --- /dev/null +++ b/bench/tx-generator/app/tx-generator.hs @@ -0,0 +1,4 @@ +import Cardano.Benchmarking.Command (runCommand) + +main :: IO () +main = runCommand diff --git a/bench/tx-generator/src/Cardano/Benchmarking/CliArgsScript.hs b/bench/tx-generator/src/Cardano/Benchmarking/CliArgsScript.hs new file mode 100644 index 00000000000..f94b1e55ccb --- /dev/null +++ b/bench/tx-generator/src/Cardano/Benchmarking/CliArgsScript.hs @@ -0,0 +1,157 @@ +{- HLINT ignore "Use record patterns" -} +{- HLINT ignore "Redundant bracket" -} +{- HLINT ignore "Reduce duplication" -} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Cardano.Benchmarking.CliArgsScript + ( + GeneratorCmd + , parseGeneratorCmd + , runPlainOldCliScript + , runEraTransitionTest + ) where + +import Prelude (error) +import Data.Text (unpack) +import qualified Data.List.NonEmpty as NE + +import Control.Tracer (traceWith) + +import Cardano.Api +import Cardano.Prelude hiding (option) + +import Ouroboros.Network.NodeToClient (IOManager) + +import Cardano.Benchmarking.GeneratorTx.Benchmark +import Cardano.Benchmarking.GeneratorTx (readSigningKey) +import Cardano.Benchmarking.DSL +import Cardano.Benchmarking.Tracer +import Cardano.Benchmarking.GeneratorTx.Error (TxGenError(..)) +import Cardano.Benchmarking.GeneratorTx.LocalProtocolDefinition (CliError(..), runBenchmarkScriptWith) + +runPlainOldCliScript :: IOManager -> GeneratorCmd -> IO (Either CliError ()) +runPlainOldCliScript + iocp + (GenerateCmd + logConfigFile + socketFile + benchmarkEra + cliPartialBenchmark + fundOptions + ) + = runExceptT $ runBenchmarkScriptWith iocp logConfigFile socketFile + $ plainOldCliScript cliPartialBenchmark benchmarkEra fundOptions + +runEraTransitionTest :: IOManager -> GeneratorCmd -> IO (Either CliError ()) +runEraTransitionTest + iocp + (GenerateCmd + logConfigFile + socketFile + _benchmarkEra + cliPartialBenchmark + fundOptions + ) + = runExceptT $ runBenchmarkScriptWith iocp logConfigFile socketFile + $ eraTransitionTest cliPartialBenchmark fundOptions + +plainOldCliScript :: PartialBenchmark -> AnyCardanoEra -> GeneratorFunds -> BenchmarkScript () +plainOldCliScript _ _ (FundsUtxo _ _ _) _ = error "plainOldCliScript FundsUtxo not supported" +plainOldCliScript _ _ (FundsSplitUtxo _ _) _ = error "plainOldCliScript FundsSplitUtxo not supported" +plainOldCliScript cliPartialBenchmark benchmarkEra (FundsGenesis keyFile) (tracers, dslSet) = do + case benchmarkEra of + AnyCardanoEra ByronEra -> error "ByronEra not supported" + AnyCardanoEra ShelleyEra -> do + myTracer "POScript :: ShelleyEra" + genericScript $ getDSL dslSet ShelleyEra + AnyCardanoEra AllegraEra -> do + myTracer "POScript :: AllegraEra" + genericScript $ getDSL dslSet AllegraEra + AnyCardanoEra MaryEra -> do + myTracer "POScript :: MaryEra" + genericScript $ getDSL dslSet MaryEra + where + myTracer msg = liftIO $ traceWith (btTxSubmit_ tracers) $ TraceBenchTxSubDebug msg + genericScript :: forall era. DSL era -> ExceptT TxGenError IO () + genericScript (DSL{..}) = do + b <- case mkBenchmark (defaultBenchmark <> cliPartialBenchmark) of + Left e -> error $ "Incomplete benchmark spec (is defaultBenchmark complete?): " <> unpack e + Right b -> return b + let + fees = bTxFee b + coolDownDelay = bInitCooldown b + + key <- readSigningKey keyFile + let + globalOutAddr = keyAddress key -- A globalOutAddr is used for all TXs in the generator. + + myTracer "POScript: securing funds" + firstUTxO <- secureGenesisFund fees (bInitialTTL b) key globalOutAddr + + myTracer $ "******* Tx generator: waiting for first UTxO" ++ show coolDownDelay ++ "s *******" + coolDown coolDownDelay + funds <- splitFunds fees (bTxCount b) (bTxFanIn b) key globalOutAddr firstUTxO + myTracer $ "******* Tx generator: waiting for funds split" ++ show coolDownDelay ++ "s *******" + coolDown coolDownDelay + + myTracer "POScript: pre-computing transactions" + finalTransactions <- txGenerator (bTxFee b) (bTxCount b) (bTxFanIn b) (bTxFanOut b) (bTxExtraPayload b) + globalOutAddr key (fromIntegral $ NE.length $ bTargets b) funds + + myTracer "POScript: sending transactions" + runBenchmark (bTargets b) (bTps b) (bErrorPolicy b) finalTransactions + +eraTransitionTest :: PartialBenchmark -> GeneratorFunds -> BenchmarkScript () +eraTransitionTest _ (FundsUtxo _ _ _) _ = error "eraTransitionTest FundsUtxo not supported" +eraTransitionTest _ (FundsSplitUtxo _ _) _ = error "eraTransitionTest FundsSplitUtxo not supported" +eraTransitionTest cliPartialBenchmark (FundsGenesis keyFile) (tracers, dslSet) = do + b <- case mkBenchmark (defaultBenchmark <> cliPartialBenchmark) of + Left e -> error $ "Incomplete benchmark spec (is defaultBenchmark complete?): " <> unpack e + Right b -> return b + let + fees = bTxFee b + coolDownDelay = bInitCooldown b + + key <- readSigningKey keyFile + let + addr_shelley :: AddressInEra ShelleyEra + addr_shelley = keyAddress key + + addr_mary :: AddressInEra MaryEra + addr_mary = keyAddress_mary key + + myTracer "POScript: securing funds" + + firstUTxO <- secureGenesisFund fees (bInitialTTL b) key addr_shelley + + myTracer $ "******* Tx generator: waiting for first UTxO" ++ show coolDownDelay ++ "s *******" + coolDown coolDownDelay + [fund1,fund2] <- splitFunds fees 2 (bTxFanIn b) key addr_shelley firstUTxO + funds_shelley <- splitFunds fees (bTxCount b) (bTxFanIn b) key addr_shelley fund1 + funds_mary <- splitFunds fees (bTxCount b) (bTxFanIn b) key addr_shelley fund2 + + myTracer $ "******* Tx generator: waiting for funds split" ++ show coolDownDelay ++ "s *******" + coolDown coolDownDelay + + myTracer "POScript: pre-computing transactions Shelley" + tx1 <- txGenerator (bTxFee b) (bTxCount b) (bTxFanIn b) (bTxFanOut b) (bTxExtraPayload b) + addr_shelley key (fromIntegral $ NE.length $ bTargets b) funds_shelley + myTracer "POScript: sending transactions Shelley" + runBenchmark (bTargets b) (bTps b) (bErrorPolicy b) tx1 + + myTracer "POScript: pre-computing transactions Mary" + (tx2 :: [Tx MaryEra]) <- txGenerator_mary (bTxFee b) (bTxCount b) (bTxFanIn b) (bTxFanOut b) (bTxExtraPayload b) + addr_mary key (fromIntegral $ NE.length $ bTargets b) funds_mary + myTracer "POScript: sending transactions Mary" + runBenchmark_mary (bTargets b) (bTps b) (bErrorPolicy b) tx2 + where + DSL {..} = getDSL dslSet ShelleyEra + DSL { + runBenchmark = runBenchmark_mary + , txGenerator = txGenerator_mary + , keyAddress = keyAddress_mary + } =getDSL dslSet MaryEra + + myTracer msg = liftIO $ traceWith (btTxSubmit_ tracers) $ TraceBenchTxSubDebug msg diff --git a/bench/tx-generator/src/Cardano/Benchmarking/Command.hs b/bench/tx-generator/src/Cardano/Benchmarking/Command.hs new file mode 100644 index 00000000000..13d4e26d1cf --- /dev/null +++ b/bench/tx-generator/src/Cardano/Benchmarking/Command.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-all-missed-specialisations -Wno-orphans #-} + +module Cardano.Benchmarking.Command +( + runCommand +, commandParser -- for tests +) +where + +import Prelude +import System.Exit + +import Options.Applicative as Opt + +import Ouroboros.Network.NodeToClient (withIOManager) + +import Cardano.Benchmarking.CliArgsScript + (GeneratorCmd, parseGeneratorCmd, runPlainOldCliScript, runEraTransitionTest) +import Cardano.Benchmarking.Script (runScript, parseScriptFile) + +data Command + = CliArguments !GeneratorCmd + | EraTransition !GeneratorCmd + | Json !FilePath + +runCommand :: IO () +runCommand = withIOManager $ \iocp -> do + cmd <- customExecParser + (prefs showHelpOnEmpty) + (info commandParser mempty) + case cmd of + CliArguments args -> runPlainOldCliScript iocp args >>= handleError + EraTransition args -> runEraTransitionTest iocp args >>= handleError + Json file -> do + script <- parseScriptFile file + runScript script iocp >>= handleError + where + handleError :: Show a => Either a b -> IO () + handleError = \case + Right _ -> exitSuccess + Left err -> die $ show err + +commandParser :: Parser Command +commandParser + = subparser + ( cliArgumentsCmd + <> eraTransitionCmd + <> jsonCmd + ) + where + cliArgumentsCmd = command "cliArguments" + (CliArguments <$> info parseGeneratorCmd + ( progDesc "tx-generator with CLI arguments" + <> fullDesc + <> header "tx-generator - load Cardano clusters with parametrised transaction flow (CLI version)" + ) + ) + + eraTransitionCmd = command "eraTransition" + (EraTransition <$> info parseGeneratorCmd + ( progDesc "tx-generator demo era transition" + <> fullDesc + <> header "tx-generator - load Cardano clusters with parametrised transaction flow (era transition)" + ) + ) + + jsonCmd = command "json" + (Json <$> info (strArgument (metavar "FILEPATH")) + ( progDesc "tx-generator run JsonScript" + <> fullDesc + <> header "tx-generator - run a generic benchmarking script" + ) + ) diff --git a/bench/tx-generator/src/Cardano/Benchmarking/DSL.hs b/bench/tx-generator/src/Cardano/Benchmarking/DSL.hs new file mode 100644 index 00000000000..5fa602f1d4b --- /dev/null +++ b/bench/tx-generator/src/Cardano/Benchmarking/DSL.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes #-} + +module Cardano.Benchmarking.DSL +where + +import Prelude (error) +import Cardano.Prelude + +import Cardano.Api +import Cardano.Benchmarking.Tracer +import Cardano.Benchmarking.Types (SubmissionErrorPolicy, NodeIPv4Address) +import Cardano.Benchmarking.GeneratorTx +import Cardano.Benchmarking.GeneratorTx.Tx + +type ScriptM a = ExceptT TxGenError IO a +type BenchmarkScript a = (BenchTracers, MonoDSLs) -> ScriptM a + +type MonoDSLs = (DSL ShelleyEra, DSL AllegraEra, DSL MaryEra) + +getDSL :: MonoDSLs -> CardanoEra era -> DSL era +getDSL _ ByronEra = error "ByronEra not supported" +getDSL (x, _, _) ShelleyEra = x +getDSL (_, x, _) AllegraEra = x +getDSL (_, _, x) MaryEra = x + +type Fee = Lovelace +type TTL = SlotNo + +type SecureGenesisFund era = + Fee + -> TTL + -> SigningKey PaymentKey + -> AddressInEra era + -> ScriptM Fund + +type SplitFunds era = + Lovelace + -> NumberOfTxs + -> NumberOfInputsPerTx + -> SigningKey PaymentKey + -> AddressInEra era + -> Fund + -> ScriptM [Fund] + +-- txGenerator is basically pure except for logging. +type TxGenerator era = + Lovelace + -> NumberOfTxs + -> NumberOfInputsPerTx + -> NumberOfOutputsPerTx + -> TxAdditionalSize + -> AddressInEra era + -> SigningKey PaymentKey + -> Int + -> [Fund] + -> ScriptM [Tx era] + +type RunBenchmark era = + NonEmpty NodeIPv4Address + -> TPSRate + -> SubmissionErrorPolicy + -> [Tx era] + -> ScriptM () + +type KeyAddress era = SigningKey PaymentKey -> AddressInEra era + +data DSL era = DSL { + keyAddress :: !(KeyAddress era) + , secureGenesisFund :: !(SecureGenesisFund era) + , splitFunds :: !(SplitFunds era) + , txGenerator :: !(TxGenerator era) + , runBenchmark :: !(RunBenchmark era) + } + +coolDown :: InitCooldown -> ScriptM () +coolDown (InitCooldown t) = liftIO $ threadDelay $ 1000 * 1000 * t diff --git a/bench/tx-generator/src/Cardano/Benchmarking/FundSet.hs b/bench/tx-generator/src/Cardano/Benchmarking/FundSet.hs new file mode 100644 index 00000000000..9f4edcadcc7 --- /dev/null +++ b/bench/tx-generator/src/Cardano/Benchmarking/FundSet.hs @@ -0,0 +1,105 @@ +{-# OPTIONS_GHC -Wwarn #-} +{-# Language DataKinds #-} +{-# Language FlexibleInstances #-} +{-# Language GADTs #-} +{-# Language GeneralizedNewtypeDeriving #-} +{-# Language MultiParamTypeClasses #-} +{-# Language RankNTypes #-} + +module Cardano.Benchmarking.FundSet +where +import Prelude + +import Data.IxSet.Typed as IxSet + +import Cardano.Api as Api + +-- Outputs that are available for spending. +-- When building a new TX they provide the TxIn parts. + +data FundInEra era = FundInEra { + _fundTxIn :: !TxIn + , _fundVal :: !(TxOutValue era) + , _fundSigningKey :: !(SigningKey PaymentKey) + , _fundValidity :: !Validity + } deriving (Show) + +data Validity + = Confirmed + | InFlight !Target !SeqNumber + deriving (Show, Eq, Ord) + +newtype Target = Traget String + deriving (Show, Eq, Ord) + +newtype SeqNumber = SeqNumber Int + deriving (Show, Eq, Ord, Enum) + +newtype Fund = Fund {unFund :: InAnyCardanoEra FundInEra} + +getFundTxIn :: Fund -> TxIn +getFundTxIn (Fund (InAnyCardanoEra _ a)) = _fundTxIn a + +getFundKey :: Fund -> SigningKey PaymentKey +getFundKey (Fund (InAnyCardanoEra _ a)) = _fundSigningKey a + +getFundValidity :: Fund -> Validity +getFundValidity (Fund (InAnyCardanoEra _ a)) = _fundValidity a + +getFundLovelace :: Fund -> Lovelace +getFundLovelace (Fund (InAnyCardanoEra _ a)) = case _fundVal a of + TxOutAdaOnly _era l -> l + TxOutValue _era v -> selectLovelace v + +data IsConfirmed = IsConfirmed | IsNotConfirmed + deriving (Show, Eq, Ord) + +isConfirmed :: Fund -> IsConfirmed +isConfirmed f = case getFundValidity f of + Confirmed -> IsConfirmed + InFlight _ _ -> IsNotConfirmed + +instance Show Fund where + show (Fund (InAnyCardanoEra _ f)) = show f + +-- TxIn/fundTxOut is the primary key. +-- There must be no two entries for the same TxIn !. + +instance Eq Fund where + (==) a b = getFundTxIn a == getFundTxIn b + +instance Ord Fund where + compare a b = compare (getFundTxIn a) (getFundTxIn b) + +type FundIndices = '[ TxIn, IsConfirmed, Target, SeqNumber, Lovelace ] +type FundSet = IxSet FundIndices Fund + +instance Indexable FundIndices Fund where + indices = ixList + (ixFun $ \f -> [ getFundTxIn f ]) + (ixFun $ \f -> [ isConfirmed f ]) + (ixFun $ \f -> case getFundValidity f of + Confirmed -> [] + InFlight t _ -> [t] + ) + (ixFun $ \f -> case getFundValidity f of + Confirmed -> [SeqNumber (-1) ] -- Confirmed Txs get SeqNumber -1 + InFlight _ n -> [ n ] + ) + (ixFun $ \f -> [ getFundLovelace f ]) + +emptyFunds :: FundSet +emptyFunds = IxSet.empty + +insertFund :: FundSet -> Fund -> FundSet +insertFund s f = updateIx (getFundTxIn f) f s + +deleteFund :: FundSet -> Fund -> FundSet +deleteFund s f = deleteIx (getFundTxIn f) s + +liftAnyEra :: ( forall era. IsCardanoEra era => f1 era -> f2 era ) -> InAnyCardanoEra f1 -> InAnyCardanoEra f2 +liftAnyEra f x = case x of + InAnyCardanoEra ByronEra a -> InAnyCardanoEra ByronEra $ f a + InAnyCardanoEra ShelleyEra a -> InAnyCardanoEra ShelleyEra $ f a + InAnyCardanoEra AllegraEra a -> InAnyCardanoEra AllegraEra $ f a + InAnyCardanoEra MaryEra a -> InAnyCardanoEra MaryEra $ f a diff --git a/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx.hs b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx.hs new file mode 100644 index 00000000000..9bec2154a0b --- /dev/null +++ b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx.hs @@ -0,0 +1,474 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_GHC -Wno-all-missed-specialisations #-} +{-# OPTIONS_GHC -Wno-missed-specialisations #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Cardano.Benchmarking.GeneratorTx + ( AsyncBenchmarkControl + , NumberOfTxs(..) + , NumberOfInputsPerTx(..) + , NumberOfOutputsPerTx(..) + , InitCooldown(..) + , TPSRate(..) + , TxAdditionalSize(..) + , TxGenError + , asyncBenchmark + , readSigningKey + , runBenchmark + , secureGenesisFund + , splitFunds + , txGenerator + , waitBenchmark + ) where + +import Cardano.Prelude +import Prelude (id, String) + +import Control.Monad (fail) +import Control.Monad.Trans.Except.Extra (left, newExceptT, right) +import Control.Tracer (Tracer, traceWith) + +import qualified Data.List.NonEmpty as NE +import qualified Data.Map.Strict as Map +import Data.Text (pack) +import Network.Socket (AddrInfo (..), AddrInfoFlag (..), Family (..), SocketType (Stream), + addrFamily, addrFlags, addrSocketType, defaultHints, getAddrInfo) + +import Cardano.CLI.Types (SigningKeyFile (..)) +import Cardano.Node.Types + +import Ouroboros.Consensus.Shelley.Eras (StandardShelley) + +import Cardano.Api hiding (txFee) + +import Cardano.Benchmarking.Types +import Cardano.Benchmarking.GeneratorTx.Error +import Cardano.Benchmarking.GeneratorTx.Genesis +import Cardano.Benchmarking.GeneratorTx.NodeToNode +import Cardano.Benchmarking.GeneratorTx.Submission +import Cardano.Benchmarking.GeneratorTx.Tx +import Cardano.Benchmarking.GeneratorTx.SizedMetadata (mkMetadata) +import Cardano.Benchmarking.Tracer + +import Shelley.Spec.Ledger.API (ShelleyGenesis) +import Ouroboros.Network.Protocol.LocalTxSubmission.Type (SubmitResult (..)) + +readSigningKey :: SigningKeyFile -> ExceptT TxGenError IO (SigningKey PaymentKey) +readSigningKey = + withExceptT TxFileError . newExceptT . readKey . unSigningKeyFile + where + readKey :: FilePath -> IO (Either (FileError TextEnvelopeError) (SigningKey PaymentKey)) + readKey f = flip readFileTextEnvelopeAnyOf f + [ FromSomeType (AsSigningKey AsGenesisUTxOKey) castSigningKey + , FromSomeType (AsSigningKey AsPaymentKey) id + ] + +secureGenesisFund :: forall era. IsShelleyBasedEra era + => Tracer IO (TraceBenchTxSubmit TxId) + -> (TxInMode CardanoMode -> IO (SubmitResult (TxValidationErrorInMode CardanoMode))) + -> NetworkId + -> ShelleyGenesis StandardShelley + -> Lovelace + -> SlotNo + -> SigningKey PaymentKey + -> AddressInEra era + -> ExceptT TxGenError IO Fund +secureGenesisFund submitTracer localSubmitTx networkId genesis txFee ttl key outAddr = do + let (_inAddr, lovelace) = genesisFundForKey @ era networkId genesis key + (tx, fund) = + genesisExpenditure networkId key outAddr lovelace txFee ttl + r <- liftIO $ + catches (localSubmitTx $ txInModeCardano tx) + [ Handler $ \e@SomeException{} -> + fail $ mconcat + [ "Exception while moving genesis funds via local socket: " + , show e + ]] + case r of + SubmitSuccess -> + liftIO . traceWith submitTracer . TraceBenchTxSubDebug + $ mconcat + [ "******* Funding secured (" + , show $ fundTxIn fund, " -> ", show $ fundAdaValue fund + , ")"] + SubmitFail e -> fail $ show e + return fund + +----------------------------------------------------------------------------------------- +-- Obtain initial funds. +----------------------------------------------------------------------------------------- +splitFunds :: forall era. IsShelleyBasedEra era + => Tracer IO (TraceBenchTxSubmit TxId) + -> (TxInMode CardanoMode -> IO (SubmitResult (TxValidationErrorInMode CardanoMode))) + -> Lovelace + -> NumberOfTxs + -> NumberOfInputsPerTx + -> SigningKey PaymentKey + -> AddressInEra era + -> Fund + -> ExceptT TxGenError IO [Fund] +splitFunds + submitTracer + localSubmitTx + fee + (NumberOfTxs numTxs) + (NumberOfInputsPerTx txFanin) + sourceKey + globalOutAddr + fundsTxIO = do + let -- The number of splitting txout entries (corresponds to the number of all inputs we will need). + (Quantity rawCoin) = lovelaceToQuantity $ fundAdaValue fundsTxIO + (Quantity feeRaw) = lovelaceToQuantity fee + numRequiredTxOuts = numTxs * fromIntegral txFanin + splitFanout = 60 :: Word64 -- near the upper bound so as not to exceed the tx size limit + (nFullTxs, remainder) = numRequiredTxOuts `divMod` splitFanout + numSplitTxs = nFullTxs + if remainder > 0 then 1 else 0 + + let -- Split the funds to 'numRequiredTxOuts' equal parts, subtracting the possible fees. + -- a safe number for fees is numRequiredTxOuts' * feePerTx. + outputSliceWithFees = rawCoin `div` fromIntegral numRequiredTxOuts + outputSlice = outputSliceWithFees - feeRaw + splitValue = mkTxOutValueAdaOnly $ quantityToLovelace $ Quantity outputSlice + -- The same output for all splitting transaction: send the same 'splitValue' + -- to the same 'sourceAddress'. + -- Create and sign splitting txs. + splittingTxs = createSplittingTxs sourceKey + fundsTxIO + numRequiredTxOuts + splitFanout + 42 + splitValue + [] + -- Submit all splitting transactions sequentially. + liftIO $ traceWith submitTracer $ TraceBenchTxSubDebug $ mconcat + [ "Coin splitting (values are Lovelaces): " + , "total funds: ", show rawCoin, ", " + , "txouts needed: ", show numRequiredTxOuts, ", " + , "txout slice with fees: ", show outputSliceWithFees, ", " + , "fees: ", show feeRaw, ", " + , "txout slice: ", show outputSlice, ", " + , "splitting fanout: ", show splitFanout, ", " + , "splitting tx count: ", show (length splittingTxs) + ] + forM_ (zip splittingTxs [0::Int ..]) $ \((tx, _), i) -> + liftIO (localSubmitTx $ txInModeCardano tx) + >>= \case + SubmitSuccess -> pure () + SubmitFail x -> left . SplittingSubmissionError $ mconcat + ["Coin splitting submission failed (", show i :: Text + , "/", show numSplitTxs :: Text + , "): ", show x :: Text + , "\n Tx: ", show tx] + liftIO $ putStrLn ("submitted all coin splitting Txs." :: Text) + + -- Re-create availableFunds with information about all splitting transactions + -- (it will be used for main transactions). + right $ concatMap snd splittingTxs + where + -- create txs which split the funds to numTxOuts equal parts + createSplittingTxs + :: SigningKey PaymentKey + -> Fund + -> Word64 + -> Word64 + -> Int + -> TxOutValue era + -> [(Tx era, [Fund])] + -> [(Tx era, [Fund])] + createSplittingTxs sKey initialFund numTxOuts maxOutsPerInitTx identityIndex txOut acc + | numTxOuts <= 0 = reverse acc + | otherwise = + let numOutsPerInitTx = min maxOutsPerInitTx numTxOuts + -- same TxOut for all + outs = zip [identityIndex .. + identityIndex + fromIntegral numOutsPerInitTx - 1] + (repeat (TxOut globalOutAddr txOut)) + (mFunds, _fees, outIndices, splitTx) = + mkTransactionGen sKey (initialFund :| []) globalOutAddr outs TxMetadataNone fee + !splitTxId = getTxId $ getTxBody splitTx + txIOList = flip map (Map.toList outIndices) $ + \(_, txInIndex) -> + let !txIn = TxIn splitTxId txInIndex + in mkFund txIn txOut + in + case mFunds of + Nothing -> reverse $ (splitTx, txIOList) : acc + Just (txInIndex, val) -> + let !txInChange = TxIn splitTxId txInIndex + !txChangeValue = mkTxOutValueAdaOnly @ era val + in + -- from the change create the next tx with numOutsPerInitTx UTxO entries + createSplittingTxs sKey + (mkFund txInChange txChangeValue) + (numTxOuts - numOutsPerInitTx) + numOutsPerInitTx + (identityIndex + fromIntegral numOutsPerInitTx) + txOut + ((splitTx, txIOList) : acc) + +----------------------------------------------------------------------------------------- +-- | Run benchmark using top level tracers.. +----------------------------------------------------------------------------------------- + +-- This is the entry point for the CLI args tx-generator +-- {-# DEPRECATED runBenchmark "to be removed: use asyncBenchmark instead" #-} +runBenchmark :: forall era. IsShelleyBasedEra era + => Tracer IO (TraceBenchTxSubmit TxId) + -> Tracer IO NodeToNodeSubmissionTrace + -> ConnectClient + -> NonEmpty NodeIPv4Address + -> TPSRate + -> SubmissionErrorPolicy + -> [Tx era] + -> ExceptT TxGenError IO () +runBenchmark + traceSubmit + traceN2N + connectClient + targets + tpsRate + errorPolicy + finalTransactions + = do + ctl <- asyncBenchmark + traceSubmit + traceN2N + connectClient + "UnknownThreadLabel" + targets + tpsRate + errorPolicy + finalTransactions + waitBenchmark traceSubmit ctl + +type AsyncBenchmarkControl = (Async (), [Async ()], IO SubmissionSummary, IO ()) + +waitBenchmark :: Tracer IO (TraceBenchTxSubmit TxId) -> AsyncBenchmarkControl -> ExceptT TxGenError IO () +waitBenchmark traceSubmit (feeder, workers, mkSummary, _) = liftIO $ do + mapM_ waitCatch (feeder : workers) + traceWith traceSubmit =<< TraceBenchTxSubSummary <$> mkSummary + +asyncBenchmark :: forall era. IsShelleyBasedEra era + => Tracer IO (TraceBenchTxSubmit TxId) + -> Tracer IO NodeToNodeSubmissionTrace + -> ConnectClient + -> String + -> NonEmpty NodeIPv4Address + -> TPSRate + -> SubmissionErrorPolicy + -> [Tx era] + -> ExceptT TxGenError IO AsyncBenchmarkControl +asyncBenchmark + traceSubmit + traceN2N + connectClient + threadName + targets + tpsRate + errorPolicy + finalTransactions + = do + let + traceDebug :: String -> ExceptT TxGenError IO () + traceDebug = liftIO . traceWith traceSubmit . TraceBenchTxSubDebug + + traceDebug "******* Tx generator, phase 2: pay to recipients *******" + + remoteAddresses <- forM targets $ \targetNodeAddress -> do + let targetNodeHost = + show . unNodeHostIPv4Address $ naHostAddress targetNodeAddress + + let targetNodePort = show $ naPort targetNodeAddress + + let hints :: AddrInfo + hints = defaultHints + { addrFlags = [AI_PASSIVE] + , addrFamily = AF_INET + , addrSocketType = Stream + , addrCanonName = Nothing + } + + (remoteAddr:_) <- liftIO $ getAddrInfo (Just hints) (Just targetNodeHost) (Just targetNodePort) + return remoteAddr + + let numTargets :: Natural = fromIntegral $ NE.length targets + + traceDebug $ "******* Tx generator, launching Tx peers: " ++ show (NE.length remoteAddresses) ++ " of them" + liftIO $ do + submission :: Submission IO era <- mkSubmission traceSubmit $ + SubmissionParams + { spTps = tpsRate + , spTargets = numTargets + , spQueueLen = 32 + , spErrorPolicy = errorPolicy + } + allAsyncs <- forM (zip [0..] $ NE.toList remoteAddresses) $ + \(i, remoteAddr) -> + launchTxPeer + traceSubmit + traceN2N + connectClient + remoteAddr + submission + i + tpsFeeder <- async $ tpsLimitedTxFeeder submission finalTransactions + let tpsFeederShutdown = do + cancel tpsFeeder + liftIO $ tpsLimitedTxFeederShutdown submission + + return (tpsFeeder, allAsyncs, mkSubmissionSummary threadName submission, tpsFeederShutdown) + +-- | At this moment 'sourceAddress' contains a huge amount of money (lets call it A). +-- Now we have to split this amount to N equal parts, as a result we'll have +-- N UTxO entries, and alltogether these entries will contain the same amount A. +-- E.g. (1 entry * 1000 ADA) -> (10 entries * 100 ADA). +-- Technically all splitting transactions will send money back to 'sourceAddress'. + +----------------------------------------------------------------------------------------- +-- | Work with tx generator thread (for Phase 2). +----------------------------------------------------------------------------------------- +txGenerator + :: forall era + . IsShelleyBasedEra era + => Tracer IO (TraceBenchTxSubmit TxId) + -> Lovelace + -> NumberOfTxs + -> NumberOfInputsPerTx + -> NumberOfOutputsPerTx + -> TxAdditionalSize + -> AddressInEra era + -> SigningKey PaymentKey + -> Int + -> [Fund] + -> ExceptT TxGenError IO [Tx era] +txGenerator + tracer + txFee + (NumberOfTxs numOfTransactions) + (NumberOfInputsPerTx numOfInsPerTx) + (NumberOfOutputsPerTx numOfOutsPerTx) + (TxAdditionalSize txAdditionalSize) + recipientAddress + sourceKey + numOfTargetNodes + fundsWithSufficientCoins + = do + liftIO . traceWith tracer . TraceBenchTxSubDebug + $ " Generating " ++ show numOfTransactions + ++ " transactions, for " ++ show numOfTargetNodes + ++ " peers, fee " ++ show txFee + ++ ", value " ++ show valueForRecipient + ++ ", totalValue " ++ show totalValue + metadata <- case mkMetadata txAdditionalSize of + Right m -> return m + Left err -> throwE $ BadPayloadSize $ pack err + txs <- createMainTxs numOfTransactions numOfInsPerTx metadata fundsWithSufficientCoins + liftIO . traceWith tracer . TraceBenchTxSubDebug + $ " Done, " ++ show numOfTransactions ++ " were generated." + pure txs + where + -- Num of recipients is equal to 'numOuts', so we think of + -- recipients as the people we're going to pay to. + recipients = zip [initRecipientIndex .. initRecipientIndex + numOfOutsPerTx - 1] + (repeat txOut) + initRecipientIndex = 0 :: Int + -- The same output for all transactions. + valueForRecipient = quantityToLovelace $ Quantity 1000000 -- 10 ADA + !txOut = TxOut recipientAddress (mkTxOutValueAdaOnly valueForRecipient) + totalValue = valueForRecipient + txFee + -- Send possible change to the same 'recipientAddress'. + addressForChange = recipientAddress + + -- Create all main transactions, using available funds. + createMainTxs + :: Word64 + -> Int + -> TxMetadataInEra era + -> [Fund] + -> ExceptT TxGenError IO [Tx era] + createMainTxs 0 _ _ _= right [] + createMainTxs txsNum insNumPerTx metadata funds = do + (txInputs, updatedFunds) <- getTxInputs insNumPerTx funds + let (_, _, _, txAux :: Tx era) = + mkTransactionGen + sourceKey + (NE.fromList txInputs) + addressForChange + recipients + metadata + txFee + (txAux :) <$> createMainTxs (txsNum - 1) insNumPerTx metadata updatedFunds + + -- Get inputs for one main transaction, using available funds. + getTxInputs + :: Int + -> [Fund] + -> ExceptT TxGenError IO ( [Fund] , [Fund]) + getTxInputs 0 funds = right ([], funds) + getTxInputs insNumPerTx funds = do + (found, updatedFunds) <- findAvailableFunds funds totalValue + (inputs, updatedFunds') <- getTxInputs (insNumPerTx - 1) updatedFunds + right (found : inputs, updatedFunds') + + -- Find a source of available funds, removing it from the availableFunds + -- for preventing of double spending. + findAvailableFunds + :: [Fund] -- funds we are trying to find in + -> Lovelace -- with at least this associated value + -> ExceptT TxGenError IO (Fund, [Fund]) + findAvailableFunds funds thresh = + case break (predTxD thresh) funds of + (_, []) -> + left $ InsufficientFundsForRecipientTx + thresh + (maximum $ map fundAdaValue funds) + (toofews, found:rest) -> right (found, toofews <> rest) + + -- Find the first tx output that contains sufficient amount of money. + predTxD :: Lovelace -> Fund -> Bool + predTxD valueThreshold f = fundAdaValue f >= valueThreshold + +--------------------------------------------------------------------------------------------------- +-- Txs for submission. +--------------------------------------------------------------------------------------------------- + +-- | To get higher performance we need to hide latency of getting and +-- forwarding (in sufficient numbers) transactions. +-- +-- TODO: transform comments into haddocks. +-- +launchTxPeer + :: forall era + . IsShelleyBasedEra era + => Tracer IO (TraceBenchTxSubmit TxId) + -> Tracer IO NodeToNodeSubmissionTrace + -> ConnectClient + -> Network.Socket.AddrInfo + -- Remote address + -> Submission IO era + -- Mutable state shared between submission threads + -> Natural + -- Thread index + -> IO (Async ()) +launchTxPeer traceSubmit traceN2N connectClient remoteAddr sub tix = + async $ + handle + (\(SomeException err) -> do + let errDesc = mconcat + [ "Exception while talking to peer #", show tix + , " (", show (addrAddress remoteAddr), "): " + , show err] + submitThreadReport sub tix (Left errDesc) + case spErrorPolicy $ sParams sub of + FailOnError -> throwIO err + LogErrors -> traceWith traceSubmit $ + TraceBenchTxSubError (pack errDesc)) + $ connectClient remoteAddr + (txSubmissionClient traceN2N traceSubmit sub tix) diff --git a/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/Benchmark.hs b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/Benchmark.hs new file mode 100644 index 00000000000..d4cea26743b --- /dev/null +++ b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/Benchmark.hs @@ -0,0 +1,224 @@ +{- HLINT ignore "Move brackets to avoid $" -} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -Wno-all-missed-specialisations #-} +{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Cardano.Benchmarking.GeneratorTx.Benchmark + ( Benchmark(..) + , GeneratorCmd(..) + , GeneratorFunds(..) + , PartialBenchmark(..) + , defaultBenchmark + , mkBenchmark + , parseGeneratorCmd + ) where + +import Cardano.Prelude hiding (TypeError) +import Prelude (String) + +import qualified Data.List.NonEmpty as NE +import Data.Monoid.Generic +import Options.Applicative as Opt + +-- Node API imports +import Cardano.Api +import Cardano.CLI.Types (SigningKeyFile(..)) + +-- Node imports +import Cardano.Node.Types +import Cardano.Tracing.OrphanInstances.Byron () +import Cardano.Tracing.OrphanInstances.Common () +import Cardano.Tracing.OrphanInstances.Consensus () +import Cardano.Tracing.OrphanInstances.Network () +import Cardano.Tracing.OrphanInstances.Shelley () + +import Cardano.Benchmarking.GeneratorTx.CLI.Parsers +import Cardano.Benchmarking.Types + +parseNumberOfTxs :: String -> String -> Parser NumberOfTxs +parseNumberOfTxs opt desc = NumberOfTxs <$> parseIntegral opt desc + +parseNumberOfInputsPerTx :: String -> String -> Parser NumberOfInputsPerTx +parseNumberOfInputsPerTx opt desc = NumberOfInputsPerTx <$> parseIntegral opt desc + +parseNumberOfOutputsPerTx :: String -> String -> Parser NumberOfOutputsPerTx +parseNumberOfOutputsPerTx opt desc = NumberOfOutputsPerTx <$> parseIntegral opt desc + +parseTPSRate :: String -> String -> Parser TPSRate +parseTPSRate opt desc = TPSRate <$> parseDouble opt desc + +parseInitCooldown :: String -> String -> Parser InitCooldown +parseInitCooldown opt desc = InitCooldown <$> parseIntegral opt desc + +parseTxAdditionalSize :: String -> String -> Parser TxAdditionalSize +parseTxAdditionalSize opt desc = TxAdditionalSize <$> parseIntegral opt desc + +-- | Specification for a benchmark run. +data Benchmark + = Benchmark + { bTargets :: !(NonEmpty NodeIPv4Address) + , bInitCooldown :: !InitCooldown + , bInitialTTL :: !SlotNo + , bTxCount :: !NumberOfTxs + , bTps :: !TPSRate + , bTxFanIn :: !NumberOfInputsPerTx + , bTxFanOut :: !NumberOfOutputsPerTx + , bTxFee :: !Lovelace + , bTxExtraPayload :: !TxAdditionalSize + , bErrorPolicy :: !SubmissionErrorPolicy + } + deriving stock (Generic, Show) +-- Warning: make sure to maintain correspondence between the two data structures. +data PartialBenchmark + = PartialBenchmark + { pbTargets :: !(Last (NonEmpty NodeIPv4Address)) + , pbInitCooldown :: !(Last InitCooldown) + , pbInitialTTL :: !(Last SlotNo) + , pbTxCount :: !(Last NumberOfTxs) + , pbTps :: !(Last TPSRate) + , pbTxFanIn :: !(Last NumberOfInputsPerTx) + , pbTxFanOut :: !(Last NumberOfOutputsPerTx) + , pbTxFee :: !(Last Lovelace) + , pbTxExtraPayload :: !(Last TxAdditionalSize) + , pbErrorPolicy :: !(Last SubmissionErrorPolicy) + } + deriving stock (Generic, Show) + deriving Semigroup via GenericSemigroup PartialBenchmark + deriving Monoid via GenericMonoid PartialBenchmark + +parsePartialBenchmark :: Opt.Parser PartialBenchmark +parsePartialBenchmark = + PartialBenchmark + <$> lastly (NE.fromList <$> some ( + parseTargetNodeAddress + "target-node" + "IP address and port of the node transactions will be sent to." + ) + ) + <*> (lastly $ parseInitCooldown + "init-cooldown" + "Delay between init and main submission phases.") + <*> (lastly $ parseInitialTTL + "initial-ttl" + "Slot denoting TTL of the initial transactions.") + <*> (lastly $ parseNumberOfTxs + "num-of-txs" + "Number of transactions generator will create.") + <*> (lastly $ parseTPSRate + "tps" + "TPS (transaction per second) rate.") + <*> (lastly $ parseNumberOfInputsPerTx + "inputs-per-tx" + "Number of inputs in each of transactions.") + <*> (lastly $ parseNumberOfOutputsPerTx + "outputs-per-tx" + "Number of outputs in each of transactions.") + <*> (lastly $ parseFeePerTx + "tx-fee" + "Fee per transaction, in Lovelaces.") + <*> (lastly $ parseTxAdditionalSize + "add-tx-size" + "Additional size of transaction, in bytes.") + <*> (lastly $ parseFlag' + LogErrors FailOnError + "fail-on-submission-errors" + "Fail on submission thread errors, instead of logging them.") + +defaultBenchmark :: PartialBenchmark +defaultBenchmark = + PartialBenchmark + { pbTargets = mempty + , pbInitCooldown = pure 20 + , pbInitialTTL = pure (SlotNo 100000000) + , pbTxCount = pure 1000 + , pbTps = pure 10 + , pbTxFanIn = pure 1 + , pbTxFanOut = pure 1 + , pbTxFee = pure 1000 + , pbTxExtraPayload = pure 100 + , pbErrorPolicy = pure LogErrors + } + +-- This is called at the last stage of the Partial Options Monoid approach. +-- https://medium.com/@jonathangfischoff/the-partial-options-monoid-pattern-31914a71fc67 +mkBenchmark :: PartialBenchmark -> Either Text Benchmark +mkBenchmark PartialBenchmark{..} = do + bTargets <- mkComplete "bTargets " pbTargets + bInitCooldown <- mkComplete "bInitCooldown " pbInitCooldown + bInitialTTL <- mkComplete "bInitialTTL " pbInitialTTL + bTxCount <- mkComplete "bTxCount " pbTxCount + bTps <- mkComplete "bTps " pbTps + bTxFanIn <- mkComplete "bTxFanIn " pbTxFanIn + bTxFanOut <- mkComplete "bTxFanOut " pbTxFanOut + bTxFee <- mkComplete "bTxFee " pbTxFee + bTxExtraPayload <- mkComplete "bTxExtraPayload" pbTxExtraPayload + bErrorPolicy <- mkComplete "bErrorPolicy" pbErrorPolicy + pure Benchmark{..} + where + -- | Return an error if the @Last@ option is incomplete. + mkComplete :: Text -> Last a -> Either Text a + mkComplete err (Last x) = maybe (Left err) Right x + + +data GeneratorCmd = + GenerateCmd FilePath + SocketPath + AnyCardanoEra + PartialBenchmark + GeneratorFunds + +defaultEra :: AnyCardanoEra +defaultEra = AnyCardanoEra ShelleyEra + +parseGeneratorCmd :: Opt.Parser GeneratorCmd +parseGeneratorCmd = + GenerateCmd + <$> parseConfigFile + "config" + "Configuration file for the cardano-node" + <*> parseSocketPath + "socket-path" + "Path to a cardano-node socket" + <*> ( fromMaybe defaultEra <$> + ( + eraFlag "shelley" ShelleyEra + <|> eraFlag "mary" MaryEra + <|> eraFlag "allegra" AllegraEra + ) + ) + <*> parsePartialBenchmark + <*> parseGeneratorFunds + where + eraFlag name tag = flag Nothing (Just $ AnyCardanoEra tag) + (long name <> help ("Initialise Cardano in " ++ name ++" submode.")) + +data GeneratorFunds + = FundsGenesis SigningKeyFile + | FundsUtxo SigningKeyFile TxIn (TxOut ShelleyEra) + | FundsSplitUtxo SigningKeyFile FilePath + deriving stock Show + +parseGeneratorFunds :: Opt.Parser GeneratorFunds +parseGeneratorFunds = + (FundsGenesis + <$> parseSigningKeysFile + "genesis-funds-key" + "Genesis UTxO funds signing key.") + <|> + (FundsUtxo + <$> parseSigningKeysFile + "utxo-funds-key" + "UTxO funds signing key." + <*> pTxIn + <*> pTxOut) + <|> + (FundsSplitUtxo + <$> parseSigningKeysFile + "split-utxo-funds-key" + "UTxO funds signing key." + <*> parseFilePath + "split-utxo" + "UTxO funds file.") diff --git a/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/CLI/Parsers.hs b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/CLI/Parsers.hs new file mode 100644 index 00000000000..e7b8f2c4e1b --- /dev/null +++ b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/CLI/Parsers.hs @@ -0,0 +1,178 @@ +{-# OPTIONS_GHC -Wno-all-missed-specialisations #-} +module Cardano.Benchmarking.GeneratorTx.CLI.Parsers + (module Cardano.Benchmarking.GeneratorTx.CLI.Parsers) +where + +import Cardano.Prelude hiding (option) +import Prelude (String) + +import Control.Monad (fail) +import qualified Data.Attoparsec.ByteString.Char8 as Atto +import qualified Data.ByteString.Char8 as BSC +import qualified Data.Char as Char +import qualified Data.Text.Encoding as Text +import qualified Data.Text as Text +import Options.Applicative + ( Parser + , auto, bashCompleter, completer, flag, help + , long, metavar, option, strOption + ) +import qualified Options.Applicative as Opt +import qualified Control.Arrow as Arr +import Cardano.Api +import Cardano.CLI.Types (SigningKeyFile (..)) +import Cardano.Node.Types + + +lastly :: Parser a -> Parser (Last a) +lastly = (Last <$>) . optional + +---------------------------------------------------------------- + +parseFlag :: String -> String -> Parser Bool +parseFlag = parseFlag' False True + +parseFlag' :: a -> a -> String -> String -> Parser a +parseFlag' def active optname desc = + flag def active $ long optname <> help desc + +parseTargetNodeAddress :: String -> String -> Parser NodeIPv4Address +parseTargetNodeAddress optname desc = + option + ( uncurry NodeAddress + . Arr.first parseHostAddress + . Arr.second parsePort + <$> auto + ) + $ long optname + <> metavar "(HOST,PORT)" + <> help desc + +parseHostAddress :: String -> NodeHostIPv4Address +parseHostAddress = NodeHostIPv4Address . + maybe (panic "Bad host of target node") identity . readMaybe + +parsePort :: Word16 -> PortNumber +parsePort = fromIntegral + +parseFeePerTx :: String -> String -> Parser Lovelace +parseFeePerTx opt desc = quantityToLovelace . Quantity <$> parseIntegral opt desc + +parseInitialTTL :: String -> String -> Parser SlotNo +parseInitialTTL opt desc = SlotNo <$> parseIntegral opt desc + +parseSigningKeysFile :: String -> String -> Parser SigningKeyFile +parseSigningKeysFile opt desc = SigningKeyFile <$> parseFilePath opt desc + +------------------------------------------------------------------ + +parseIntegral :: Integral a => String -> String -> Parser a +parseIntegral optname desc = option (fromInteger <$> auto) + $ long optname <> metavar "INT" <> help desc + +parseDouble :: String -> String -> Parser Double +parseDouble optname desc = option auto + $ long optname <> metavar "DOUBLE" <> help desc + +parseFilePath :: String -> String -> Parser FilePath +parseFilePath optname desc = + strOption + $ long optname + <> metavar "FILEPATH" + <> help desc + <> completer (bashCompleter "file") + +parseSocketPath :: String -> String -> Parser SocketPath +parseSocketPath optname desc = + SocketPath <$> parseFilePath optname desc + +parseConfigFile :: String -> String -> Parser FilePath +parseConfigFile = parseFilePath + +parseGenesisPath :: Parser FilePath +parseGenesisPath = + strOption + ( long "genesis-file" + <> metavar "FILEPATH" + <> help "Path to the genesis yaml file." + ) + +------------------------------------------------------------------ +-- Sadly the following isn't exported from: +-- module Cardano.CLI.Shelley.Parsers +pTxIn :: Parser TxIn +pTxIn = + Opt.option (readerFromAttoParser parseTxIn) + ( Opt.long "tx-in" + <> Opt.metavar "TX-IN" + <> Opt.help "The input transaction as TxId#TxIx where TxId is the transaction hash and TxIx is the index." + ) + +parseTxIn :: Atto.Parser TxIn +parseTxIn = TxIn <$> parseTxId <*> (Atto.char '#' *> parseTxIx) + +renderTxIn :: TxIn -> Text +renderTxIn (TxIn txid (TxIx txix)) = + mconcat + [ Text.decodeUtf8 (serialiseToRawBytesHex txid) + , "#" + , Text.pack (show txix) + ] + +parseTxId :: Atto.Parser TxId +parseTxId = do + bstr <- Atto.takeWhile1 Char.isHexDigit + case deserialiseFromRawBytesHex AsTxId bstr of + Just addr -> return addr + Nothing -> fail $ "Incorrect transaction id format:: " ++ show bstr + +parseTxIx :: Atto.Parser TxIx +parseTxIx = toEnum <$> Atto.decimal + +readerFromAttoParser :: Atto.Parser a -> Opt.ReadM a +readerFromAttoParser p = + Opt.eitherReader (Atto.parseOnly (p <* Atto.endOfInput) . BSC.pack) + +pTxOut :: Parser (TxOut ShelleyEra) +pTxOut = + Opt.option (readerFromAttoParser parseTxOut) + ( Opt.long "tx-out" + <> Opt.metavar "TX-OUT" + <> Opt.help "The transaction output as Address+Lovelace where Address is \ + \the Bech32-encoded address followed by the amount in \ + \Lovelace." + ) + where + parseTxOut :: Atto.Parser (TxOut ShelleyEra) + parseTxOut = + TxOut <$> parseAddressInEra + <* Atto.char '+' + <*> (TxOutAdaOnly AdaOnlyInShelleyEra <$> parseLovelace) + +parseAddressInEra :: IsCardanoEra era => Atto.Parser (AddressInEra era) +parseAddressInEra = do + addr <- parseAddressAny + case anyAddressInEra cardanoEra addr of + Nothing -> fail "invalid address in the target era" + Just a -> pure a + +parseAddressAny :: Atto.Parser AddressAny +parseAddressAny = do + str <- lexPlausibleAddressString + case deserialiseAddress AsAddressAny str of + Nothing -> fail "invalid address" + Just addr -> pure addr + +parseLovelace :: Atto.Parser Lovelace +parseLovelace = quantityToLovelace . Quantity <$> Atto.decimal + +lexPlausibleAddressString :: Atto.Parser Text +lexPlausibleAddressString = + Text.decodeLatin1 <$> Atto.takeWhile1 isPlausibleAddressChar + where + -- Covers both base58 and bech32 (with constrained prefixes) + isPlausibleAddressChar c = + (c >= 'a' && c <= 'z') + || (c >= 'A' && c <= 'Z') + || (c >= '0' && c <= '9') + || c == '_' diff --git a/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/Error.hs b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/Error.hs new file mode 100644 index 00000000000..641fa3883a8 --- /dev/null +++ b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/Error.hs @@ -0,0 +1,21 @@ +{-# Language DerivingStrategies #-} +{-# OPTIONS_GHC -Wno-all-missed-specialisations #-} + +module Cardano.Benchmarking.GeneratorTx.Error + ( TxGenError (..) + ) where + +import Cardano.Api +import Cardano.Prelude + +data TxGenError = + InsufficientFundsForRecipientTx !Lovelace !Lovelace + -- ^ The calculated expenditure (second value) was not available as a single + -- UTxO entry. The first value is the largest single UTxO available. + | TxFileError !(FileError TextEnvelopeError) + | SplittingSubmissionError !Text + | SuppliedUtxoTooSmall !Int !Int + -- ^ The supplied UTxO size (second value) was less than the requested + -- number of transactions to send (first value). + | BadPayloadSize !Text + deriving stock Show diff --git a/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/Genesis.hs b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/Genesis.hs new file mode 100644 index 00000000000..e9acd39a31f --- /dev/null +++ b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/Genesis.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Cardano.Benchmarking.GeneratorTx.Genesis + ( genesisFundForKey + , genesisExpenditure + ) +where + +import Cardano.Prelude hiding (TypeError, filter) +import Prelude (error, filter) +import qualified Data.Map.Strict as Map + +import Control.Arrow ((***)) +import Cardano.Api +import Cardano.Api.Shelley (fromShelleyLovelace, fromShelleyStakeReference, fromShelleyPaymentCredential) + +import Cardano.Benchmarking.GeneratorTx.Tx + +import Shelley.Spec.Ledger.API (Addr(..), ShelleyGenesis, sgInitialFunds) +import Ouroboros.Consensus.Shelley.Eras (StandardShelley) + +genesisFunds :: forall era. IsShelleyBasedEra era + => NetworkId -> ShelleyGenesis StandardShelley -> [(AddressInEra era, Lovelace)] +genesisFunds networkId g + = map (castAddr *** fromShelleyLovelace) + $ Map.toList + $ sgInitialFunds g + where + castAddr (Addr _ pcr stref) + = shelleyAddressInEra $ makeShelleyAddress networkId (fromShelleyPaymentCredential pcr) (fromShelleyStakeReference stref) + castAddr _ = error "castAddr: unhandled Shelley.Addr case" + +genesisFundForKey :: forall era. IsShelleyBasedEra era + => NetworkId + -> ShelleyGenesis StandardShelley + -> SigningKey PaymentKey + -> (AddressInEra era, Lovelace) +genesisFundForKey networkId genesis key + = fromMaybe (error "No genesis funds for signing key.") + . head + . filter (isTxOutForKey . fst) + $ genesisFunds networkId genesis + where + isTxOutForKey addr = keyAddress networkId key == addr + +genesisExpenditure :: + IsShelleyBasedEra era + => NetworkId + -> SigningKey PaymentKey + -> AddressInEra era + -> Lovelace + -> Lovelace + -> SlotNo + -> (Tx era, Fund) +genesisExpenditure networkId key addr coin fee ttl = (tx, fund) + where + tx = mkGenesisTransaction (castKey key) 0 ttl fee [ pseudoTxIn ] [ txout ] + + value = mkTxOutValueAdaOnly $ coin - fee + txout = TxOut addr value + + pseudoTxIn = genesisUTxOPseudoTxIn networkId + (verificationKeyHash $ getVerificationKey $ castKey key) + + castKey :: SigningKey PaymentKey -> SigningKey GenesisUTxOKey + castKey(PaymentSigningKey skey) = GenesisUTxOSigningKey skey + + fund = mkFund (TxIn (getTxId $ getTxBody tx) (TxIx 0)) value diff --git a/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/LocalProtocolDefinition.hs b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/LocalProtocolDefinition.hs new file mode 100644 index 00000000000..bd35f9d0f10 --- /dev/null +++ b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/LocalProtocolDefinition.hs @@ -0,0 +1,168 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} + +module Cardano.Benchmarking.GeneratorTx.LocalProtocolDefinition + ( CliError (..) + , runBenchmarkScriptWith + , startProtocol + ) where + +import Prelude (error, show) +import Paths_tx_generator (version) + +import Data.Version (showVersion) +import Data.Text (pack) + +import Cardano.Prelude hiding (TypeError, show) +import Control.Monad.Trans.Except.Extra (firstExceptT) + +import Ouroboros.Consensus.Config + ( configBlock, configCodec) +import Ouroboros.Consensus.Config.SupportsNode + (ConfigSupportsNode(..), getNetworkMagic) +import Ouroboros.Network.NodeToClient (IOManager) +import Ouroboros.Network.Block (MaxSlotNo(..)) + +import Cardano.Api + +import qualified Cardano.Chain.Genesis as Genesis + +import Cardano.Node.Configuration.Logging +import Cardano.Node.Configuration.POM +import Cardano.Node.Protocol.Cardano +import Cardano.Node.Protocol.Types (SomeConsensusProtocol) +import Cardano.Node.Types + +import Cardano.Benchmarking.DSL +import Cardano.Benchmarking.Tracer + +import Cardano.Benchmarking.GeneratorTx.NodeToNode +import Cardano.Benchmarking.OuroborosImports (getGenesis, protocolToTopLevelConfig, protocolToNetworkId) + +import qualified Cardano.Benchmarking.GeneratorTx as GeneratorTx +import qualified Cardano.Benchmarking.GeneratorTx.Tx as GeneratorTx + +mangleLocalProtocolDefinition :: + SomeConsensusProtocol + -> IOManager + -> SocketPath + -> BenchTracers + -> MonoDSLs +mangleLocalProtocolDefinition + ptcl + iom + (SocketPath sock) + tracers + = (DSL {..}, DSL {..}, DSL {..}) + where + topLevelConfig = protocolToTopLevelConfig ptcl + + localConnectInfo :: LocalNodeConnectInfo CardanoMode + localConnectInfo = LocalNodeConnectInfo + (CardanoModeParams (EpochSlots 21600)) -- TODO: get this from genesis + networkId + sock + + connectClient :: ConnectClient + connectClient = benchmarkConnectTxSubmit + iom + (btConnect_ tracers) + (btSubmission_ tracers) + (configCodec topLevelConfig) + (getNetworkMagic $ configBlock topLevelConfig) + + networkId = protocolToNetworkId ptcl + + keyAddress :: IsShelleyBasedEra era => KeyAddress era + keyAddress = GeneratorTx.keyAddress networkId + + secureGenesisFund :: IsShelleyBasedEra era => SecureGenesisFund era + secureGenesisFund = GeneratorTx.secureGenesisFund + (btTxSubmit_ tracers) + (submitTxToNodeLocal localConnectInfo) + networkId + (getGenesis ptcl) + + splitFunds :: IsShelleyBasedEra era => SplitFunds era + splitFunds = GeneratorTx.splitFunds + (btTxSubmit_ tracers) + (submitTxToNodeLocal localConnectInfo) + + txGenerator :: IsShelleyBasedEra era => TxGenerator era + txGenerator = GeneratorTx.txGenerator (btTxSubmit_ tracers) + + runBenchmark :: IsShelleyBasedEra era => RunBenchmark era + runBenchmark = GeneratorTx.runBenchmark (btTxSubmit_ tracers) (btN2N_ tracers) connectClient + +runBenchmarkScriptWith :: + IOManager + -> FilePath + -> SocketPath + -> BenchmarkScript a + -> ExceptT CliError IO a +runBenchmarkScriptWith iocp logConfigFile socketFile script = do + (loggingLayer, ptcl) <- startProtocol logConfigFile + let tracers :: BenchTracers + tracers = createTracers loggingLayer + dslSet :: MonoDSLs + dslSet = mangleLocalProtocolDefinition ptcl iocp socketFile tracers + res <- firstExceptT BenchmarkRunnerError $ script (tracers, dslSet) + liftIO $ do + threadDelay (200*1000) -- Let the logging layer print out everything. + shutdownLoggingLayer loggingLayer + return res + +startProtocol + :: FilePath + -> ExceptT CliError IO (LoggingLayer, SomeConsensusProtocol) +startProtocol logConfigFile = do + nc <- liftIO $ mkNodeConfig logConfigFile + case ncProtocolConfig nc of + NodeProtocolConfigurationByron _ -> error "NodeProtocolConfigurationByron not supported" + NodeProtocolConfigurationShelley _ -> error "NodeProtocolConfigurationShelley not supported" + NodeProtocolConfigurationCardano byC shC hfC -> do + ptcl :: SomeConsensusProtocol <- firstExceptT (ProtocolInstantiationError . pack . show) $ + mkSomeConsensusProtocolCardano byC shC hfC Nothing + + loggingLayer <- mkLoggingLayer nc ptcl + return (loggingLayer, ptcl) + where + mkLoggingLayer :: NodeConfiguration -> SomeConsensusProtocol -> ExceptT CliError IO LoggingLayer + mkLoggingLayer nc ptcl = + firstExceptT (\(ConfigErrorFileNotFound fp) -> ConfigNotFoundError fp) $ + createLoggingLayer (pack $ showVersion version) nc ptcl + + mkNodeConfig :: FilePath -> IO NodeConfiguration + mkNodeConfig logConfig = do + let configFp = ConfigYamlFilePath logConfig + filesPc = defaultPartialNodeConfiguration + { pncProtocolFiles = Last . Just $ + ProtocolFilepaths + { byronCertFile = Just "" + , byronKeyFile = Just "" + , shelleyKESFile = Just "" + , shelleyVRFFile = Just "" + , shelleyCertFile = Just "" + , shelleyBulkCredsFile = Just "" + } + , pncValidateDB = Last $ Just False + , pncShutdownIPC = Last $ Just Nothing + , pncShutdownOnSlotSynced = Last $ Just NoMaxSlotNo + , pncConfigFile = Last $ Just configFp + } + configYamlPc <- parseNodeConfigurationFP . Just $ configFp + case makeNodeConfiguration $ configYamlPc <> filesPc of + Left err -> panic $ "Error in creating the NodeConfiguration: " <> pack err + Right nc' -> return nc' + +data CliError = + GenesisReadError !FilePath !Genesis.GenesisDataError + | FileNotFoundError !FilePath + | ConfigNotFoundError !FilePath + | ProtocolInstantiationError !Text + | BenchmarkRunnerError !GeneratorTx.TxGenError + deriving stock Show diff --git a/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/NodeToNode.hs b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/NodeToNode.hs new file mode 100644 index 00000000000..1c85aa3720c --- /dev/null +++ b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/NodeToNode.hs @@ -0,0 +1,153 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +{-# OPTIONS_GHC -fno-warn-orphans -Wno-unticked-promoted-constructors -Wno-all-missed-specialisations #-} + +module Cardano.Benchmarking.GeneratorTx.NodeToNode + ( ConnectClient + , benchmarkConnectTxSubmit + ) where + +import Cardano.Prelude (forever, liftIO) +import Prelude + +import Codec.Serialise (DeserialiseFailure) +import Control.Monad.Class.MonadTimer (MonadTimer, threadDelay) +import Control.Monad.Class.MonadSTM.Strict (newTVarIO) +import Data.ByteString.Lazy (ByteString) +import qualified Data.Map as Map +import Data.Proxy (Proxy (..)) +import Network.Socket (AddrInfo (..)) +import System.Random (newStdGen) + +import Control.Tracer (Tracer, nullTracer) +import Ouroboros.Consensus.Byron.Ledger.Mempool (GenTx) +import Ouroboros.Consensus.Block.Abstract +import qualified Ouroboros.Consensus.Cardano as Consensus (CardanoBlock) +import Ouroboros.Consensus.Ledger.SupportsMempool (GenTxId) +import Ouroboros.Consensus.Network.NodeToNode (Codecs (..), defaultCodecs) +import Ouroboros.Consensus.Node.NetworkProtocolVersion +import Ouroboros.Consensus.Node.Run (RunNode) +import Ouroboros.Consensus.Shelley.Protocol (StandardCrypto) + +import Ouroboros.Network.Channel (Channel (..)) +import Ouroboros.Network.DeltaQ (defaultGSV) +import Ouroboros.Network.Driver (runPeerWithLimits) +import Ouroboros.Network.KeepAlive +import Ouroboros.Network.Magic +import Ouroboros.Network.Mux (MuxPeer (..), RunMiniProtocol (..), continueForever) +import Ouroboros.Network.NodeToClient (chainSyncPeerNull, IOManager) +import Ouroboros.Network.NodeToNode (NetworkConnectTracers (..)) +import qualified Ouroboros.Network.NodeToNode as NtN +import Ouroboros.Network.Protocol.BlockFetch.Client (BlockFetchClient (..), + blockFetchClientPeer) +import Ouroboros.Network.Protocol.Handshake.Version (simpleSingletonVersions) +import Ouroboros.Network.Protocol.KeepAlive.Codec +import Ouroboros.Network.Protocol.KeepAlive.Client +import Ouroboros.Network.Protocol.TxSubmission.Client (TxSubmissionClient, + txSubmissionClientPeer) +import Ouroboros.Network.Snocket (socketSnocket) + +import Cardano.Benchmarking.Tracer (SendRecvConnect, SendRecvTxSubmission) + +type CardanoBlock = Consensus.CardanoBlock StandardCrypto +type ConnectClient = AddrInfo -> TxSubmissionClient (GenTxId CardanoBlock) (GenTx CardanoBlock) IO () -> IO () + +benchmarkConnectTxSubmit + :: forall blk. (blk ~ CardanoBlock, RunNode blk ) + => IOManager + -> Tracer IO SendRecvConnect + -> Tracer IO SendRecvTxSubmission + -> CodecConfig CardanoBlock + -> NetworkMagic + -> AddrInfo + -- ^ remote address information + -> TxSubmissionClient (GenTxId blk) (GenTx blk) IO () + -- ^ the particular txSubmission peer + -> IO () + +benchmarkConnectTxSubmit ioManager handshakeTracer submissionTracer codecConfig networkMagic remoteAddr myTxSubClient = + NtN.connectTo + (socketSnocket ioManager) + NetworkConnectTracers { + nctMuxTracer = nullTracer, + nctHandshakeTracer = handshakeTracer + } + peerMultiplex + (addrAddress <$> Nothing) + (addrAddress remoteAddr) + where + n2nVer :: NodeToNodeVersion + n2nVer = NodeToNodeV_5 + blkN2nVer :: BlockNodeToNodeVersion blk + blkN2nVer = supportedVers Map.! n2nVer + supportedVers :: Map.Map NodeToNodeVersion (BlockNodeToNodeVersion blk) + supportedVers = supportedNodeToNodeVersions (Proxy @blk) + myCodecs :: Codecs blk DeserialiseFailure IO + ByteString ByteString ByteString ByteString ByteString ByteString ByteString + myCodecs = defaultCodecs codecConfig blkN2nVer n2nVer + peerMultiplex = + simpleSingletonVersions + n2nVer + (NtN.NodeToNodeVersionData + { NtN.networkMagic = networkMagic + , NtN.diffusionMode = NtN.InitiatorOnlyDiffusionMode + }) $ + NtN.nodeToNodeProtocols NtN.defaultMiniProtocolParameters ( \them _ -> + NtN.NodeToNodeProtocols + { NtN.chainSyncProtocol = InitiatorProtocolOnly $ + MuxPeer + nullTracer + (cChainSyncCodec myCodecs) + chainSyncPeerNull + , NtN.blockFetchProtocol = InitiatorProtocolOnly $ + MuxPeer + nullTracer + (cBlockFetchCodec myCodecs) + (blockFetchClientPeer blockFetchClientNull) + , NtN.keepAliveProtocol = InitiatorProtocolOnly $ + MuxPeerRaw + (kaClient n2nVer them) + , NtN.txSubmissionProtocol = InitiatorProtocolOnly $ + MuxPeer + submissionTracer + (cTxSubmissionCodec myCodecs) + (txSubmissionClientPeer myTxSubClient) + } ) + n2nVer + -- Stolen from: Ouroboros/Consensus/Network/NodeToNode.hs + kaClient + :: Ord remotePeer + => NodeToNodeVersion + -> remotePeer + -> Channel IO ByteString + -> IO ((), Maybe ByteString) + kaClient version them channel = do + case version of + -- Version 1 doesn't support keep alive protocol but Blockfetch + -- still requires a PeerGSV per peer. + NodeToNodeV_1 -> forever (threadDelay 1000) >> return ((), Nothing) + NodeToNodeV_2 -> forever (threadDelay 1000) >> return ((), Nothing) + _ -> do + keepAliveRng <- newStdGen + peerGSVMap <- liftIO . newTVarIO $ Map.singleton them defaultGSV + runPeerWithLimits + nullTracer + (cKeepAliveCodec myCodecs) + (byteLimitsKeepAlive (const 0)) -- TODO: Real Bytelimits, see #1727 + timeLimitsKeepAlive + channel + $ keepAliveClientPeer + $ keepAliveClient + nullTracer + keepAliveRng + (continueForever (Proxy :: Proxy IO)) them peerGSVMap + (KeepAliveInterval 10) + +-- the null block fetch client +blockFetchClientNull + :: forall block point m a. MonadTimer m + => BlockFetchClient block point m a +blockFetchClientNull + = BlockFetchClient $ forever $ threadDelay (24 * 60 * 60) {- one day in seconds -} diff --git a/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/SizedMetadata.hs b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/SizedMetadata.hs new file mode 100644 index 00000000000..4a3e3bca031 --- /dev/null +++ b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/SizedMetadata.hs @@ -0,0 +1,152 @@ +{- HLINT ignore "Use camelCase" -} +{- HLINT ignore "Use uncurry" -} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE GADTs #-} +module Cardano.Benchmarking.GeneratorTx.SizedMetadata +where + +import Prelude + +import qualified Data.Map.Strict as Map +import Data.Word (Word64) +import qualified Data.ByteString as BS +import Cardano.Benchmarking.GeneratorTx.Tx +import Cardano.Api + +maxMapSize :: Int +maxMapSize = 1000 +maxBSSize :: Int +maxBSSize = 64 + +-- Properties of the underlying/opaque CBOR encoding. +assume_cbor_properties :: Bool +assume_cbor_properties + = prop_mapCostsShelley + && prop_mapCostsAllegra + && prop_mapCostsMary + && prop_bsCostsShelley + && prop_bsCostsAllegra + && prop_bsCostsMary + +-- The cost of map entries in metadata follows a step function. +-- This assums the map indecies are [0..n]. +prop_mapCostsShelley :: Bool +prop_mapCostsAllegra :: Bool +prop_mapCostsMary :: Bool +prop_mapCostsShelley = measureMapCosts AsShelleyEra == assumeMapCosts AsShelleyEra +prop_mapCostsAllegra = measureMapCosts AsAllegraEra == assumeMapCosts AsAllegraEra +prop_mapCostsMary = measureMapCosts AsMaryEra == assumeMapCosts AsMaryEra + +assumeMapCosts :: forall era . IsShelleyBasedEra era => AsType era -> [Int] +assumeMapCosts _proxy = stepFunction [ + ( 1 , 0) -- An empty map of metadata has the same cost as TxMetadataNone. + , ( 1 , firstEntry) -- Using Metadata costs 37 or 39 bytes (first map entry). + , ( 22 , 2) -- The next 22 entries cost 2 bytes each. + , ( 233 , 3) -- 233 entries at 3 bytes. + , ( 744 , 4) -- 744 entries at 4 bytes. + ] + where + firstEntry = case shelleyBasedEra @ era of + ShelleyBasedEraShelley -> 37 + ShelleyBasedEraAllegra -> 39 + ShelleyBasedEraMary -> 39 + +-- Bytestring costs are not LINEAR !! +-- Costs are piecewise linear for payload sizes [0..23] and [24..64]. +prop_bsCostsShelley :: Bool +prop_bsCostsAllegra :: Bool +prop_bsCostsMary :: Bool +prop_bsCostsShelley = measureBSCosts AsShelleyEra == [37..60] ++ [62..102] +prop_bsCostsAllegra = measureBSCosts AsAllegraEra == [39..62] ++ [64..104] +prop_bsCostsMary = measureBSCosts AsMaryEra == [39..62] ++ [64..104] + +stepFunction :: [(Int, Int)] -> [Int] +stepFunction f = scanl1 (+) steps + where steps = concatMap (\(count,step) -> replicate count step) f + +-- Measure the cost of metadata map entries. +-- This is the cost of the index with an empty BS as payload. +measureMapCosts :: forall era . IsShelleyBasedEra era => AsType era -> [Int] +measureMapCosts era = map (metadataSize era . Just . replicateEmptyBS) [0..maxMapSize] + where + replicateEmptyBS :: Int -> TxMetadata + replicateEmptyBS n = listMetadata $ replicate n $ TxMetaBytes BS.empty + +listMetadata :: [TxMetadataValue] -> TxMetadata +listMetadata l = makeTransactionMetadata $ Map.fromList $ zip [0..] l + +-- Cost of metadata with a single BS of size [0..maxBSSize]. +measureBSCosts :: forall era . IsShelleyBasedEra era => AsType era -> [Int] +measureBSCosts era = map (metadataSize era . Just . bsMetadata) [0..maxBSSize] + where bsMetadata s = listMetadata [TxMetaBytes $ BS.replicate s 0] + +metadataSize :: forall era . IsShelleyBasedEra era => AsType era -> Maybe TxMetadata -> Int +metadataSize p m = dummyTxSize p m - dummyTxSize p Nothing + +dummyTxSizeInEra :: forall era . IsShelleyBasedEra era => TxMetadataInEra era -> Int +dummyTxSizeInEra metadata = case makeTransactionBody dummyTx of + Right b -> BS.length $ serialiseToCBOR b + Left err -> error $ "metaDataSize " ++ show err + where + dummyTx :: TxBodyContent BuildTx era + dummyTx = TxBodyContent { + txIns = [( TxIn "dbaff4e270cfb55612d9e2ac4658a27c79da4a5271c6f90853042d1403733810" (TxIx 0) + , BuildTxWith $ KeyWitness KeyWitnessForSpending )] + , txOuts = [] + , txFee = mkFee 0 + , txValidityRange = (TxValidityNoLowerBound, mkValidityUpperBound 0) + , txMetadata = metadata + , txAuxScripts = TxAuxScriptsNone + , txWithdrawals = TxWithdrawalsNone + , txCertificates = TxCertificatesNone + , txUpdateProposal = TxUpdateProposalNone + , txMintValue = TxMintNone + } + +dummyTxSize :: forall era . IsShelleyBasedEra era => AsType era -> Maybe TxMetadata -> Int +dummyTxSize _p m = (dummyTxSizeInEra @ era) $ metadataInEra m + +metadataInEra :: forall era . IsShelleyBasedEra era => Maybe TxMetadata -> TxMetadataInEra era +metadataInEra Nothing = TxMetadataNone +metadataInEra (Just m) = case shelleyBasedEra @ era of + ShelleyBasedEraShelley -> TxMetadataInEra TxMetadataInShelleyEra m + ShelleyBasedEraAllegra -> TxMetadataInEra TxMetadataInAllegraEra m + ShelleyBasedEraMary -> TxMetadataInEra TxMetadataInMaryEra m + +mkMetadata :: forall era . IsShelleyBasedEra era => Int -> Either String (TxMetadataInEra era) +mkMetadata 0 = Right $ metadataInEra Nothing +mkMetadata size + = if size < minSize + then Left $ "Error : metadata must be 0 or at least " ++ show minSize ++ " bytes in this era." + else Right $ metadataInEra $ Just metadata + where + minSize = case shelleyBasedEra @ era of + ShelleyBasedEraShelley -> 37 + ShelleyBasedEraAllegra -> 39 + ShelleyBasedEraMary -> 39 + nettoSize = size - minSize + + -- At 24 the CBOR representation changes. + maxLinearByteStringSize = 23 + fullChunkSize = maxLinearByteStringSize + 1 + + -- A full chunk consists of 4 bytes for the index and 20 bytes for the bytestring. + -- Each full chunk adds exactly `fullChunkSize` (== 24) bytes. + -- The remainder is added in the first chunk. + mkFullChunk ix = (ix, TxMetaBytes $ BS.replicate (fullChunkSize - 4) 0) + + fullChunkCount :: Word64 + fullChunkCount = fromIntegral $ nettoSize `div` fullChunkSize + + -- Full chunks use indices starting at 1000, to enforce 4-byte encoding of the index. + -- At some index the encoding will change to 5 bytes and this will break. + fullChunks = map mkFullChunk [1000 .. 1000 + fullChunkCount -1] + + -- The first chunk has a variable size. + firstChunk = + ( 0 -- the first chunk uses index 0 + , TxMetaBytes $ BS.replicate (nettoSize `mod` fullChunkSize) 0 + ) + + metadata = makeTransactionMetadata $ Map.fromList (firstChunk : fullChunks) diff --git a/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/Submission.hs b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/Submission.hs new file mode 100644 index 00000000000..f70c8345f6b --- /dev/null +++ b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/Submission.hs @@ -0,0 +1,384 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} +{-# OPTIONS_GHC -Wno-all-missed-specialisations #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Cardano.Benchmarking.GeneratorTx.Submission + ( SubmissionParams(..) + , Submission(sParams) + , SubmissionThreadReport + , mkSubmission + , mkSubmissionSummary + , submitThreadReport + , txSubmissionClient + , simpleTxFeeder + , tpsLimitedTxFeeder + , tpsLimitedTxFeederShutdown + ) where + +import Prelude (String, error, fail) +import Cardano.Prelude hiding (ByteString, atomically, retry, threadDelay) + +import Control.Arrow ((&&&)) +import Control.Concurrent (threadDelay) +import qualified Control.Concurrent.STM as STM +import Control.Concurrent.STM.TBQueue (TBQueue) + +import qualified Data.List as L +import qualified Data.List.Extra as L +import qualified Data.List.NonEmpty as NE +import qualified Data.Text as T +import Data.Time.Clock (NominalDiffTime, UTCTime) +import qualified Data.Time.Clock as Clock + +import Control.Tracer (Tracer, traceWith) + +import Cardano.Tracing.OrphanInstances.Byron () +import Cardano.Tracing.OrphanInstances.Common () +import Cardano.Tracing.OrphanInstances.Consensus () +import Cardano.Tracing.OrphanInstances.Network () +import Cardano.Tracing.OrphanInstances.Shelley () + +import qualified Ouroboros.Consensus.Cardano as Consensus (CardanoBlock) +import Ouroboros.Consensus.Ledger.SupportsMempool (GenTx, GenTxId, txInBlockSize) +import qualified Ouroboros.Consensus.Ledger.SupportsMempool as Mempool +import Ouroboros.Consensus.Shelley.Ledger.Mempool (mkShelleyTx) +import qualified Ouroboros.Consensus.Shelley.Ledger.Mempool as Mempool (TxId(ShelleyTxId)) +import Ouroboros.Consensus.Shelley.Protocol (StandardCrypto) + +import Ouroboros.Consensus.Cardano.Block (GenTx (GenTxShelley, GenTxMary, GenTxAllegra)) +import qualified Ouroboros.Consensus.Cardano.Block as Block (TxId(GenTxIdShelley, GenTxIdAllegra, GenTxIdMary)) + +import Ouroboros.Network.Protocol.TxSubmission.Client (ClientStIdle (..), + ClientStTxIds (..), + ClientStTxs (..), + TxSubmissionClient (..)) +import Ouroboros.Network.Protocol.TxSubmission.Type (BlockingReplyList (..), + TokBlockingStyle (..), TxSizeInBytes) + +import Cardano.Api +import Cardano.Api.Shelley (Tx(ShelleyTx), fromShelleyTxId) + +import Cardano.Benchmarking.Tracer +import Cardano.Benchmarking.Types + +{------------------------------------------------------------------------------- + Parametrisation & state +-------------------------------------------------------------------------------} +type CardanoBlock = Consensus.CardanoBlock StandardCrypto + +data SubmissionParams + = SubmissionParams + { spTps :: !TPSRate + , spTargets :: !Natural + , spQueueLen :: !Natural + , spErrorPolicy :: !SubmissionErrorPolicy + } + +data Submission (m :: Type -> Type) (era :: Type) + = Submission + { sParams :: !SubmissionParams + , sStartTime :: !UTCTime + , sThreads :: !Natural + , sTxSendQueue :: !(TBQueue (Maybe (Tx era))) + , sReportsRefs :: ![STM.TMVar (Either String SubmissionThreadReport)] + , sTrace :: !(Tracer m (TraceBenchTxSubmit TxId)) + } + +mkSubmission + :: MonadIO m + => Tracer m (TraceBenchTxSubmit TxId) + -> SubmissionParams + -> m (Submission m era) +mkSubmission sTrace sParams@SubmissionParams{spTargets=sThreads, spQueueLen} = liftIO $ do + sStartTime <- Clock.getCurrentTime + sTxSendQueue <- STM.newTBQueueIO spQueueLen + sReportsRefs <- STM.atomically $ replicateM (fromIntegral sThreads) STM.newEmptyTMVar + pure Submission{..} + +submitThreadReport + :: MonadIO m + => Submission m era + -> Natural + -> Either String SubmissionThreadReport + -> m () +submitThreadReport Submission{sReportsRefs} threadIx = + liftIO . STM.atomically . STM.putTMVar (sReportsRefs L.!! fromIntegral threadIx) + +{------------------------------------------------------------------------------- + Results +-------------------------------------------------------------------------------} +data SubmissionThreadStats + = SubmissionThreadStats + { stsAcked :: {-# UNPACK #-} !Ack + , stsSent :: {-# UNPACK #-} !Sent + , stsUnavailable :: {-# UNPACK #-} !Unav + } + +data SubmissionThreadReport + = SubmissionThreadReport + { strStats :: !SubmissionThreadStats + , strThreadIndex :: !Natural + , strEndOfProtocol :: !UTCTime + } + +mkSubmissionSummary :: + String + -> Submission IO tx + -> IO SubmissionSummary +mkSubmissionSummary ssThreadName Submission{ sStartTime, sReportsRefs} + = do + results <- sequence (STM.atomically . STM.readTMVar <$> sReportsRefs) + let (failures, reports) = partitionEithers results + now <- Clock.getCurrentTime + let ssElapsed = Clock.diffUTCTime now sStartTime + ssTxSent@(Sent sent) = sum $ stsSent . strStats <$> reports + ssTxUnavailable = sum $ stsUnavailable . strStats <$> reports + ssEffectiveTps = txDiffTimeTPS sent ssElapsed + ssThreadwiseTps = threadReportTps <$> reports + ssFailures = failures + pure SubmissionSummary{..} + where + txDiffTimeTPS :: Int -> NominalDiffTime -> TPSRate + txDiffTimeTPS n delta = + TPSRate $ realToFrac $ fromIntegral n / delta + + threadReportTps :: SubmissionThreadReport -> TPSRate + threadReportTps + SubmissionThreadReport + { strStats=SubmissionThreadStats{stsAcked=Ack ack}, strEndOfProtocol } = + txDiffTimeTPS ack (Clock.diffUTCTime strEndOfProtocol sStartTime) + +{------------------------------------------------------------------------------- + Submission queue: feeding and consumption +-------------------------------------------------------------------------------} +simpleTxFeeder + :: forall m era + . (MonadIO m) + => Submission m era -> [Tx era] -> m () +simpleTxFeeder + Submission{sTrace, sThreads, sTxSendQueue} txs = do + foldM_ (const feedTx) () (zip txs [0..]) + -- Issue the termination notifications. + replicateM_ (fromIntegral sThreads) $ + liftIO $ STM.atomically $ STM.writeTBQueue sTxSendQueue Nothing + where + feedTx :: (Tx era, Int) -> m () + feedTx (tx, ix) = do + liftIO $ STM.atomically $ STM.writeTBQueue sTxSendQueue (Just tx) + traceWith sTrace $ TraceBenchTxSubServFed [getTxId $ getTxBody tx] ix + +tpsLimitedTxFeederShutdown :: Submission m era -> IO () +tpsLimitedTxFeederShutdown Submission{sThreads, sTxSendQueue } + = do + replicateM_ (fromIntegral sThreads) + . STM.atomically $ STM.writeTBQueue sTxSendQueue Nothing + +tpsLimitedTxFeeder + :: forall m era . MonadIO m => Submission m era -> [Tx era] -> m () +tpsLimitedTxFeeder submission txs = do + -- It would be nice to catch an AsyncException here and do a clean shutdown. + -- However this would require extra machineries because we are in MonadIO m not in IO (). + -- TODO: Move everything to IO () and avoid problems from over-polymorphism. + now <- liftIO Clock.getCurrentTime + foldM_ feedTx (now, 0) (zip txs [0..]) + liftIO $ tpsLimitedTxFeederShutdown submission + where + Submission{ sParams=SubmissionParams{spTps=TPSRate rate} + , sTrace + , sTxSendQueue } = submission + + feedTx :: (UTCTime, NominalDiffTime) + -> (Tx era, Int) + -> m (UTCTime, NominalDiffTime) + feedTx (lastPreDelay, lastDelay) (tx, ix) = do + liftIO . STM.atomically $ STM.writeTBQueue sTxSendQueue (Just tx) + traceWith sTrace $ TraceBenchTxSubServFed [getTxId $ getTxBody tx] ix + now <- liftIO Clock.getCurrentTime + let targetDelay = realToFrac $ 1.0 / rate + loopCost = (now `Clock.diffUTCTime` lastPreDelay) - lastDelay + delay = targetDelay - loopCost + liftIO . threadDelay . ceiling $ (realToFrac delay * 1000000.0 :: Double) + pure (now, delay) + +consumeTxs + :: forall m blk era + . (MonadIO m) + => Submission m era -> TokBlockingStyle blk -> Req -> m (Bool, UnReqd (Tx era)) +consumeTxs Submission{sTxSendQueue} blk req + = liftIO . STM.atomically $ go blk req [] + where + go :: TokBlockingStyle a -> Req -> [Tx era] -> STM (Bool, UnReqd (Tx era)) + go _ 0 acc = pure (False, UnReqd acc) + go TokBlocking n acc = STM.readTBQueue sTxSendQueue >>= + \case + Nothing -> pure (True, UnReqd acc) + Just tx -> go TokBlocking (n - 1) (tx:acc) + go TokNonBlocking _ _ = STM.tryReadTBQueue sTxSendQueue >>= + \case + Nothing -> pure (False, UnReqd []) + Just Nothing -> pure (True, UnReqd []) + Just (Just tx) -> pure (False, UnReqd [tx]) + +txSubmissionClient + :: forall m era tx txid gentx gentxid . + ( MonadIO m, MonadFail m + , IsShelleyBasedEra era + , tx ~ Tx era + , txid ~ TxId + , gentx ~ GenTx CardanoBlock + , gentxid ~ GenTxId CardanoBlock + ) + => Tracer m NodeToNodeSubmissionTrace + -> Tracer m (TraceBenchTxSubmit txid) + -> Submission m era + -> Natural + -- This return type is forced by Ouroboros.Network.NodeToNode.connectTo + -> TxSubmissionClient gentxid gentx m () +txSubmissionClient tr bmtr sub threadIx = + TxSubmissionClient $ + pure $ client False (UnAcked []) (SubmissionThreadStats 0 0 0) + where + -- Nothing means we've ran out of things to either announce or send. + decideAnnouncement :: TokBlockingStyle a + -> Ack -> UnReqd tx -> UnAcked tx + -> m (Either Text (ToAnnce tx, UnAcked tx, Acked tx)) + decideAnnouncement b (Ack ack) (UnReqd annNow) (UnAcked unAcked) = + if tokIsBlocking b && ack /= length unAcked + then pure $ Left "decideAnnouncement: TokBlocking, but length unAcked != ack" + else pure $ Right (ToAnnce annNow, UnAcked newUnacked, Acked acked) + where + stillUnacked, newUnacked, acked :: [tx] + (stillUnacked, acked) = L.splitAtEnd ack unAcked + newUnacked = annNow <> stillUnacked + + -- Sadly, we can't just return what we want, we instead have to + -- communicate via IORefs, because.. + client :: Bool -> UnAcked tx -> SubmissionThreadStats + -- The () return type is forced by Ouroboros.Network.NodeToNode.connectTo + -> ClientStIdle gentxid gentx m () + client done unAcked (!stats) = ClientStIdle + { recvMsgRequestTxIds = \blocking ackNum reqNum + -> do + let ack = Ack $ fromIntegral ackNum + req = Req $ fromIntegral reqNum + traceWith tr $ reqIdsTrace ack req blocking + + (exhausted, unReqd) <- + if done then pure (True, UnReqd []) + else consumeTxs sub blocking req + + r' <- decideAnnouncement blocking ack unReqd unAcked + (ann@(ToAnnce annNow), newUnacked@(UnAcked outs), Acked acked) + <- case r' of + Left e -> traceWith bmtr (TraceBenchTxSubError e) + >> fail (T.unpack e) + Right x -> pure x + + traceWith tr $ idListTrace ann blocking + traceWith bmtr $ TraceBenchTxSubServAnn (getTxId . getTxBody <$> annNow) + traceWith bmtr $ TraceBenchTxSubServAck (getTxId . getTxBody <$> acked) + traceWith bmtr $ TraceBenchTxSubServOuts (getTxId . getTxBody <$> outs) + + let newStats = stats { stsAcked = + stsAcked stats + ack } + + case (exhausted, NE.nonEmpty annNow, blocking) of + (_, Nothing, TokBlocking) -> do + traceWith tr EndOfProtocol + SendMsgDone <$> (submitReport newStats + -- The () return type is forced by + -- Ouroboros.Network.NodeToNode.connectTo + >> pure ()) + + (_, Just neAnnNow, TokBlocking) -> + pure $ SendMsgReplyTxIds + (BlockingReply $ txToIdSize <$> neAnnNow) + (client exhausted newUnacked newStats) + + (False, Nothing, TokNonBlocking) -> do + pure $ SendMsgReplyTxIds + (NonBlockingReply []) + (client exhausted newUnacked newStats) + + (_, _, TokNonBlocking) -> + pure $ SendMsgReplyTxIds + (NonBlockingReply $ txToIdSize <$> annNow) + (client exhausted newUnacked newStats) + + , recvMsgRequestTxs = \txIds -> do + let reqTxIds :: [txid] + reqTxIds = fmap fromGenTxId txIds + traceWith tr $ ReqTxs (length reqTxIds) + let UnAcked ua = unAcked + uaIds = getTxId . getTxBody <$> ua + (toSend, _retained) = L.partition ((`L.elem` reqTxIds) . getTxId . getTxBody) ua + missIds = reqTxIds L.\\ uaIds + + traceWith tr $ TxList (length toSend) + traceWith bmtr $ TraceBenchTxSubServReq reqTxIds + traceWith bmtr $ TraceBenchTxSubServOuts (getTxId . getTxBody <$> ua) + unless (L.null missIds) $ + traceWith bmtr $ TraceBenchTxSubServUnav missIds + pure $ SendMsgReplyTxs (toGenTx <$> toSend) + (client done unAcked $ + stats { stsSent = + stsSent stats + Sent (length toSend) + , stsUnavailable = + stsUnavailable stats + Unav (length missIds)}) + } + + submitReport :: SubmissionThreadStats -> m SubmissionThreadReport + submitReport strStats = do + strEndOfProtocol <- liftIO Clock.getCurrentTime + let strThreadIndex = threadIx + report = SubmissionThreadReport{..} + submitThreadReport sub threadIx (Right report) + pure report + + txToIdSize :: tx -> (gentxid, TxSizeInBytes) + txToIdSize = (Mempool.txId &&& txInBlockSize) . toGenTx + + toGenTx :: tx -> gentx + toGenTx tx = case (shelleyBasedEra @ era , tx) of + (ShelleyBasedEraShelley, ShelleyTx _ tx') -> GenTxShelley (mkShelleyTx tx') + (ShelleyBasedEraAllegra, ShelleyTx _ tx') -> GenTxAllegra (mkShelleyTx tx') + (ShelleyBasedEraMary, ShelleyTx _ tx') -> GenTxMary (mkShelleyTx tx') + + fromGenTxId :: gentxid -> txid + fromGenTxId (Block.GenTxIdShelley (Mempool.ShelleyTxId i)) = fromShelleyTxId i + fromGenTxId (Block.GenTxIdAllegra (Mempool.ShelleyTxId i)) = fromShelleyTxId i + fromGenTxId (Block.GenTxIdMary (Mempool.ShelleyTxId i)) = fromShelleyTxId i + fromGenTxId _ = error "submission.hs: fromGenTxId" + + tokIsBlocking :: TokBlockingStyle a -> Bool + tokIsBlocking = \case + TokBlocking -> True + TokNonBlocking -> False + + reqIdsTrace :: Ack -> Req -> TokBlockingStyle a -> NodeToNodeSubmissionTrace + reqIdsTrace ack req = \case + TokBlocking -> ReqIdsBlocking ack req + TokNonBlocking -> ReqIdsPrompt ack req + + idListTrace :: ToAnnce tx -> TokBlockingStyle a -> NodeToNodeSubmissionTrace + idListTrace (ToAnnce toAnn) = \case + TokBlocking -> IdsListBlocking $ length toAnn + TokNonBlocking -> IdsListPrompt $ length toAnn diff --git a/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/Tx.hs b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/Tx.hs new file mode 100644 index 00000000000..02388b46e9c --- /dev/null +++ b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/Tx.hs @@ -0,0 +1,210 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -Wno-all-missed-specialisations #-} + +module Cardano.Benchmarking.GeneratorTx.Tx + ( Fund + , fundTxIn + , fundAdaValue + , keyAddress + , mkGenesisTransaction + , mkFund + , mkFee + , mkTransactionGen + , mkTxOutValueAdaOnly + , mkValidityUpperBound + , txOutValueToLovelace + , txInModeCardano + ) +where + +import Prelude + +import qualified Data.List.NonEmpty as NonEmpty +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.Map.Strict as Map +import Data.Map.Strict (Map) + +import Cardano.Benchmarking.Types (TxAdditionalSize(..)) + +import Cardano.Api + +type Fund = (TxIn, InAnyCardanoEra TxOutValue) + +mkFund :: forall era. IsCardanoEra era => TxIn -> TxOutValue era -> Fund +mkFund txIn val = (txIn, InAnyCardanoEra cardanoEra val) + +fundTxIn :: Fund -> TxIn +fundTxIn (x,_) = x + +fundAdaValue :: Fund -> Lovelace +fundAdaValue (_, InAnyCardanoEra _ txOut) = txOutValueToLovelace txOut + +keyAddress :: forall era. IsShelleyBasedEra era => NetworkId -> SigningKey PaymentKey -> AddressInEra era +keyAddress networkId k + = makeShelleyAddressInEra + networkId + (PaymentCredentialByKey $ verificationKeyHash $ getVerificationKey k) + NoStakeAddress + +--{-# DEPRECATED mkGenesisTransaction "to be removed" #-} +mkGenesisTransaction :: forall era . + IsShelleyBasedEra era + => SigningKey GenesisUTxOKey + -> TxAdditionalSize + -> SlotNo + -> Lovelace + -> [TxIn] + -> [TxOut era] + -> Tx era +mkGenesisTransaction key _payloadSize ttl fee txins txouts + = case makeTransactionBody txBodyContent of + Right b -> signShelleyTransaction b [WitnessGenesisUTxOKey key] + Left err -> error $ show err + where + txBodyContent = TxBodyContent { + txIns = zip txins $ repeat $ BuildTxWith $ KeyWitness KeyWitnessForSpending + , txOuts = txouts + , txFee = fees + , txValidityRange = (TxValidityNoLowerBound, validityUpperBound) + , txMetadata = TxMetadataNone + , txAuxScripts = TxAuxScriptsNone + , txWithdrawals = TxWithdrawalsNone + , txCertificates = TxCertificatesNone + , txUpdateProposal = TxUpdateProposalNone + , txMintValue = TxMintNone + } + fees = case shelleyBasedEra @ era of + ShelleyBasedEraShelley -> TxFeeExplicit TxFeesExplicitInShelleyEra fee + ShelleyBasedEraAllegra -> TxFeeExplicit TxFeesExplicitInAllegraEra fee + ShelleyBasedEraMary -> TxFeeExplicit TxFeesExplicitInMaryEra fee + validityUpperBound = case shelleyBasedEra @ era of + ShelleyBasedEraShelley -> TxValidityUpperBound ValidityUpperBoundInShelleyEra ttl + ShelleyBasedEraAllegra -> TxValidityUpperBound ValidityUpperBoundInAllegraEra ttl + ShelleyBasedEraMary -> TxValidityUpperBound ValidityUpperBoundInMaryEra ttl + +mkTransaction :: forall era . + IsShelleyBasedEra era + => SigningKey PaymentKey + -> TxMetadataInEra era + -> SlotNo + -> Lovelace + -> [TxIn] + -> [TxOut era] + -> Tx era +mkTransaction key metadata ttl fee txins txouts + = case makeTransactionBody txBodyContent of + Right b -> signShelleyTransaction b [WitnessPaymentKey key] + Left err -> error $ show err + where + txBodyContent = TxBodyContent { + txIns = zip txins $ repeat $ BuildTxWith $ KeyWitness KeyWitnessForSpending + , txOuts = txouts + , txFee = mkFee fee + , txValidityRange = (TxValidityNoLowerBound, mkValidityUpperBound ttl) + , txMetadata = metadata + , txAuxScripts = TxAuxScriptsNone + , txWithdrawals = TxWithdrawalsNone + , txCertificates = TxCertificatesNone + , txUpdateProposal = TxUpdateProposalNone + , txMintValue = TxMintNone + } + +mkFee :: forall era . + IsShelleyBasedEra era + => Lovelace + -> TxFee era +mkFee f = case shelleyBasedEra @ era of + ShelleyBasedEraShelley -> TxFeeExplicit TxFeesExplicitInShelleyEra f + ShelleyBasedEraAllegra -> TxFeeExplicit TxFeesExplicitInAllegraEra f + ShelleyBasedEraMary -> TxFeeExplicit TxFeesExplicitInMaryEra f + +mkValidityUpperBound :: forall era . + IsShelleyBasedEra era + => SlotNo + -> TxValidityUpperBound era +mkValidityUpperBound ttl = case shelleyBasedEra @ era of + ShelleyBasedEraShelley -> TxValidityUpperBound ValidityUpperBoundInShelleyEra ttl + ShelleyBasedEraAllegra -> TxValidityUpperBound ValidityUpperBoundInAllegraEra ttl + ShelleyBasedEraMary -> TxValidityUpperBound ValidityUpperBoundInMaryEra ttl + +mkTransactionGen :: forall era . + IsShelleyBasedEra era + => SigningKey PaymentKey + -> NonEmpty Fund + -> AddressInEra era + -> [(Int, TxOut era)] + -- ^ Each recipient and their payment details + -> TxMetadataInEra era + -- ^ Optional size of additional binary blob in transaction (as 'txAttributes') + -> Lovelace + -- ^ Tx fee. + -> ( Maybe (TxIx, Lovelace) -- The 'change' index and value (if any) + , Lovelace -- The associated fees + , Map Int TxIx -- The offset map in the transaction below + , Tx era + ) +mkTransactionGen signingKey inputs address payments metadata fee = + (mChange, fee, offsetMap, tx) + where + tx = mkTransaction signingKey metadata (SlotNo 10000000) + fee + (NonEmpty.toList $ fundTxIn <$> inputs) + (NonEmpty.toList txOutputs) + + payTxOuts = map snd payments + + totalInpValue = sum $ fundAdaValue <$> inputs + totalOutValue = txOutSum payTxOuts + changeValue = totalInpValue - totalOutValue - fee + -- change the order of comparisons first check emptyness of txouts AND remove appendr after + + (txOutputs, mChange) = case compare changeValue 0 of + GT -> + let changeTxOut = TxOut address $ mkTxOutValueAdaOnly changeValue + changeIndex = TxIx $ fromIntegral $ length payTxOuts -- 0-based index + in + (appendr payTxOuts (changeTxOut :| []), Just (changeIndex, changeValue)) + EQ -> + case payTxOuts of + [] -> error "change is zero and txouts is empty" + txout0: txoutsRest -> (txout0 :| txoutsRest, Nothing) + LT -> error "Bad transaction: insufficient funds" + + -- TxOuts of recipients are placed at the first positions + offsetMap = Map.fromList $ zipWith (\payment index -> (fst payment, TxIx index)) + payments + [0..] + txOutSum :: [ TxOut era ] -> Lovelace + txOutSum l = sum $ map toVal l + + toVal (TxOut _ val) = txOutValueToLovelace val + + -- | Append a non-empty list to a list. + -- > appendr [1,2,3] (4 :| [5]) == 1 :| [2,3,4,5] + appendr :: [a] -> NonEmpty a -> NonEmpty a + appendr l nel = foldr NonEmpty.cons nel l + +mkTxOutValueAdaOnly :: forall era . IsShelleyBasedEra era => Lovelace -> TxOutValue era +mkTxOutValueAdaOnly l = case shelleyBasedEra @ era of + ShelleyBasedEraShelley -> TxOutAdaOnly AdaOnlyInShelleyEra l + ShelleyBasedEraAllegra -> TxOutAdaOnly AdaOnlyInAllegraEra l + ShelleyBasedEraMary -> TxOutValue MultiAssetInMaryEra $ lovelaceToValue l + +txOutValueToLovelace :: TxOutValue era -> Lovelace +txOutValueToLovelace = \case + TxOutAdaOnly AdaOnlyInByronEra x -> x + TxOutAdaOnly AdaOnlyInShelleyEra x -> x + TxOutAdaOnly AdaOnlyInAllegraEra x -> x + TxOutValue _ v -> case valueToLovelace v of + Just c -> c + Nothing -> error "txOutValueLovelace TxOut contains no ADA" + +txInModeCardano :: forall era . IsShelleyBasedEra era => Tx era -> TxInMode CardanoMode +txInModeCardano tx = case shelleyBasedEra @ era of + ShelleyBasedEraShelley -> TxInMode tx ShelleyEraInCardanoMode + ShelleyBasedEraAllegra -> TxInMode tx AllegraEraInCardanoMode + ShelleyBasedEraMary -> TxInMode tx MaryEraInCardanoMode diff --git a/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/Tx/Byron.hs b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/Tx/Byron.hs new file mode 100644 index 00000000000..1b95e21146b --- /dev/null +++ b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/Tx/Byron.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# OPTIONS_GHC -Wno-all-missed-specialisations -Wextra #-} + +module Cardano.Benchmarking.GeneratorTx.Tx.Byron + ( normalByronTxToGenTx + , byronGenesisUTxOTxIn + ) +where + +import Cardano.Prelude hiding (option, trace, (%)) +import Prelude (error) + +import qualified Data.Map.Strict as Map +import qualified Data.Text as T +import Formatting (sformat, (%)) + +import Cardano.Chain.Common (Address) +import qualified Cardano.Chain.Common as Common +import Cardano.Chain.Genesis as Genesis +import qualified Cardano.Chain.UTxO as UTxO +import qualified Cardano.Crypto.Signing as Crypto + +import Ouroboros.Consensus.Byron.Ledger (ByronBlock, GenTx (..)) +import qualified Ouroboros.Consensus.Byron.Ledger as Byron + +-- | The 'GenTx' is all the kinds of transactions that can be submitted +-- and \"normal\" Byron transactions are just one of the kinds. +normalByronTxToGenTx :: UTxO.ATxAux ByteString -> GenTx ByronBlock +normalByronTxToGenTx tx' = Byron.ByronTx (Byron.byronIdTx tx') tx' + +-- | Given a genesis, and a pair of a genesis public key and address, +-- reconstruct a TxIn corresponding to the genesis UTxO entry. +byronGenesisUTxOTxIn :: Genesis.Config -> Crypto.VerificationKey -> Common.Address -> UTxO.TxIn +byronGenesisUTxOTxIn gc vk genAddr = + handleMissingAddr $ fst <$> Map.lookup genAddr initialUtxo + where + initialUtxo :: Map Common.Address (UTxO.TxIn, UTxO.TxOut) + initialUtxo = + Map.fromList + . mapMaybe (\(inp, out) -> mkEntry inp genAddr <$> keyMatchesUTxO vk out) + . map (bimap UTxO.fromCompactTxIn UTxO.fromCompactTxOut) + . Map.toList + . UTxO.unUTxO + . UTxO.genesisUtxo + $ gc + + mkEntry :: UTxO.TxIn + -> Address + -> UTxO.TxOut + -> (Address, (UTxO.TxIn, UTxO.TxOut)) + mkEntry inp addr out = (addr, (inp, out)) + + keyMatchesUTxO :: Crypto.VerificationKey -> UTxO.TxOut -> Maybe UTxO.TxOut + keyMatchesUTxO key out = + if Common.checkVerKeyAddress key (UTxO.txOutAddress out) + then Just out else Nothing + + handleMissingAddr :: Maybe UTxO.TxIn -> UTxO.TxIn + handleMissingAddr = fromMaybe . error + $ "\nGenesis UTxO has no address\n" + <> T.unpack (prettyAddress genAddr) + <> "\n\nIt has the following, though:\n\n" + <> Cardano.Prelude.concat (T.unpack . prettyAddress <$> Map.keys initialUtxo) + + prettyAddress :: Common.Address -> Text + prettyAddress addr = sformat + (Common.addressF %"\n"%Common.addressDetailedF) + addr addr diff --git a/bench/tx-generator/src/Cardano/Benchmarking/OuroborosImports.hs b/bench/tx-generator/src/Cardano/Benchmarking/OuroborosImports.hs new file mode 100644 index 00000000000..123b94f3003 --- /dev/null +++ b/bench/tx-generator/src/Cardano/Benchmarking/OuroborosImports.hs @@ -0,0 +1,84 @@ +{- HLINT ignore "Eta reduce" -} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} + +module Cardano.Benchmarking.OuroborosImports + ( + CardanoBlock + , LocalSubmitTx + , LoggingLayer + , PaymentKey + , ShelleyGenesis + , SigningKey + , SigningKeyFile + , StandardShelley + , NetworkId + , getGenesis + , makeLocalConnectInfo + , protocolToTopLevelConfig + , protocolToNetworkId + , protocolToCodecConfig + , submitTxToNodeLocal + ) where + +import Prelude + +import Ouroboros.Consensus.Block.Abstract +import qualified Ouroboros.Consensus.Cardano as Consensus +import Ouroboros.Consensus.Config (TopLevelConfig, configBlock, configCodec) +import Ouroboros.Consensus.Config.SupportsNode + (ConfigSupportsNode(..), getNetworkMagic) +import Ouroboros.Consensus.Node (ProtocolInfo(..)) +import Ouroboros.Consensus.Shelley.Protocol (StandardCrypto) +import Ouroboros.Consensus.Shelley.Eras (StandardShelley) +import Ouroboros.Network.Protocol.LocalTxSubmission.Type (SubmitResult (..)) + +import Cardano.Node.Configuration.Logging (LoggingLayer) +import Cardano.Node.Protocol.Types ( SomeConsensusProtocol(..)) + +import Cardano.Api.Shelley (CardanoMode) +import Cardano.CLI.Types (SigningKeyFile) + +import Cardano.Api (NetworkId(..), LocalNodeConnectInfo(..), ConsensusModeParams(..), EpochSlots(..) + , TxInMode, TxValidationErrorInMode + , SigningKey, PaymentKey + , submitTxToNodeLocal) +import Cardano.Api.Protocol.Types (BlockType(..), ProtocolInfoArgs(..), protocolInfo) + +import Shelley.Spec.Ledger.Genesis (ShelleyGenesis) + +type CardanoBlock = Consensus.CardanoBlock StandardCrypto + +toProtocolInfo :: SomeConsensusProtocol -> ProtocolInfo IO CardanoBlock +toProtocolInfo (SomeConsensusProtocol CardanoBlockType info) = protocolInfo info +toProtocolInfo _ = error "toProtocolInfo unkown protocol" + +getGenesis :: SomeConsensusProtocol -> ShelleyGenesis StandardShelley +getGenesis (SomeConsensusProtocol CardanoBlockType info) = shelleyBasedGenesis + where + (ProtocolInfoArgsCardano + _ + Consensus.ProtocolParamsShelleyBased{Consensus.shelleyBasedGenesis} + _ _ _ _ _ _ ) = info +getGenesis (SomeConsensusProtocol _ _ ) = error "getGenesis (SomeConsensusProtocol _ _ ) unknown protocol" + +protocolToTopLevelConfig :: SomeConsensusProtocol -> TopLevelConfig CardanoBlock +protocolToTopLevelConfig ptcl = pInfoConfig + where + ProtocolInfo {pInfoConfig} = toProtocolInfo ptcl + +protocolToCodecConfig :: SomeConsensusProtocol -> CodecConfig CardanoBlock +protocolToCodecConfig = configCodec . protocolToTopLevelConfig + +protocolToNetworkId :: SomeConsensusProtocol -> NetworkId +protocolToNetworkId ptcl + = Testnet $ getNetworkMagic $ configBlock $ protocolToTopLevelConfig ptcl + +makeLocalConnectInfo :: NetworkId -> FilePath -> LocalNodeConnectInfo CardanoMode +makeLocalConnectInfo networkId sock + = LocalNodeConnectInfo + (CardanoModeParams (EpochSlots 21600)) + networkId + sock + +type LocalSubmitTx = (TxInMode CardanoMode -> IO (SubmitResult (TxValidationErrorInMode CardanoMode))) diff --git a/bench/tx-generator/src/Cardano/Benchmarking/Script.hs b/bench/tx-generator/src/Cardano/Benchmarking/Script.hs new file mode 100644 index 00000000000..5e39c65ddad --- /dev/null +++ b/bench/tx-generator/src/Cardano/Benchmarking/Script.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NumericUnderscores #-} +module Cardano.Benchmarking.Script + ( Script + , runScript + , parseScriptFile + ) +where + +import Prelude + +import Control.Concurrent (threadDelay) +import Control.Monad +import Control.Monad.IO.Class + +import Ouroboros.Network.NodeToClient (IOManager) +import Cardano.Node.Configuration.Logging (shutdownLoggingLayer) + +import Cardano.Benchmarking.Script.Action +import Cardano.Benchmarking.Script.Aeson (parseScriptFile) +import Cardano.Benchmarking.Script.Env +import Cardano.Benchmarking.Script.Store + +type Script = [Action] + +runScript :: Script -> IOManager -> IO (Either Error ()) +runScript script iom = runActionM (forM_ script action) iom >>= \case + (Right a , s , ()) -> do + cleanup s shutDownLogging + threadDelay 10_000_000 + return $ Right a + (Left err , s , ()) -> do + cleanup s (traceError (show err) >> shutDownLogging) + threadDelay 10_000_000 + return $ Left err + where + cleanup s a = void $ runActionMEnv s a iom + +shutDownLogging :: ActionM () +shutDownLogging = do + ll <- get LoggingLayer + traceError "QRT Last Message. LoggingLayer going to shutdown. 73 . . . ." + liftIO $ do + threadDelay (200*1000) + shutdownLoggingLayer ll diff --git a/bench/tx-generator/src/Cardano/Benchmarking/Script/Action.hs b/bench/tx-generator/src/Cardano/Benchmarking/Script/Action.hs new file mode 100644 index 00000000000..bb64dcce250 --- /dev/null +++ b/bench/tx-generator/src/Cardano/Benchmarking/Script/Action.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} + +module Cardano.Benchmarking.Script.Action +where + +import Prelude +import GHC.Generics +import Data.Functor.Identity +import Data.Dependent.Sum (DSum(..)) + +import Cardano.Benchmarking.OuroborosImports (SigningKeyFile) +import Cardano.Api (AnyCardanoEra) + +import Cardano.Benchmarking.Script.Env +import Cardano.Benchmarking.Script.Store +import Cardano.Benchmarking.Script.Core +import Cardano.Benchmarking.Types (TPSRate) + +data Action where + Set :: !SetKeyVal -> Action +-- Declare :: SetKeyVal -> Action --declare (once): error if key was set before + StartProtocol :: !FilePath -> Action + Delay :: !Double -> Action + ReadSigningKey :: !KeyName -> !SigningKeyFile -> Action + SecureGenesisFund :: !FundName -> !KeyName -> !KeyName -> Action + SplitFund :: [FundName] -> !KeyName -> !FundName -> Action + SplitFundToList :: !FundListName -> !KeyName -> !FundName -> Action + PrepareTxList :: !TxListName -> !KeyName -> !FundListName -> Action + AsyncBenchmark :: !ThreadName -> !TxListName -> TPSRate -> Action + WaitBenchmark :: !ThreadName -> Action + CancelBenchmark :: !ThreadName -> Action + Reserved :: [String] -> Action + WaitForEra :: !AnyCardanoEra -> Action + deriving (Show, Eq) + +deriving instance Generic Action + +action :: Action -> ActionM () +action a = case a of + Set (key :=> (Identity val)) -> set (User key) val + StartProtocol filePath -> startProtocol filePath + ReadSigningKey name filePath -> readSigningKey name filePath + SecureGenesisFund fundName fundKey genesisKey -> secureGenesisFund fundName fundKey genesisKey + SplitFund newFunds newKey sourceFund -> splitFund newFunds newKey sourceFund + SplitFundToList fundList destKey sourceFund -> splitFundToList fundList destKey sourceFund + Delay t -> delay t + PrepareTxList name key fund -> prepareTxList name key fund + AsyncBenchmark thread txs tps -> asyncBenchmark thread txs tps + WaitBenchmark thread -> waitBenchmark thread + CancelBenchmark thread -> cancelBenchmark thread + WaitForEra era -> waitForEra era + Reserved options -> reserved options diff --git a/bench/tx-generator/src/Cardano/Benchmarking/Script/Aeson.hs b/bench/tx-generator/src/Cardano/Benchmarking/Script/Aeson.hs new file mode 100644 index 00000000000..467e3be9826 --- /dev/null +++ b/bench/tx-generator/src/Cardano/Benchmarking/Script/Aeson.hs @@ -0,0 +1,196 @@ +{-# OPTIONS_GHC -Wno-orphans #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} +module Cardano.Benchmarking.Script.Aeson +where + +import Prelude +import System.Exit +import Data.Functor.Identity +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Dependent.Sum +import qualified Data.HashMap.Strict as HashMap (toList, lookup) +import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS (lines) +import Data.Aeson +import Data.Aeson.Types +import Data.Aeson.Encode.Pretty +import qualified Data.Attoparsec.ByteString as Atto + +import Cardano.Api (AnyCardanoEra(..), CardanoEra(..)) +import Cardano.CLI.Types (SigningKeyFile(..)) + +import Cardano.Benchmarking.Script.Action +import Cardano.Benchmarking.Script.Env +import Cardano.Benchmarking.Script.Setters +import Cardano.Benchmarking.Script.Store +import Cardano.Benchmarking.Types (TPSRate(..)) + +testJSONRoundTrip :: [Action] -> Maybe String +testJSONRoundTrip l = case fromJSON $ toJSON l of + Success r -> if l == r then Nothing else Just "compare: not equal" + Error err -> Just err + +prettyPrint :: [Action] -> BSL.ByteString +prettyPrint = encodePretty' conf + where + conf = defConfig {confCompare = keyOrder actionNames } + actionNames :: [Text] + actionNames = + [ "startProtocol", "readSigningKey", "secureGenesisFund", "splitFund" + , "splitFundToList", "delay", "prepareTxList" + , "runBenchmark", "asyncBenchmark", "waitBenchmark", "cancelBenchmark" + , "reserved" ] + +instance FromJSON AnyCardanoEra where + parseJSON = withText "AnyCardanoEra" $ \case + "Byron" -> return $ AnyCardanoEra ByronEra + "Shelley" -> return $ AnyCardanoEra ShelleyEra + "Allegra" -> return $ AnyCardanoEra AllegraEra + "Mary" -> return $ AnyCardanoEra MaryEra + era -> parseFail ("Error: Cannot parse JSON value '" <> Text.unpack era <> "' to AnyCardanoEra.") + +instance ToJSON (DSum Tag Identity) where + toEncoding = error "DSum Tag Identity" + toJSON = error "DSum Tag Identity" + +instance FromJSON (DSum Tag Identity) where + parseJSON = error "fromJSON" + +instance ToJSON Sum where + toEncoding = genericToEncoding defaultOptions +instance FromJSON Sum + +actionToJSON :: Action -> Value +actionToJSON a = case a of + Set keyVal -> keyValToJSONCompact keyVal -- Remove the inner/ nested Object and add "set" -prefix. + StartProtocol filePath -> singleton "startProtocol" filePath + ReadSigningKey (KeyName name) (SigningKeyFile filePath) + -> object ["readSigningKey" .= name, "filePath" .= filePath] + SecureGenesisFund (FundName fundName) (KeyName fundKey) (KeyName genesisKey) + -> object ["secureGenesisFund" .= fundName, "fundKey" .= fundKey, "genesisKey" .= genesisKey ] + SplitFund newFunds (KeyName newKey) (FundName sourceFund) + -> object ["splitFund" .= names, "newKey" .= newKey, "sourceFund" .= sourceFund] + where names = [n | FundName n <- newFunds] + SplitFundToList (FundListName fundList) (KeyName destKey) (FundName sourceFund) + -> object ["splitFundToList" .= fundList, "newKey" .= destKey, "sourceFund" .= sourceFund ] + Delay t -> object ["delay" .= t ] + PrepareTxList (TxListName name) (KeyName key) (FundListName fund) + -> object ["prepareTxList" .= name, "newKey" .= key, "fundList" .= fund ] + AsyncBenchmark (ThreadName t) (TxListName txs) (TPSRate tps) + -> object ["asyncBenchmark" .= t, "txList" .= txs, "tps" .= tps] + WaitBenchmark (ThreadName t) -> singleton "waitBenchmark" t + CancelBenchmark (ThreadName t) -> singleton "cancelBenchmark" t + WaitForEra era -> singleton "waitForEra" era + Reserved l -> singleton "reserved" l + where + singleton k v = object [ k .= v ] + +keyValToJSONCompact :: SetKeyVal -> Value +keyValToJSONCompact keyVal = case parseEither (withObject "internal Error" parseSum) v of + Right c -> c + Left err -> error err + where + v = toJSON $ runIdentity $ taggedToSum keyVal + parseSum obj = do + key <- obj .: "tag" + (val :: Value) <- obj .: "contents" + return $ object [("set" <> Text.tail key) .= val] + +instance ToJSON Action where toJSON = actionToJSON +instance FromJSON Action where parseJSON = jsonToAction + +jsonToAction :: Value -> Parser Action +jsonToAction = withObject "Error: Action is not a JSON object." objectToAction + +objectToAction :: Object -> Parser Action +objectToAction obj = case obj of + (HashMap.lookup "startProtocol" -> Just v) + -> (withText "Error parsing startProtocol" $ \t -> return $ StartProtocol $ Text.unpack t) v + (HashMap.lookup "readSigningKey" -> Just v) -> parseReadSigningKey v + (HashMap.lookup "secureGenesisFund" -> Just v) -> parseSecureGenesisFund v + (HashMap.lookup "splitFund" -> Just v) -> parseSplitFund v + (HashMap.lookup "splitFundToList" -> Just v) -> parseSplitFundToList v + (HashMap.lookup "delay" -> Just v) -> Delay <$> parseJSON v + (HashMap.lookup "prepareTxList" -> Just v) -> parsePrepareTxList v + (HashMap.lookup "asyncBenchmark" -> Just v) -> parseAsyncBenchmark v + (HashMap.lookup "waitBenchmark" -> Just v) -> WaitBenchmark <$> parseThreadName v + (HashMap.lookup "cancelBenchmark" -> Just v) -> CancelBenchmark <$> parseThreadName v + (HashMap.lookup "waitForEra" -> Just v) -> WaitForEra <$> parseJSON v + (HashMap.lookup "reserved" -> Just v) -> Reserved <$> parseJSON v + (HashMap.toList -> [(k, v)] ) -> parseSetter k v + _ -> parseFail "Error: cannot parse action Object." + where + parseSetter k v = case k of + (Text.stripPrefix "set" -> Just tag) -> do + s <- parseJSON $ object [ "tag" .= ("S" <> tag), "contents" .= v] + return $ Set $ sumToTaggged s + _ -> parseFail $ "Error: cannot parse action Object with key " <> Text.unpack k + + parseKey f = KeyName <$> parseField obj f + parseFund f = FundName <$> parseField obj f + parseThreadName + = withText "Error parsing ThreadName" $ \t -> return $ ThreadName $ Text.unpack t + + parseReadSigningKey v = ReadSigningKey + <$> ( KeyName <$> parseJSON v ) + <*> ( SigningKeyFile <$> parseField obj "filePath" ) + + parseSecureGenesisFund v = SecureGenesisFund + <$> ( FundName <$> parseJSON v ) + <*> parseKey "fundKey" + <*> parseKey "genesisKey" + + parseSplitFund v = do + l <- parseJSON v + k <- parseKey "newKey" + f <- parseFund "sourceFund" + return $ SplitFund (map FundName l) k f + + parseSplitFundToList v = SplitFundToList + <$> ( FundListName <$> parseJSON v ) + <*> parseKey "newKey" + <*> parseFund "sourceFund" + + parsePrepareTxList v = PrepareTxList + <$> ( TxListName <$> parseJSON v ) + <*> parseKey "newKey" + <*> ( FundListName <$>parseField obj "fundList" ) + + parseAsyncBenchmark v = AsyncBenchmark + <$> ( ThreadName <$> parseJSON v ) + <*> ( TxListName <$> parseField obj "txList" ) + <*> ( TPSRate <$> parseField obj "tps" ) + +parseScriptFile :: FilePath -> IO [Action] +parseScriptFile filePath = do + input <- BS.readFile filePath + case Atto.parse Data.Aeson.json input of + Atto.Fail rest _context msg -> die errorMsg + where + consumed = BS.take (BS.length input - BS.length rest) input + lineNumber = length $ BS.lines consumed + errorMsg = concat [ + "error while parsing json value :\n" + , "file :" , filePath , "\n" + , "line number ", show lineNumber ,"\n" + , "message : ", msg, "\n" + ] + Atto.Partial _ -> die $ concat [ + "error while parsing json value :\n" + , "file :" , filePath , "\n" + , "truncated input file\n" + ] +-- Atto.Done extra _ | (not $ BS.null extra) -> die $ concat [ +-- "error while parsing json value :\n" +-- , "file :" , filePath , "\n" +-- , "leftover data" +-- ] + Atto.Done _ value -> case fromJSON value of + Error err -> die err + Success script -> return script diff --git a/bench/tx-generator/src/Cardano/Benchmarking/Script/Core.hs b/bench/tx-generator/src/Cardano/Benchmarking/Script/Core.hs new file mode 100644 index 00000000000..307e9be9d44 --- /dev/null +++ b/bench/tx-generator/src/Cardano/Benchmarking/Script/Core.hs @@ -0,0 +1,307 @@ +{- HLINT ignore "Reduce duplication" -} +{- HLINT ignore "Use uncurry" -} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes #-} -- +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Cardano.Benchmarking.Script.Core +where + +import Prelude +import Control.Monad +import Control.Monad.Trans.Except +import Control.Monad.IO.Class +import Control.Concurrent (threadDelay) +import Control.Tracer (traceWith) + +import Ouroboros.Network.Protocol.LocalTxSubmission.Type (SubmitResult (..)) +import Cardano.Api ( AsType(..), CardanoEra(..), InAnyCardanoEra(..), AnyCardanoEra(..), IsShelleyBasedEra, Tx + , Lovelace, NetworkId(..), cardanoEra + , CardanoMode, LocalNodeConnectInfo + , PaymentKey + , SigningKey + , TxInMode + , TxValidationErrorInMode + , getLocalChainTip, queryNodeLocalState, QueryInMode( QueryCurrentEra), ConsensusModeIsMultiEra( CardanoModeIsMultiEra ) + , chainTipToChainPoint ) + +import qualified Cardano.Benchmarking.FundSet as FundSet +import Cardano.Benchmarking.FundSet (FundInEra(..), Validity(..), liftAnyEra ) +import Cardano.Benchmarking.GeneratorTx as Core + (AsyncBenchmarkControl, asyncBenchmark, waitBenchmark, readSigningKey, secureGenesisFund, splitFunds, txGenerator, TxGenError) + +import Cardano.Benchmarking.GeneratorTx.Tx as Core (keyAddress, txInModeCardano) +import Cardano.Benchmarking.GeneratorTx.LocalProtocolDefinition as Core (startProtocol) +import Cardano.Benchmarking.GeneratorTx.NodeToNode (ConnectClient, benchmarkConnectTxSubmit) +import Cardano.Benchmarking.OuroborosImports as Core + (LocalSubmitTx, SigningKeyFile + , getGenesis, protocolToNetworkId, protocolToCodecConfig, makeLocalConnectInfo, submitTxToNodeLocal) +import Cardano.Benchmarking.Tracer as Core + ( TraceBenchTxSubmit (..) + , createTracers, btTxSubmit_, btN2N_, btConnect_, btSubmission_) +import Cardano.Benchmarking.Types as Core (NumberOfTxs(..), SubmissionErrorPolicy(..), TPSRate) +import Cardano.Benchmarking.Wallet + +import Cardano.Benchmarking.Script.Env +import Cardano.Benchmarking.Script.Setters +import Cardano.Benchmarking.Script.Store as Store + +liftCoreWithEra :: (forall era. IsShelleyBasedEra era => AsType era -> ExceptT TxGenError IO x) -> ActionM (Either TxGenError x) +liftCoreWithEra coreCall = withEra ( liftIO . runExceptT . coreCall) + +withEra :: (forall era. IsShelleyBasedEra era => AsType era -> ActionM x) -> ActionM x +withEra action = do + era <- get $ User TEra + case era of + AnyCardanoEra MaryEra -> action AsMaryEra + AnyCardanoEra AllegraEra -> action AsAllegraEra + AnyCardanoEra ShelleyEra -> action AsShelleyEra + AnyCardanoEra ByronEra -> error "byron not supported" + +startProtocol :: FilePath -> ActionM () +startProtocol filePath = do + liftIO (runExceptT $ Core.startProtocol filePath) >>= \case + Left err -> throwE $ CliError err + Right (loggingLayer, protocol) -> do + set LoggingLayer loggingLayer + set Protocol protocol + set BenchTracers $ Core.createTracers loggingLayer + set Genesis $ Core.getGenesis protocol + set NetworkId $ protocolToNetworkId protocol + +readSigningKey :: KeyName -> SigningKeyFile -> ActionM () +readSigningKey name filePath = + liftIO ( runExceptT $ Core.readSigningKey filePath) >>= \case + Left err -> liftTxGenError err + Right key -> setName name key + +getLocalSubmitTx :: ActionM LocalSubmitTx +getLocalSubmitTx = submitTxToNodeLocal <$> getLocalConnectInfo + +secureGenesisFund + :: FundName + -> KeyName + -> KeyName + -> ActionM () +secureGenesisFund fundName destKey genesisKeyName = do + tracer <- btTxSubmit_ <$> get BenchTracers + localSubmit <- getLocalSubmitTx + networkId <- get NetworkId + genesis <- get Genesis + fee <- getUser TFee + ttl <- getUser TTTL + fundKey <- getName destKey + genesisKey <- getName genesisKeyName + let + coreCall :: forall era. IsShelleyBasedEra era => AsType era -> ExceptT TxGenError IO Store.Fund + coreCall _proxy = do + let addr = Core.keyAddress @ era networkId fundKey + f <- Core.secureGenesisFund tracer localSubmit networkId genesis fee ttl genesisKey addr + return (f, fundKey) + liftCoreWithEra coreCall >>= \case + Left err -> liftTxGenError err + Right fund -> do + -- Todo : user only of two methods + setName fundName fund -- Old method + initGlobalWallet networkId fundKey fund -- New method + +initGlobalWallet :: NetworkId -> SigningKey PaymentKey -> Fund -> ActionM () +initGlobalWallet networkId key ((txIn, outVal), skey) = do + wallet <- liftIO $ initWallet networkId key + liftIO (walletRefInsertFund wallet (FundSet.Fund $ mkFund outVal)) + set GlobalWallet wallet + where + mkFund = liftAnyEra $ \value -> FundInEra { + _fundTxIn = txIn + , _fundVal = value + , _fundSigningKey = skey + , _fundValidity = Confirmed + } + +splitFundN + :: NumberOfTxs + -> KeyName + -> FundName + -> ActionM [Store.Fund] +splitFundN count destKeyName sourceFund = do + tracer <- btTxSubmit_ <$> get BenchTracers + localSubmit <- getLocalSubmitTx + networkId <- get NetworkId + fee <- getUser TFee + destKey <- getName destKeyName + (fund, fundKey) <- consumeName sourceFund + txIn <- getUser TNumberOfInputsPerTx + let + coreCall :: forall era. IsShelleyBasedEra era => AsType era -> ExceptT TxGenError IO [Store.Fund] + coreCall _proxy = do + let addr = Core.keyAddress @ era networkId fundKey + f <- Core.splitFunds tracer localSubmit fee count txIn fundKey addr fund + return $ zip f $ repeat destKey + liftCoreWithEra coreCall >>= \case + Left err -> liftTxGenError err + Right funds -> return funds + +splitFund + :: [FundName] + -> KeyName + -> FundName + -> ActionM () +splitFund newFunds destKey sourceFund = do + funds <- splitFundN (NumberOfTxs $ fromIntegral $ length newFunds) destKey sourceFund + forM_ (zip newFunds funds) $ \(name, f) -> setName name f + +splitFundToList + :: FundListName + -> KeyName + -> FundName + -> ActionM () +splitFundToList newFunds destKey sourceFund = do + count <- getUser TNumberOfTxs + funds <- splitFundN count destKey sourceFund + setName newFunds funds + +delay :: Double -> ActionM () +delay t = liftIO $ threadDelay $ floor $ 1000000 * t + +prepareTxList + :: TxListName + -> KeyName + -> FundListName + -> ActionM () +prepareTxList name destKey srcFundName = do + tracer <- btTxSubmit_ <$> get BenchTracers + networkId <- get NetworkId + fee <- getUser TFee + fundList <- consumeName srcFundName + key <- getName destKey + txIn <- getUser TNumberOfInputsPerTx + txOut <- getUser TNumberOfOutputsPerTx + count <- getUser TNumberOfTxs + payload <- getUser TTxAdditionalSize + let + coreCall :: forall era. IsShelleyBasedEra era => AsType era -> ExceptT TxGenError IO (InAnyCardanoEra TxList) + coreCall _proxy = do + let addr = Core.keyAddress @ era networkId key + ----------------------------------------------------TODO : Constant 1 ??? + l <- Core.txGenerator tracer fee count txIn txOut payload addr (snd $ head fundList) 1 (map fst fundList) + return $ InAnyCardanoEra cardanoEra $ TxList l + liftCoreWithEra coreCall >>= \case + Left err -> liftTxGenError err + Right l -> setName name l + +waitBenchmarkCore :: AsyncBenchmarkControl -> ActionM () +waitBenchmarkCore ctl = do + tracers <- get BenchTracers + _ <- liftIO $ runExceptT $ Core.waitBenchmark (btTxSubmit_ tracers) ctl + return () + +asyncBenchmarkCore :: ThreadName -> TxListName -> TPSRate -> ActionM AsyncBenchmarkControl +asyncBenchmarkCore (ThreadName threadName) transactions tps = do + tracers <- get BenchTracers + targets <- getUser TTargets + txs <- getName transactions + (Testnet networkMagic) <- get NetworkId + protocol <- get Protocol + ioManager <- askIOManager + let + connectClient :: ConnectClient + connectClient = benchmarkConnectTxSubmit + ioManager + (btConnect_ tracers) + (btSubmission_ tracers) + (protocolToCodecConfig protocol) + networkMagic + + coreCall :: forall era. IsShelleyBasedEra era => [Tx era] -> ExceptT TxGenError IO AsyncBenchmarkControl + coreCall l = Core.asyncBenchmark (btTxSubmit_ tracers) (btN2N_ tracers) connectClient threadName targets tps LogErrors l + ret <- liftIO $ runExceptT $ case txs of + InAnyCardanoEra MaryEra (TxList l) -> coreCall l + InAnyCardanoEra AllegraEra (TxList l) -> coreCall l + InAnyCardanoEra ShelleyEra (TxList l) -> coreCall l + InAnyCardanoEra ByronEra _ -> error "byron not supported" + case ret of + Left err -> liftTxGenError err + Right ctl -> return ctl + +asyncBenchmark :: ThreadName -> TxListName -> TPSRate -> ActionM () +asyncBenchmark controlName txList tps = asyncBenchmarkCore controlName txList tps >>= setName controlName + +waitBenchmark :: ThreadName -> ActionM () +waitBenchmark n = getName n >>= waitBenchmarkCore + +cancelBenchmark :: ThreadName -> ActionM () +cancelBenchmark n = do + ctl@(_, _ , _ , shutdownAction) <- getName n + liftIO shutdownAction + waitBenchmarkCore ctl + +getLocalConnectInfo :: ActionM (LocalNodeConnectInfo CardanoMode) +getLocalConnectInfo = makeLocalConnectInfo <$> get NetworkId <*> getUser TLocalSocket + +queryEra :: ActionM AnyCardanoEra +queryEra = do + localNodeConnectInfo <- getLocalConnectInfo + chainTip <- liftIO $ getLocalChainTip localNodeConnectInfo + ret <- liftIO $ queryNodeLocalState localNodeConnectInfo (Just $ chainTipToChainPoint chainTip) $ QueryCurrentEra CardanoModeIsMultiEra + case ret of + Right era -> return era + Left err -> throwE $ ApiError $ show err + +waitForEra :: AnyCardanoEra -> ActionM () +waitForEra era = do + currentEra <- queryEra + if currentEra == era + then return () + else do + traceError $ "Current era: " ++ show currentEra ++ " Waiting for: " ++ show era + liftIO $ threadDelay 1_000_000 + waitForEra era +{- +This is for dirty hacking and testing and quick-fixes. +Its a function that can be called from the JSON scripts +and for which the JSON encoding is "reserved". +-} +reserved :: [String] -> ActionM () +reserved _ = do + localCreateCoins +-- throwE $ UserError "no dirty hack is implemented" + +localCreateCoins :: ActionM () +localCreateCoins = do + wallet <- get GlobalWallet + let + -- todo: fix hardcoded number of initial coins + outputs :: [[Lovelace]] + outputs = replicate 100 $ map fromInteger [20..50] + + createCoins :: forall era. IsShelleyBasedEra era => [Lovelace] -> AsType era -> ActionM (Either String (TxInMode CardanoMode)) + createCoins coins _proxy = do + (tx :: Either String (Tx era)) <- liftIO $ walletRefCreateCoins wallet coins + return $ fmap txInModeCardano tx + forM_ outputs $ \coins -> do + gen <- withEra $ createCoins coins + case gen of + Left (_err :: String) -> return () + Right tx -> void $ localSubmitTx tx + +localSubmitTx :: TxInMode CardanoMode -> ActionM (SubmitResult (TxValidationErrorInMode CardanoMode)) +localSubmitTx tx = do + submitTracer <- btTxSubmit_ <$> get BenchTracers + submit <- getLocalSubmitTx + ret <- liftIO $ submit tx + let + msg = case ret of + SubmitSuccess -> mconcat + [ "local submit success (" , show tx , ")"] + SubmitFail e -> mconcat + [ "local submit failed: " , show e , " (" , show tx , ")"] + liftIO $ traceWith submitTracer $ TraceBenchTxSubDebug msg + return ret diff --git a/bench/tx-generator/src/Cardano/Benchmarking/Script/Env.hs b/bench/tx-generator/src/Cardano/Benchmarking/Script/Env.hs new file mode 100644 index 00000000000..960bae7d9ef --- /dev/null +++ b/bench/tx-generator/src/Cardano/Benchmarking/Script/Env.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} + +module Cardano.Benchmarking.Script.Env +where + +import Prelude +import Data.Functor.Identity +import qualified Data.Text as Text +import Data.Dependent.Sum (DSum(..)) +import Data.Dependent.Map (DMap) +import qualified Data.Dependent.Map as DMap +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import Control.Monad.Trans.Except +import Control.Monad.Trans.RWS.Strict (RWST) +import qualified Control.Monad.Trans.RWS.Strict as RWS +import Control.Tracer (traceWith) + +import qualified Cardano.Benchmarking.Tracer as Tracer +import Ouroboros.Network.NodeToClient (IOManager) + +import Cardano.Benchmarking.GeneratorTx.Error (TxGenError) +import Cardano.Benchmarking.GeneratorTx.LocalProtocolDefinition (CliError) +import Cardano.Benchmarking.Script.Setters as Setters +import Cardano.Benchmarking.Script.Store + +type Env = DMap Store Identity + +emptyEnv :: Env +emptyEnv = DMap.empty + +type ActionM a = ExceptT Error (RWST IOManager () Env IO) a + +runActionM :: ActionM ret -> IOManager -> IO (Either Error ret, Env, ()) +runActionM = runActionMEnv emptyEnv + +runActionMEnv :: Env -> ActionM ret -> IOManager -> IO (Either Error ret, Env, ()) +runActionMEnv env action iom = RWS.runRWST (runExceptT action) iom env + +type SetKeyVal = DSum Setters.Tag Identity + +data Error where + LookupError :: !(Store v) -> Error + TxGenError :: !TxGenError -> Error + CliError :: !CliError -> Error + ApiError :: !String -> Error + UserError :: !String -> Error + +deriving instance Show Error + +liftTxGenError :: TxGenError -> ActionM a +liftTxGenError = throwE . TxGenError + +askIOManager :: ActionM IOManager +askIOManager = lift RWS.ask + +set :: Store v -> v -> ActionM () +set key val = lift $ RWS.modify $ DMap.insert key (pure val) + +unSet :: Store v -> ActionM () +unSet key = lift $ RWS.modify $ DMap.delete key + +setName :: Name v -> v -> ActionM () +setName = set . Named + +get :: Store v -> ActionM v +get key = do + lift (RWS.gets $ DMap.lookup key) >>= \case + Just (Identity v) -> return v + Nothing -> throwE $ LookupError key + +getName :: Name v -> ActionM v +getName = get . Named + +getUser :: Tag v -> ActionM v +getUser = get . User + +consumeName :: Name v -> ActionM v +consumeName n = do + v <- getName n + unSet $ Named n + return v + +traceError :: String -> ActionM () +traceError err = do + tracers <- get BenchTracers + liftIO $ traceWith (Tracer.btTxSubmit_ tracers) $ Tracer.TraceBenchTxSubError $ Text.pack $ show err diff --git a/bench/tx-generator/src/Cardano/Benchmarking/Script/Example.hs b/bench/tx-generator/src/Cardano/Benchmarking/Script/Example.hs new file mode 100644 index 00000000000..f9ffc3d27f2 --- /dev/null +++ b/bench/tx-generator/src/Cardano/Benchmarking/Script/Example.hs @@ -0,0 +1,70 @@ +module Cardano.Benchmarking.Script.Example +where + +import Prelude +import Control.Monad +import qualified Data.ByteString.Lazy.Char8 as BSL +import qualified Data.List.NonEmpty as NonEmpty +import Data.Word +import Data.Dependent.Sum ((==>) ) + +import Cardano.Api (AnyCardanoEra(..), CardanoEra(..), Quantity(..), SlotNo(..), quantityToLovelace ) +import Cardano.Node.Types +import Ouroboros.Network.NodeToClient (withIOManager) + +import Cardano.Benchmarking.Types +import Cardano.Benchmarking.Script.Action +import Cardano.Benchmarking.Script.Aeson +import Cardano.Benchmarking.Script.Env +import Cardano.Benchmarking.Script.Store +import Cardano.Benchmarking.Script.Setters + +runTestScript :: IO (Either Error (), Env, ()) +runTestScript = withIOManager $ runActionM (forM_ testScript action) + +printJSON :: IO () +printJSON = BSL.putStrLn $ prettyPrint testScript + +txConfig :: [Action] +txConfig = map Set [ + TNumberOfInputsPerTx ==> NumberOfInputsPerTx 1 + , TNumberOfOutputsPerTx ==> NumberOfOutputsPerTx 1 + , TNumberOfTxs ==> NumberOfTxs 500 + , TTxAdditionalSize ==> TxAdditionalSize 0 + , TFee ==> quantityToLovelace (Quantity 0) + , TTTL ==> SlotNo 1000000 + ] + +testScript :: [Action] +testScript = + txConfig + ++ + [ + StartProtocol "configuration/configuration-generator.yaml" + , Set $ TEra ==> AnyCardanoEra MaryEra + , Set $ TLocalSocket ==> "logs/sockets/1" + , ReadSigningKey passPartout "configuration/genesis-shelley/utxo-keys/utxo1.skey" + , SecureGenesisFund genFund passPartout passPartout + , Delay 10 + , SplitFund outputFunds passPartout genFund + , Delay 10 + , SplitFundToList fundList passPartout f1 + , PrepareTxList txList passPartout fundList + , Set $ TTargets ==> makeTargets [ 3000, 3001, 3002] + , AsyncBenchmark threadName txList (TPSRate 10) + , WaitForEra $ AnyCardanoEra ByronEra + , CancelBenchmark threadName + , Reserved [] + ] + where + passPartout = KeyName "pass-partout" + genFund = FundName "genFund" + outputFunds = map FundName ["fund1", "fund2", "fund3", "fund4"] + f1= head outputFunds + fundList = FundListName "fundList" + txList = TxListName "txlist" + threadName = ThreadName "thread1" + makeTargets = NonEmpty.fromList . map (\p -> makeAddr ("127.0.0.1", p)) + + makeAddr :: (String, Word16) -> NodeIPv4Address + makeAddr (a,b) = NodeAddress (NodeHostIPv4Address $ read a) (fromIntegral b) diff --git a/bench/tx-generator/src/Cardano/Benchmarking/Script/Setters.hs b/bench/tx-generator/src/Cardano/Benchmarking/Script/Setters.hs new file mode 100644 index 00000000000..499bd5f8414 --- /dev/null +++ b/bench/tx-generator/src/Cardano/Benchmarking/Script/Setters.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE StandaloneDeriving #-} + +module Cardano.Benchmarking.Script.Setters +where + +import Prelude +import GHC.Generics +import Data.Constraint.Extras.TH (deriveArgDict) +import Data.Dependent.Sum (DSum(..) , (==>) ) +import Data.GADT.Compare.TH (deriveGCompare, deriveGEq) +import Data.GADT.Show.TH (deriveGShow) +import Data.List.NonEmpty + +import Cardano.Api (Lovelace, SlotNo, AnyCardanoEra(..)) + +import Cardano.Benchmarking.Types + +-- Some boiler plate; ToDo may generate this. +data Tag v where + TNumberOfInputsPerTx :: Tag NumberOfInputsPerTx + TNumberOfOutputsPerTx :: Tag NumberOfOutputsPerTx + TNumberOfTxs :: Tag NumberOfTxs + TFee :: Tag Lovelace + TTTL :: Tag SlotNo + TTxAdditionalSize :: Tag TxAdditionalSize + TLocalSocket :: Tag String + TEra :: Tag AnyCardanoEra + TTargets :: Tag (NonEmpty NodeIPv4Address) + +deriveGEq ''Tag +deriveGCompare ''Tag +deriveGShow ''Tag +deriveArgDict ''Tag + +deriving instance Show (Tag v) +deriving instance Eq (Tag v) + +data Sum where + SNumberOfInputsPerTx :: !NumberOfInputsPerTx -> Sum + SNumberOfOutputsPerTx :: !NumberOfOutputsPerTx -> Sum + SNumberOfTxs :: !NumberOfTxs -> Sum + SFee :: !Lovelace -> Sum + STTL :: !SlotNo -> Sum + STxAdditionalSize :: !TxAdditionalSize -> Sum + SLocalSocket :: !String -> Sum + SEra :: !AnyCardanoEra -> Sum + STargets :: !(NonEmpty NodeIPv4Address) -> Sum + deriving (Eq, Show, Generic) + +taggedToSum :: Applicative f => DSum Tag f -> f Sum +taggedToSum x = case x of + (TNumberOfInputsPerTx :=> v) -> SNumberOfInputsPerTx <$> v + (TNumberOfOutputsPerTx :=> v) -> SNumberOfOutputsPerTx <$> v + (TNumberOfTxs :=> v) -> SNumberOfTxs <$> v + (TFee :=> v) -> SFee <$> v + (TTTL :=> v) -> STTL <$> v + (TTxAdditionalSize :=> v) -> STxAdditionalSize <$> v + (TLocalSocket :=> v) -> SLocalSocket <$> v + (TEra :=> v) -> SEra <$> v + (TTargets :=> v) -> STargets <$> v + +sumToTaggged :: Applicative f => Sum -> DSum Tag f +sumToTaggged x = case x of + SNumberOfInputsPerTx v -> TNumberOfInputsPerTx ==> v + SNumberOfOutputsPerTx v -> TNumberOfOutputsPerTx ==> v + SNumberOfTxs v -> TNumberOfTxs ==> v + SFee v -> TFee ==> v + STTL v -> TTTL ==> v + STxAdditionalSize v -> TTxAdditionalSize ==> v + SLocalSocket v -> TLocalSocket ==> v + SEra v -> TEra ==> v + STargets v -> TTargets ==> v diff --git a/bench/tx-generator/src/Cardano/Benchmarking/Script/Store.hs b/bench/tx-generator/src/Cardano/Benchmarking/Script/Store.hs new file mode 100644 index 00000000000..8cd6697a9b4 --- /dev/null +++ b/bench/tx-generator/src/Cardano/Benchmarking/Script/Store.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} + +module Cardano.Benchmarking.Script.Store +where + +import Prelude + +import Data.Constraint.Extras.TH (deriveArgDict) +import Data.GADT.Compare.TH (deriveGCompare, deriveGEq) +import Data.GADT.Show.TH (deriveGShow) + +import Cardano.Api as Cardano (InAnyCardanoEra(..), Tx) +import Cardano.Node.Protocol.Types (SomeConsensusProtocol) + +import Cardano.Benchmarking.Script.Setters as Setters +import Cardano.Benchmarking.OuroborosImports as Cardano + ( LoggingLayer, ShelleyGenesis, StandardShelley + , NetworkId, SigningKey, PaymentKey) + +import Cardano.Benchmarking.GeneratorTx as Core (AsyncBenchmarkControl) +import qualified Cardano.Benchmarking.GeneratorTx.Tx as Core (Fund) +import Cardano.Benchmarking.Tracer as Core (BenchTracers) +import Cardano.Benchmarking.Wallet as Wallet + +type Fund = (Core.Fund, SigningKey PaymentKey) + +data Store v where + User :: Setters.Tag x -> Store x + GlobalWallet :: Store WalletRef + LoggingLayer :: Store LoggingLayer + Protocol :: Store SomeConsensusProtocol + BenchTracers :: Store Core.BenchTracers + NetworkId :: Store Cardano.NetworkId -- could be in Setters (just need JSON instance) + Genesis :: Store (ShelleyGenesis StandardShelley) + Named :: Name x -> Store x + +data Name x where + KeyName :: !String -> Name (SigningKey PaymentKey) + FundName :: !String -> Name Fund + FundListName :: !String -> Name [Fund] + TxListName :: !String -> Name (InAnyCardanoEra TxList) + ThreadName :: !String -> Name AsyncBenchmarkControl + +type KeyName = Name (SigningKey PaymentKey) +type FundName = Name Fund +type FundListName = Name [Fund] +type TxListName = Name (InAnyCardanoEra TxList) +type ThreadName = Name AsyncBenchmarkControl + +newtype TxList era = TxList [Tx era] + +-- Remember when debugging at 4:00AM : +-- TH-Haskell is imperative: It breaks up Main into smaller binding groups! +-- This means declarations below a splice are not visible above. +-- The order of splices & declarations matters. + +deriveGEq ''Name +deriveGCompare ''Name +deriveGShow ''Name +deriveArgDict ''Name +deriving instance Show (Name x) +deriving instance Eq (Name x) + +deriveGEq ''Store +deriveGCompare ''Store +deriveGShow ''Store +deriveArgDict ''Store + +deriving instance Show (Store v) +deriving instance Eq (Store x) diff --git a/bench/tx-generator/src/Cardano/Benchmarking/Tracer.hs b/bench/tx-generator/src/Cardano/Benchmarking/Tracer.hs new file mode 100644 index 00000000000..30fd412cac7 --- /dev/null +++ b/bench/tx-generator/src/Cardano/Benchmarking/Tracer.hs @@ -0,0 +1,372 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{-# OPTIONS_GHC -Wno-all-missed-specialisations #-} +{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Cardano.Benchmarking.Tracer + ( BenchTracers(..) + , NodeToNodeSubmissionTrace(..) + , SendRecvConnect + , SendRecvTxSubmission + , SubmissionSummary(..) + , TraceBenchTxSubmit(..) + , TraceLowLevelSubmit(..) + , createTracers + ) where + +import Prelude (Show(..), String) + +import Cardano.Prelude hiding (TypeError, show) + +import qualified Codec.CBOR.Term as CBOR +import Cardano.BM.Tracing +import Data.Aeson (ToJSON (..), (.=)) +import qualified Data.Aeson as A +import qualified Data.HashMap.Strict as HM +import qualified Data.Text as T +import Data.Time.Clock (DiffTime, NominalDiffTime, getCurrentTime) + +-- Mode-agnostic imports. +import Cardano.BM.Data.Tracer + (emptyObject, mkObject, trStructured) +import Network.Mux (WithMuxBearer(..)) +-- Node API imports. +import Cardano.Api + +-- Node imports. +import Cardano.Node.Configuration.Logging (LOContent(..), LoggingLayer (..)) +import Cardano.Tracing.OrphanInstances.Byron() +import Cardano.Tracing.OrphanInstances.Common() +import Cardano.Tracing.OrphanInstances.Consensus() +import Cardano.Tracing.OrphanInstances.Network() +import Cardano.Tracing.OrphanInstances.Shelley() + + +import Cardano.Benchmarking.OuroborosImports +import Ouroboros.Network.Driver (TraceSendRecv (..)) +import Ouroboros.Network.Protocol.TxSubmission.Type (TxSubmission) +import Ouroboros.Consensus.Ledger.SupportsMempool (GenTx, GenTxId) +import Ouroboros.Network.NodeToNode (RemoteConnectionId, NodeToNodeVersion) +import Ouroboros.Network.Protocol.Handshake.Type (Handshake) + +import Cardano.Benchmarking.Types + +data BenchTracers = + BenchTracers + { btBase_ :: Trace IO Text + , btTxSubmit_ :: Tracer IO (TraceBenchTxSubmit TxId) + , btConnect_ :: Tracer IO SendRecvConnect + , btSubmission_ :: Tracer IO SendRecvTxSubmission + , btLowLevel_ :: Tracer IO TraceLowLevelSubmit + , btN2N_ :: Tracer IO NodeToNodeSubmissionTrace + } + +createTracers :: LoggingLayer -> BenchTracers +createTracers loggingLayer = + BenchTracers + baseTrace + benchTracer + connectTracer + submitTracer + lowLevelSubmitTracer + n2nSubmitTracer + where + baseTrace :: Trace IO Text + baseTrace = llBasicTrace loggingLayer + + tr :: Trace IO Text + tr = llAppendName loggingLayer "cli" baseTrace + + tr' :: Trace IO Text + tr' = appendName "generate-txs" tr + + benchTracer :: Tracer IO (TraceBenchTxSubmit TxId) + benchTracer = toLogObjectVerbose (appendName "benchmark" tr') + + connectTracer :: Tracer IO SendRecvConnect + connectTracer = toLogObjectVerbose (appendName "connect" tr') + + submitTracer :: Tracer IO SendRecvTxSubmission + submitTracer = toLogObjectVerbose (appendName "submit" tr') + + lowLevelSubmitTracer :: Tracer IO TraceLowLevelSubmit + lowLevelSubmitTracer = toLogObjectVerbose (appendName "llSubmit" tr') + + n2nSubmitTracer :: Tracer IO NodeToNodeSubmissionTrace + n2nSubmitTracer = toLogObjectVerbose (appendName "submit2" tr') + +{------------------------------------------------------------------------------- + Overall benchmarking trace +-------------------------------------------------------------------------------} +data TraceBenchTxSubmit txid + = TraceBenchTxSubRecv [txid] + -- ^ Received from generator. + | TraceBenchTxSubStart [txid] + -- ^ The @txid@ has been submitted to `TxSubmission` + -- protocol peer. + | TraceBenchTxSubServAnn [txid] + -- ^ Announcing txids in response for server's request. + | TraceBenchTxSubServReq [txid] + -- ^ Request for @tx@ recieved from `TxSubmission` protocol + -- peer. + | TraceBenchTxSubServAck [txid] + -- ^ An ack (window moved over) received for these transactions. + | TraceBenchTxSubServDrop [txid] + -- ^ Transactions the server implicitly dropped. + | TraceBenchTxSubServOuts [txid] + -- ^ Transactions outstanding. + | TraceBenchTxSubServUnav [txid] + -- ^ Transactions requested, but unavailable in the outstanding set. + | TraceBenchTxSubServFed [txid] Int + -- ^ Transactions fed by the feeder, accompanied by sequence number. + | TraceBenchTxSubServCons [txid] + -- ^ Transactions consumed by a submitter. + | TraceBenchTxSubIdle + -- ^ Remote peer requested new transasctions but none were + -- available, generator not keeping up? + | TraceBenchTxSubRateLimit DiffTime + -- ^ Rate limiter bit, this much delay inserted to keep within + -- configured rate. + | TraceBenchTxSubSummary SubmissionSummary + -- ^ SubmissionSummary. + | TraceBenchTxSubDebug String + | TraceBenchTxSubError Text + deriving stock (Show) + +instance Transformable Text IO (TraceBenchTxSubmit TxId) where + -- transform to JSON Object + trTransformer = trStructured + +instance HasSeverityAnnotation (TraceBenchTxSubmit TxId) +instance HasPrivacyAnnotation (TraceBenchTxSubmit TxId) + +-- | Summary of a tx submission run. +data SubmissionSummary + = SubmissionSummary + { ssThreadName :: !String + , ssTxSent :: !Sent + , ssTxUnavailable :: !Unav + , ssElapsed :: !NominalDiffTime + , ssEffectiveTps :: !TPSRate + , ssThreadwiseTps :: ![TPSRate] + , ssFailures :: ![String] + } + deriving stock (Show, Generic) +instance ToJSON SubmissionSummary + +{------------------------------------------------------------------------------- + N2N submission trace +-------------------------------------------------------------------------------} +data NodeToNodeSubmissionTrace + = ReqIdsBlocking Ack Req + | IdsListBlocking Int + + | ReqIdsPrompt Ack Req + | IdsListPrompt Int + + | ReqTxs Int + | TxList Int + + | EndOfProtocol + +instance ToObject NodeToNodeSubmissionTrace where + toObject MinimalVerbosity = const emptyObject -- do not log + toObject _ = \case + ReqIdsBlocking (Ack ack) (Req req) -> + mkObject [ "kind" .= A.String "ReqIdsBlocking" + , "ack" .= A.toJSON ack + , "req" .= A.toJSON req ] + IdsListBlocking sent -> mkObject [ "kind" .= A.String "IdsListBlocking" + , "sent" .= A.toJSON sent ] + ReqIdsPrompt (Ack ack) (Req req) -> + mkObject [ "kind" .= A.String "ReqIdsPrompt" + , "ack" .= A.toJSON ack + , "req" .= A.toJSON req ] + IdsListPrompt sent -> mkObject [ "kind" .= A.String "IdsListPrompt" + , "sent" .= A.toJSON sent ] + EndOfProtocol -> mkObject [ "kind" .= A.String "EndOfProtocol" ] + ReqTxs req -> mkObject [ "kind" .= A.String "ReqTxs" + , "req" .= A.toJSON req ] + TxList sent -> mkObject [ "kind" .= A.String "TxList" + , "sent" .= A.toJSON sent ] + + +instance HasSeverityAnnotation NodeToNodeSubmissionTrace +instance HasPrivacyAnnotation NodeToNodeSubmissionTrace +instance Transformable Text IO NodeToNodeSubmissionTrace where + trTransformer = trStructured + +{------------------------------------------------------------------------------- + Low-tevel tracer +-------------------------------------------------------------------------------} +data TraceLowLevelSubmit + = TraceLowLevelSubmitting + -- ^ Submitting transaction. + | TraceLowLevelAccepted + -- ^ The transaction has been accepted. + | TraceLowLevelRejected String + -- ^ The transaction has been rejected, with corresponding error message. + deriving stock (Show) + +instance ToObject TraceLowLevelSubmit where + toObject MinimalVerbosity _ = emptyObject -- do not log + toObject NormalVerbosity t = + case t of + TraceLowLevelSubmitting -> mkObject ["kind" .= A.String "TraceLowLevelSubmitting"] + TraceLowLevelAccepted -> mkObject ["kind" .= A.String "TraceLowLevelAccepted"] + TraceLowLevelRejected m -> mkObject [ "kind" .= A.String "TraceLowLevelRejected" + , "message" .= A.String (T.pack m) + ] + toObject MaximalVerbosity t = + case t of + TraceLowLevelSubmitting -> + mkObject [ "kind" .= A.String "TraceLowLevelSubmitting" + ] + TraceLowLevelAccepted -> + mkObject [ "kind" .= A.String "TraceLowLevelAccepted" + ] + TraceLowLevelRejected errMsg -> + mkObject [ "kind" .= A.String "TraceLowLevelRejected" + , "errMsg" .= A.String (T.pack errMsg) + ] + +instance HasSeverityAnnotation TraceLowLevelSubmit +instance HasPrivacyAnnotation TraceLowLevelSubmit + +instance (MonadIO m) => Transformable Text m TraceLowLevelSubmit where + -- transform to JSON Object + trTransformer = trStructured + +{------------------------------------------------------------------------------- + SendRecvTxSubmission +-------------------------------------------------------------------------------} +type SendRecvTxSubmission = TraceSendRecv (TxSubmission (GenTxId CardanoBlock) (GenTx CardanoBlock)) + +instance Transformable Text IO SendRecvTxSubmission where + -- transform to JSON Object + trTransformer verb tr = Tracer $ \arg -> do + currentTime <- getCurrentTime + let + obj = toObject verb arg + updatedObj = + if obj == emptyObject + then obj + else + -- Add a timestamp in 'ToObject'-representation. + HM.insert "time" (A.String (T.pack . show $ currentTime)) obj + tracer = if obj == emptyObject then nullTracer else tr + meta <- mkLOMeta (getSeverityAnnotation arg) (getPrivacyAnnotation arg) + traceWith tracer (mempty, LogObject mempty meta (LogStructured updatedObj)) + +{------------------------------------------------------------------------------- + Orphans +-------------------------------------------------------------------------------} +instance HasSeverityAnnotation TxId +instance HasPrivacyAnnotation TxId + +instance ToObject TxId where + toObject MinimalVerbosity _ = emptyObject -- do not log + toObject NormalVerbosity _ = mkObject [ "kind" .= A.String "GenTxId"] + toObject MaximalVerbosity txid = mkObject [ "kind" .= A.String "GenTxId" + , "txId" .= toJSON txid + ] + +instance Transformable Text IO TxId where + trTransformer = trStructured + +type SendRecvConnect = WithMuxBearer + RemoteConnectionId + (TraceSendRecv (Handshake + NodeToNodeVersion + CBOR.Term)) + +instance ToObject (TraceBenchTxSubmit TxId) where + toObject MinimalVerbosity _ = emptyObject -- do not log + toObject NormalVerbosity t = + case t of + TraceBenchTxSubRecv _ -> mkObject ["kind" .= A.String "TraceBenchTxSubRecv"] + TraceBenchTxSubStart _ -> mkObject ["kind" .= A.String "TraceBenchTxSubStart"] + TraceBenchTxSubServAnn _ -> mkObject ["kind" .= A.String "TraceBenchTxSubServAnn"] + TraceBenchTxSubServReq _ -> mkObject ["kind" .= A.String "TraceBenchTxSubServReq"] + TraceBenchTxSubServAck _ -> mkObject ["kind" .= A.String "TraceBenchTxSubServAck"] + TraceBenchTxSubServDrop _ -> mkObject ["kind" .= A.String "TraceBenchTxSubServDrop"] + TraceBenchTxSubServOuts _ -> mkObject ["kind" .= A.String "TraceBenchTxSubServOuts"] + TraceBenchTxSubServUnav _ -> mkObject ["kind" .= A.String "TraceBenchTxSubServUnav"] + TraceBenchTxSubServFed _ _ -> mkObject ["kind" .= A.String "TraceBenchTxSubServFed"] + TraceBenchTxSubServCons _ -> mkObject ["kind" .= A.String "TraceBenchTxSubServCons"] + TraceBenchTxSubIdle -> mkObject ["kind" .= A.String "TraceBenchTxSubIdle"] + TraceBenchTxSubRateLimit _ -> mkObject ["kind" .= A.String "TraceBenchTxSubRateLimit"] + TraceBenchTxSubSummary _ -> mkObject ["kind" .= A.String "TraceBenchTxSubSummary"] + TraceBenchTxSubDebug _ -> mkObject ["kind" .= A.String "TraceBenchTxSubDebug"] + TraceBenchTxSubError _ -> mkObject ["kind" .= A.String "TraceBenchTxSubError"] + toObject MaximalVerbosity t = + case t of + TraceBenchTxSubRecv txIds -> + mkObject [ "kind" .= A.String "TraceBenchTxSubRecv" + , "txIds" .= toJSON txIds + ] + TraceBenchTxSubStart txIds -> + mkObject [ "kind" .= A.String "TraceBenchTxSubStart" + , "txIds" .= toJSON txIds + ] + TraceBenchTxSubServAnn txIds -> + mkObject [ "kind" .= A.String "TraceBenchTxSubServAnn" + , "txIds" .= toJSON txIds + ] + TraceBenchTxSubServReq txIds -> + mkObject [ "kind" .= A.String "TraceBenchTxSubServReq" + , "txIds" .= toJSON txIds + ] + TraceBenchTxSubServAck txIds -> + mkObject [ "kind" .= A.String "TraceBenchTxSubServAck" + , "txIds" .= toJSON txIds + ] + TraceBenchTxSubServDrop txIds -> + mkObject [ "kind" .= A.String "TraceBenchTxSubServDrop" + , "txIds" .= toJSON txIds + ] + TraceBenchTxSubServOuts txIds -> + mkObject [ "kind" .= A.String "TraceBenchTxSubServOuts" + , "txIds" .= toJSON txIds + ] + TraceBenchTxSubServUnav txIds -> + mkObject [ "kind" .= A.String "TraceBenchTxSubServUnav" + , "txIds" .= toJSON txIds + ] + TraceBenchTxSubServFed txIds ix -> + mkObject [ "kind" .= A.String "TraceBenchTxSubServFed" + , "txIds" .= toJSON txIds + , "index" .= toJSON ix + ] + TraceBenchTxSubServCons txIds -> + mkObject [ "kind" .= A.String "TraceBenchTxSubServCons" + , "txIds" .= toJSON txIds + ] + TraceBenchTxSubIdle -> + mkObject [ "kind" .= A.String "TraceBenchTxSubIdle" + ] + TraceBenchTxSubRateLimit limit -> + mkObject [ "kind" .= A.String "TraceBenchTxSubRateLimit" + , "limit" .= toJSON limit + ] + TraceBenchTxSubSummary summary -> + mkObject [ "kind" .= A.String "TraceBenchTxSubSummary" + , "summary" .= toJSON summary + ] + TraceBenchTxSubDebug s -> + mkObject [ "kind" .= A.String "TraceBenchTxSubDebug" + , "msg" .= A.String (T.pack s) + ] + TraceBenchTxSubError s -> + mkObject [ "kind" .= A.String "TraceBenchTxSubError" + , "msg" .= A.String s + ] diff --git a/bench/tx-generator/src/Cardano/Benchmarking/Types.hs b/bench/tx-generator/src/Cardano/Benchmarking/Types.hs new file mode 100644 index 00000000000..7a9d507e0d0 --- /dev/null +++ b/bench/tx-generator/src/Cardano/Benchmarking/Types.hs @@ -0,0 +1,140 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE GeneralisedNewtypeDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -Wno-all-missed-specialisations #-} +{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Cardano.Benchmarking.Types + ( Ack(..) + , Acked(..) + , InitCooldown(..) + , NodeIPv4Address + , NumberOfInputsPerTx(..) + , NumberOfOutputsPerTx(..) + , NumberOfTxs(..) + , Req(..) + , Sent(..) + , SubmissionErrorPolicy(..) + , ToAnnce(..) + , TxAdditionalSize(..) + , TPSRate(..) + , UnAcked(..) + , Unav(..) + , UnReqd(..) + ) where + + +import Prelude +import Data.Word +import GHC.Generics +import Data.Aeson + +import Cardano.Node.Types (NodeIPv4Address) + +myJsonOptions :: Options +myJsonOptions = defaultOptions { + unwrapUnaryRecords = True + } + +-- | How long wait before starting the main submission phase, +-- after the init Tx batch was submitted. +newtype InitCooldown = + InitCooldown Int + deriving newtype (Eq, Ord, Num, Show) +deriving stock instance Generic InitCooldown +instance ToJSON InitCooldown where + toJSON = genericToJSON myJsonOptions + toEncoding = genericToEncoding myJsonOptions +instance FromJSON InitCooldown where parseJSON = genericParseJSON myJsonOptions + +newtype NumberOfInputsPerTx = + NumberOfInputsPerTx Int + deriving newtype (Eq, Ord, Num, Show) +deriving stock instance Generic NumberOfInputsPerTx +instance ToJSON NumberOfInputsPerTx where + toJSON = genericToJSON myJsonOptions + toEncoding = genericToEncoding myJsonOptions + +instance FromJSON NumberOfInputsPerTx where parseJSON = genericParseJSON myJsonOptions + +newtype NumberOfOutputsPerTx = + NumberOfOutputsPerTx Int + deriving newtype (Eq, Ord, Num, Show) +deriving stock instance Generic NumberOfOutputsPerTx +instance ToJSON NumberOfOutputsPerTx where + toJSON = genericToJSON myJsonOptions + toEncoding = genericToEncoding myJsonOptions +instance FromJSON NumberOfOutputsPerTx where parseJSON = genericParseJSON myJsonOptions + +newtype NumberOfTxs = + NumberOfTxs { unNumberOfTxs :: Word64 } + deriving newtype (Eq, Ord, Num, Show) +deriving stock instance Generic NumberOfTxs +instance ToJSON NumberOfTxs where + toJSON = genericToJSON myJsonOptions + toEncoding = genericToEncoding myJsonOptions +instance FromJSON NumberOfTxs where parseJSON = genericParseJSON myJsonOptions + + +newtype TPSRate = + TPSRate Double + deriving newtype (Eq, Ord, Num, Show) +deriving stock instance Generic TPSRate +instance ToJSON TPSRate where + toJSON = genericToJSON myJsonOptions + toEncoding = genericToEncoding myJsonOptions +instance FromJSON TPSRate where parseJSON = genericParseJSON myJsonOptions + +-- | This parameter specifies additional size (in bytes) of transaction. +-- Since 1 transaction is ([input] + [output] + attributes), its size +-- is defined by its inputs and outputs. We want to have an ability to +-- increase transaction's size without increasing the number of inputs/ +-- outputs. Such a big transaction will give us more real-world results +-- of benchmarking. +-- Technically this parameter specifies the size of attribute we'll +-- add to transaction (by default attributes are empty, so if this +-- parameter is skipped, attributes will remain empty). +newtype TxAdditionalSize = + TxAdditionalSize { unTxAdditionalSize :: Int } + deriving newtype (Eq, Ord, Num, Show) +deriving stock instance Generic TxAdditionalSize +instance ToJSON TxAdditionalSize where + toJSON = genericToJSON myJsonOptions + toEncoding = genericToEncoding myJsonOptions +instance FromJSON TxAdditionalSize where parseJSON = genericParseJSON myJsonOptions + +-- | Transactions not yet even announced. +newtype UnReqd tx = UnReqd [tx] + +-- | Transactions we decided to announce now. +newtype ToAnnce tx = ToAnnce [tx] + +-- | Transactions announced, yet unacked by peer. +newtype UnAcked tx = UnAcked [tx] + +-- | Transactions acked by peer. +newtype Acked tx = Acked [tx] + +-- | Peer acknowledged this many txids of the outstanding window. +newtype Ack = Ack Int deriving newtype (Enum, Eq, Integral, Num, Ord, Real) + +-- | Peer requested this many txids to add to the outstanding window. +newtype Req = Req Int deriving newtype (Enum, Eq, Integral, Num, Ord, Real) + +-- | This many Txs sent to peer. +newtype Sent = Sent Int deriving newtype (Enum, Eq, Integral, Num, Ord, Real, Show) +deriving stock instance Generic Sent + +-- | This many Txs requested by the peer, but not available for sending. +newtype Unav = Unav Int deriving newtype (Enum, Eq, Integral, Num, Ord, Real, Show) +deriving stock instance Generic Unav + +data SubmissionErrorPolicy + = FailOnError + | LogErrors + deriving stock (Eq, Show) + +instance ToJSON Sent +instance ToJSON Unav diff --git a/bench/tx-generator/src/Cardano/Benchmarking/Wallet.hs b/bench/tx-generator/src/Cardano/Benchmarking/Wallet.hs new file mode 100644 index 00000000000..c2d4e121705 --- /dev/null +++ b/bench/tx-generator/src/Cardano/Benchmarking/Wallet.hs @@ -0,0 +1,184 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +module Cardano.Benchmarking.Wallet +where +import Prelude + +import Data.IxSet.Typed as IxSet +import Data.Proxy +import Control.Concurrent.MVar + +import Cardano.Api + +import Cardano.Benchmarking.GeneratorTx.Tx as Tx hiding (Fund) +import Cardano.Benchmarking.FundSet as FundSet + +type WalletRef = MVar Wallet + +data Wallet = Wallet { + walletNetworkId :: !NetworkId + , walletKey :: !(SigningKey PaymentKey) + , walletSeqNumber :: !SeqNumber + , walletFunds :: !FundSet + } + +initWallet :: NetworkId -> SigningKey PaymentKey -> IO (MVar Wallet) +initWallet network key = newMVar $ Wallet { + walletNetworkId = network + , walletKey = key + , walletSeqNumber = SeqNumber 1 + , walletFunds = emptyFunds + } + +walletRefInsertFund :: WalletRef -> Fund -> IO () +walletRefInsertFund ref fund = modifyMVar_ ref $ \w -> return $ walletInsertFund w fund + +walletInsertFund :: Wallet -> Fund -> Wallet +walletInsertFund w f + = w { walletFunds = FundSet.insertFund (walletFunds w) f } + +walletDeleteFund :: Wallet -> Fund -> Wallet +walletDeleteFund w f + = w { walletFunds = FundSet.deleteFund (walletFunds w) f } + +walletUpdateFunds :: Wallet -> [Fund] -> [Fund] -> Wallet +walletUpdateFunds w add del + = foldl walletInsertFund w2 add + where w2 = foldl walletDeleteFund w del + +walletRefCreateCoins :: forall era. IsShelleyBasedEra era + => WalletRef + -> [Lovelace] + -> IO (Either String (Tx era)) +walletRefCreateCoins ref coins + = modifyMVar ref $ \w -> case walletCreateCoins w coins of + Right (newWallet, tx) -> return (newWallet, Right tx) + Left err -> return (w, Left err) + +walletCreateCoins :: forall era. IsShelleyBasedEra era + => Wallet + -> [Lovelace] + -> Either String (Wallet, Tx era) +walletCreateCoins wallet genValues = do + inputCoin <- findSufficientCoin (walletFunds wallet) (sum genValues) + let outValues = includeChange [getFundLovelace inputCoin] genValues + (tx, txId) <- genTx (walletKey wallet) (walletNetworkId wallet) [inputCoin] outValues + let newFunds = zipWith (mkNewFund txId) [TxIx 0 ..] outValues + Right (walletUpdateFunds wallet newFunds [inputCoin] , tx) + where + mkNewFund :: TxId -> TxIx -> Lovelace -> Fund + mkNewFund txId txIx val = Fund $ InAnyCardanoEra (cardanoEra @ era) $ FundInEra { + _fundTxIn = TxIn txId txIx + , _fundVal = mkTxOutValueAdaOnly val + , _fundSigningKey = walletKey wallet + , _fundValidity = Confirmed + } + + findSufficientCoin :: FundSet -> Lovelace -> Either String Fund + findSufficientCoin fs minValue = case coins of + [] -> Left $ "findSufficientCoin: no single coin with min value >= " ++ show minValue + (c:_) -> Right c + where coins = toAscList ( Proxy :: Proxy Lovelace) (fs @= IsConfirmed @>= minValue) + +includeChange :: [Lovelace] -> [Lovelace] -> [Lovelace] +includeChange have spend = case compare changeValue 0 of + GT -> changeValue : spend + EQ -> spend + LT -> error "genTX: Bad transaction: insufficient funds" + where changeValue = sum have - sum spend + +-- genTx assumes that inFunds and outValues are of equal value. +genTx :: forall era. IsShelleyBasedEra era + => SigningKey PaymentKey + -> NetworkId + -> [Fund] + -> [Lovelace] + -> Either String (Tx era, TxId) +genTx key networkId inFunds outValues + = case makeTransactionBody txBodyContent of + Left err -> error $ show err + Right b -> Right ( signShelleyTransaction b (map (WitnessPaymentKey . getFundKey) inFunds) + , getTxId b + ) + where + txBodyContent = TxBodyContent { + txIns = map (\f -> (getFundTxIn f, BuildTxWith $ KeyWitness KeyWitnessForSpending)) inFunds + , txOuts = map mkTxOut outValues + , txFee = mkFee 0 + , txValidityRange = (TxValidityNoLowerBound, upperBound) + , txMetadata = TxMetadataNone + , txAuxScripts = TxAuxScriptsNone + , txWithdrawals = TxWithdrawalsNone + , txCertificates = TxCertificatesNone + , txUpdateProposal = TxUpdateProposalNone + , txMintValue = TxMintNone + } + + mkTxOut v = TxOut (Tx.keyAddress @ era networkId key) (mkTxOutValueAdaOnly v) + + upperBound :: TxValidityUpperBound era + upperBound = case shelleyBasedEra @ era of + ShelleyBasedEraShelley -> TxValidityUpperBound ValidityUpperBoundInShelleyEra $ SlotNo maxBound + ShelleyBasedEraAllegra -> TxValidityNoUpperBound ValidityNoUpperBoundInAllegraEra + ShelleyBasedEraMary -> TxValidityNoUpperBound ValidityNoUpperBoundInMaryEra + +benchmarkTransaction :: forall era. IsShelleyBasedEra era + => Wallet + -> Int + -> Target + -> Either String (Wallet, Tx era) +benchmarkTransaction wallet numInputs targetNode = do + inputFunds <- findInputFunds (walletFunds wallet) targetNode + let outValues = map getFundLovelace inputFunds + (tx, txId) <- genTx (walletKey wallet) (walletNetworkId wallet) inputFunds outValues + let + newFunds = zipWith (mkNewFund txId) [TxIx 0 ..] outValues + newWallet = (walletUpdateFunds wallet newFunds inputFunds) {walletSeqNumber = newSeqNumber} + Right (newWallet , tx) + where + newSeqNumber = succ $ walletSeqNumber wallet + + mkNewFund :: TxId -> TxIx -> Lovelace -> Fund + mkNewFund txId txIx val = Fund $ InAnyCardanoEra (cardanoEra @ era) $ FundInEra { + _fundTxIn = TxIn txId txIx + , _fundVal = mkTxOutValueAdaOnly val + , _fundSigningKey = walletKey wallet + , _fundValidity = InFlight targetNode newSeqNumber + } + + findInputFunds :: FundSet -> Target -> Either String [Fund] + findInputFunds fs _target = + if length coins == numInputs + then Right coins + else Left "could not find enough input coins" + where + -- Just take confirmed coins. + -- TODO: extend this to unconfimed coins to the same target node + coins = take numInputs $ toAscList ( Proxy :: Proxy Lovelace) (fs @= IsConfirmed) + +newtype WalletScript era = WalletScript { runWalletScript :: IO (WalletStep era) } + +data WalletStep era + = Done + | NextTx !(WalletScript era) !(Tx era) + | Error String + +benchmarkWalletScript :: forall era . + IsShelleyBasedEra era + => WalletRef + -> SeqNumber + -> Int + -> Target + -> WalletScript era +benchmarkWalletScript wRef maxCount numInputs targetNode + = WalletScript (modifyMVarMasked wRef nextTx) + where + nextCall = benchmarkWalletScript wRef maxCount numInputs targetNode + nextTx :: Wallet -> IO (Wallet, WalletStep era) + nextTx w = if walletSeqNumber w > maxCount + then return (w, Done) + else case benchmarkTransaction w numInputs targetNode of + Right (wNew, tx) -> return (wNew, NextTx nextCall tx) + Left err -> return (w, Error err) diff --git a/bench/tx-generator/test/Main.hs b/bench/tx-generator/test/Main.hs new file mode 100644 index 00000000000..6ea92c6242f --- /dev/null +++ b/bench/tx-generator/test/Main.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE Trustworthy #-} +module Main (main) where + +import Prelude +import Data.Maybe +import Test.Tasty +import Test.Tasty.HUnit +import Text.Heredoc +import Options.Applicative + +import Cardano.Benchmarking.Command (commandParser) +import Cardano.Benchmarking.CliArgsScript (parseGeneratorCmd) +import Cardano.Benchmarking.GeneratorTx.SizedMetadata + + +main :: IO () +main = defaultMain tests + +tests :: TestTree +tests = testGroup "cardano-tx-generator" + [ + cliArgs + , sizedMetadata + , mockServer + ] + +mockServer = testGroup "direct/pure client-server connect" + [ testCase "tx-send == tx-received" $ assertBool "tx-send == tx-received" True -- TODO ! + ] + +sizedMetadata = testGroup "properties of the CBOR encoding relevant for generating sized metadat" + [ testCase "Shelley metadata map costs" $ assertBool "metadata map costs" prop_mapCostsShelley + , testCase "Shelley metadata ByteString costs" $ assertBool "metadata ByteString costs" prop_bsCostsShelley + , testCase "Allegra metadata map costs" $ assertBool "metadata map costs" prop_mapCostsAllegra + , testCase "Allegra metadata ByteString costs" $ assertBool "metadata ByteString costs" prop_bsCostsAllegra + , testCase "Mary metadata map costs" $ assertBool "metadata map costs" prop_mapCostsMary + , testCase "Marymetadata ByteString costs" $ assertBool "metadata ByteString costs" prop_bsCostsMary + , testCase "Test mkMetadata" $ assertBool "" True --WIP + ] + + +cliArgs = testGroup "cli arguments" + [ + -- Also update readme and documentation when the help-messages changes. + testCase "check help message against pinned version" + $ assertBool "help message == pinned help message" $ helpMessage == pinnedHelpMessage + + -- examples for calling the tx-generator found in the shell scripts. + , testCmdLine [here|cliArguments --config /work/cli-tests/benchmarks/shelley3pools/configuration/configuration-generator.yaml --socket-path /work/cli-tests/benchmarks/shelley3pools/logs/sockets/1 --num-of-txs 1000 --add-tx-size 0 --inputs-per-tx 1 --outputs-per-tx 1 --tx-fee 1000000 --tps 10 --init-cooldown 5 --target-node ("127.0.0.1",3000) --target-node ("127.0.0.1",3001) --target-node ("127.0.0.1",3002) --genesis-funds-key configuration/genesis-shelley/utxo-keys/utxo1.skey|] + , testCmdLine [here|eraTransition --config /work/cli-tests/benchmarks/shelley3pools/configuration/configuration-generator.yaml --socket-path /work/cli-tests/benchmarks/shelley3pools/logs/sockets/1 --num-of-txs 1000 --add-tx-size 0 --inputs-per-tx 1 --outputs-per-tx 1 --tx-fee 1000000 --tps 10 --init-cooldown 5 --target-node ("127.0.0.1",3000) --target-node ("127.0.0.1",3001) --target-node ("127.0.0.1",3002) --genesis-funds-key configuration/genesis-shelley/utxo-keys/utxo1.skey|] + + ] + where + testCmdLine :: String -> TestTree + testCmdLine l = testCase "check that example cmd line parses" $ assertBool l $ isJust + $ getParseResult $ execParserPure defaultPrefs (info commandParser fullDesc) + $ words l +pinnedHelpMessage = [here|ParserFailure(Usage: --config FILEPATH --socket-path FILEPATH + [--shelley | --mary | --allegra] [(--target-node (HOST,PORT))] + [--init-cooldown INT] [--initial-ttl INT] [--num-of-txs INT] + [--tps DOUBLE] [--inputs-per-tx INT] [--outputs-per-tx INT] + [--tx-fee INT] [--add-tx-size INT] + [--fail-on-submission-errors] + (--genesis-funds-key FILEPATH | --utxo-funds-key FILEPATH + --tx-in TX-IN --tx-out TX-OUT | + --split-utxo-funds-key FILEPATH --split-utxo FILEPATH) + +Available options: + --config FILEPATH Configuration file for the cardano-node + --socket-path FILEPATH Path to a cardano-node socket + --shelley Initialise Cardano in shelley submode. + --mary Initialise Cardano in mary submode. + --allegra Initialise Cardano in allegra submode. + --target-node (HOST,PORT) + IP address and port of the node transactions will be + sent to. + --init-cooldown INT Delay between init and main submission phases. + --initial-ttl INT Slot denoting TTL of the initial transactions. + --num-of-txs INT Number of transactions generator will create. + --tps DOUBLE TPS (transaction per second) rate. + --inputs-per-tx INT Number of inputs in each of transactions. + --outputs-per-tx INT Number of outputs in each of transactions. + --tx-fee INT Fee per transaction, in Lovelaces. + --add-tx-size INT Additional size of transaction, in bytes. + --fail-on-submission-errors + Fail on submission thread errors, instead of logging + them. + --genesis-funds-key FILEPATH + Genesis UTxO funds signing key. + --utxo-funds-key FILEPATH + UTxO funds signing key. + --tx-in TX-IN The input transaction as TxId#TxIx where TxId is the + transaction hash and TxIx is the index. + --tx-out TX-OUT The transaction output as Address+Lovelace where + Address is the Bech32-encoded address followed by the + amount in Lovelace. + --split-utxo-funds-key FILEPATH + UTxO funds signing key. + --split-utxo FILEPATH UTxO funds file.,ExitSuccess,80)|] + +helpMessage = show $ parserFailure defaultPrefs (info parseGeneratorCmd fullDesc ) (ShowHelpText Nothing) [] diff --git a/bench/tx-generator/test/script.json b/bench/tx-generator/test/script.json new file mode 100644 index 00000000000..198acfc53ec --- /dev/null +++ b/bench/tx-generator/test/script.json @@ -0,0 +1,94 @@ +[ + { + "setNumberOfInputsPerTx": 1 + }, + { + "setNumberOfOutputsPerTx": 1 + }, + { + "setNumberOfTxs": 500 + }, + { + "setTxAdditionalSize": 0 + }, + { + "setFee": 0 + }, + { + "setTTL": 1000000 + }, + { + "startProtocol": "configuration/configuration-generator.yaml" + }, + { + "setEra": "Mary" + }, + { + "setLocalSocket": "logs/sockets/1" + }, + { + "readSigningKey": "pass-partout", + "filePath": "configuration/genesis-shelley/utxo-keys/utxo1.skey" + }, + { + "secureGenesisFund": "genFund", + "genesisKey": "pass-partout", + "fundKey": "pass-partout" + }, + { + "delay": 10 + }, + { + "splitFund": [ + "fund1", + "fund2", + "fund3", + "fund4" + ], + "sourceFund": "genFund", + "newKey": "pass-partout" + }, + { + "delay": 10 + }, + { + "splitFundToList": "fundList", + "sourceFund": "fund1", + "newKey": "pass-partout" + }, + { + "prepareTxList": "txlist", + "newKey": "pass-partout", + "fundList": "fundList" + }, + { + "setTargets": [ + { + "addr": "127.0.0.1", + "port": 3000 + }, + { + "addr": "127.0.0.1", + "port": 3001 + }, + { + "addr": "127.0.0.1", + "port": 3002 + } + ] + }, + { + "asyncBenchmark": "thread1", + "txList": "txlist", + "tps": 10 + }, + { + "waitForEra": "Byron" + }, + { + "cancelBenchmark": "thread1" + }, + { + "reserved": [] + } +] \ No newline at end of file diff --git a/bench/tx-generator/tx-generator.cabal b/bench/tx-generator/tx-generator.cabal new file mode 100644 index 00000000000..7c90c6f2fd2 --- /dev/null +++ b/bench/tx-generator/tx-generator.cabal @@ -0,0 +1,150 @@ +name: tx-generator +version: 1.27 +description: The transaction generator for cardano node +author: IOHK +maintainer: operations@iohk.io +license: Apache-2.0 +license-files: + LICENSE + NOTICE +build-type: Simple +cabal-version: >= 1.10 +extra-source-files: README.md +library + + hs-source-dirs: src + ghc-options: -Wall + -Wcompat + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wno-prepositive-qualified-module + -Wno-unticked-promoted-constructors + -Wpartial-fields + -Wredundant-constraints + -Wwarn=deprecations + + exposed-modules: + Cardano.Benchmarking.CliArgsScript + Cardano.Benchmarking.Command + Cardano.Benchmarking.DSL + Cardano.Benchmarking.FundSet + Cardano.Benchmarking.GeneratorTx + Cardano.Benchmarking.GeneratorTx.Benchmark + Cardano.Benchmarking.GeneratorTx.Error + Cardano.Benchmarking.GeneratorTx.LocalProtocolDefinition + Cardano.Benchmarking.GeneratorTx.Genesis + Cardano.Benchmarking.GeneratorTx.NodeToNode + Cardano.Benchmarking.GeneratorTx.Tx + Cardano.Benchmarking.GeneratorTx.SizedMetadata + Cardano.Benchmarking.GeneratorTx.Tx.Byron + Cardano.Benchmarking.GeneratorTx.Submission + Cardano.Benchmarking.GeneratorTx.CLI.Parsers + Cardano.Benchmarking.OuroborosImports + Cardano.Benchmarking.Script + Cardano.Benchmarking.Script.Action + Cardano.Benchmarking.Script.Aeson + Cardano.Benchmarking.Script.Core + Cardano.Benchmarking.Script.Env + Cardano.Benchmarking.Script.Example + Cardano.Benchmarking.Script.Setters + Cardano.Benchmarking.Script.Store + Cardano.Benchmarking.Tracer + Cardano.Benchmarking.Types + Cardano.Benchmarking.Wallet + + other-modules: Paths_tx_generator + + build-depends: aeson + , aeson-pretty + , async + , attoparsec + , base >=4.12 && <5 + , bytestring + , cardano-api + , cardano-binary + , cardano-cli + , cardano-crypto-class + , cardano-crypto-wrapper + , cardano-ledger-byron + , cardano-node + , cardano-prelude + , contra-tracer + , cborg >= 0.2.2 && < 0.3 + , containers + , constraints-extras + , dependent-map + , dependent-sum + , dependent-sum-template + , extra + , formatting + , generic-monoid + , ghc-prim + , io-sim-classes + , iohk-monitoring + , ixset-typed + , network + , network-mux + , optparse-applicative + , ouroboros-consensus + , ouroboros-consensus-byron + , ouroboros-consensus-cardano + , ouroboros-consensus-shelley + , ouroboros-network + , ouroboros-network-framework + , random + , serialise + , shelley-spec-ledger + , stm + , text + , time + , transformers + , transformers-except + , unordered-containers + + default-language: Haskell2010 + default-extensions: NoImplicitPrelude + OverloadedStrings + + ghc-options: -Wall + -Wno-implicit-prelude + -fno-warn-safe + -fno-warn-unsafe + -fno-warn-missing-import-lists + -Wno-unticked-promoted-constructors + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wredundant-constraints + -Wpartial-fields + -Wcompat + +executable tx-generator + hs-source-dirs: app + main-is: tx-generator.hs + default-language: Haskell2010 + ghc-options: -threaded + -Wall + -rtsopts + "-with-rtsopts=-T" + + build-depends: base >=4.12 && <5 + , tx-generator + +test-suite tx-generator-test + hs-source-dirs: test + main-is: Main.hs + type: exitcode-stdio-1.0 + + build-depends: base >=4.12 && <5 + , tasty-hunit + , tasty + , heredoc + , optparse-applicative + , tx-generator + + default-language: Haskell2010 + + ghc-options: -Weverything + -fno-warn-missing-import-lists + -fno-warn-safe + -fno-warn-unsafe + -threaded -rtsopts -with-rtsopts=-N -with-rtsopts=-T diff --git a/cabal.project b/cabal.project index a3d25890bc2..7edad94098e 100644 --- a/cabal.project +++ b/cabal.project @@ -10,6 +10,7 @@ packages: cardano-node-chairman cardano-submit-api nix/workbench/cardano-topology + bench/tx-generator package cardano-api ghc-options: -Werror @@ -26,6 +27,9 @@ package cardano-node package cardano-node-chairman ghc-options: -Werror +package tx-generator + ghc-options: -Werror + package cryptonite -- Using RDRAND instead of /dev/urandom as an entropy source for key -- generation is dubious. Set the flag so we use /dev/urandom by default. diff --git a/cardano-node/cardano-node.cabal b/cardano-node/cardano-node.cabal index 026aff5b267..fa13319ed03 100644 --- a/cardano-node/cardano-node.cabal +++ b/cardano-node/cardano-node.cabal @@ -1,7 +1,7 @@ cabal-version: 2.4 name: cardano-node -version: 1.27.0 +version: 1.26.1 description: The cardano full node author: IOHK maintainer: operations@iohk.io diff --git a/default.nix b/default.nix index 8d97b87d0d1..0916cdc2ffd 100644 --- a/default.nix +++ b/default.nix @@ -25,9 +25,8 @@ let packages = { inherit haskellPackages cardano-node cardano-node-profiled cardano-node-eventlogged - cardano-cli db-converter cardano-ping + cardano-cli db-converter cardano-ping tx-generator scripts environments dockerImage submitApiDockerImage bech32; - nixosTests = recRecurseIntoAttrs nixosTests; # so that eval time gc roots are cached (nix-tools stuff) diff --git a/nix/pkgs.nix b/nix/pkgs.nix index 559601a04e8..2b6d89245e0 100644 --- a/nix/pkgs.nix +++ b/nix/pkgs.nix @@ -65,6 +65,7 @@ final: prev: with final; inherit (cardanoNodeHaskellPackages.cardano-node.components.exes) cardano-node; inherit (cardanoNodeHaskellPackages.cardano-cli.components.exes) cardano-cli; inherit (cardanoNodeHaskellPackages.cardano-topology.components.exes) cardano-topology; + inherit (cardanoNodeHaskellPackages.tx-generator.components.exes) tx-generator; inherit (cardanoNodeHaskellPackages.bech32.components.exes) bech32; inherit (cardanoNodeHaskellPackages.cardano-submit-api.components.exes) cardano-submit-api; cardano-node-profiled = cardanoNodeProfiledHaskellPackages.cardano-node.components.exes.cardano-node; diff --git a/release.nix b/release.nix index 163e7476a2c..e1783c669fb 100644 --- a/release.nix +++ b/release.nix @@ -126,6 +126,8 @@ let [ "cardano-node-profiled" ] [ "cardano-node-eventlogged" ] [ "checks" "tests" "cardano-node-chairman" ] [ "workbench" ] [ "profiles" ] + [ "haskellPackages" "cardano-node-chairman" "checks" ] [ "checks" "tests" "cardano-node-chairman" ] + [ "haskellPackages" "tx-generator" ] ]; # Paths or prefix of paths for which cross-builds (mingwW64, musl64) are disabled: noCrossBuild = [