From d434f67a3aa8502b84212786a76e02105f7169e7 Mon Sep 17 00:00:00 2001 From: Nadia Yvette Chambers Date: Tue, 7 May 2024 14:02:34 +0000 Subject: [PATCH 1/9] txgen-mvar: fast-solo profile This is to speed up the development cycle esp. for rapid tests. --- Makefile | 2 +- nix/workbench/profile/prof1-variants.jq | 3 +++ 2 files changed, 4 insertions(+), 1 deletion(-) diff --git a/Makefile b/Makefile index fc952643706..32e6f93fe49 100644 --- a/Makefile +++ b/Makefile @@ -75,7 +75,7 @@ ps: ## Plain-text list of profiles ## Profile-based cluster shells (autogenerated targets) ## PROFILES_BASE := default default-p2p plutus plutus-secp-ecdsa plutus-secp-schnorr oldtracing idle tracer-only -PROFILES_FAST := fast fast-p2p fast-plutus fast-notracer fast-oldtracing faststartup-24M +PROFILES_FAST := fast fast-solo fast-p2p fast-plutus fast-notracer fast-oldtracing faststartup-24M PROFILES_CI_TEST := ci-test ci-test-p2p ci-test-plutus ci-test-notracer ci-test-rtview ci-test-dense10 PROFILES_CI_BENCH := ci-bench ci-bench-p2p ci-bench-plutus ci-bench-plutus-secp-ecdsa ci-bench-plutus-secp-schnorr ci-bench-notracer ci-bench-rtview ci-bench-lmdb ci-bench-drep PROFILES_CI_BENCH += ci-bench-plutusv3-blst ci-bench-plutus24 diff --git a/nix/workbench/profile/prof1-variants.jq b/nix/workbench/profile/prof1-variants.jq index 971093d92fc..3e9e06d20d8 100644 --- a/nix/workbench/profile/prof1-variants.jq +++ b/nix/workbench/profile/prof1-variants.jq @@ -976,6 +976,9 @@ def all_profile_variants: , $fast_base * { name: "fast" } + , $fast_base * $solo * + { name: "fast-solo" + } , $fast_base * $p2p * { name: "fast-p2p" } From 688b595bdc4d893d16a9f67c4cbc75a99e84106b Mon Sep 17 00:00:00 2001 From: Nadia Yvette Chambers Date: Wed, 1 May 2024 21:00:03 +0000 Subject: [PATCH 2/9] txgen-mvar: make keepAliveInterval configurable This adds a keepalive interval field for NixServiceOptions and then handles defaulting it to 30 like now when it's absent from the JSON and defaulted to 10. It also omits it when it's the default when rendering it into JSON. --- .../Cardano/TxGenerator/Setup/NixService.hs | 19 ++++++++++--------- 1 file changed, 10 insertions(+), 9 deletions(-) diff --git a/bench/tx-generator/src/Cardano/TxGenerator/Setup/NixService.hs b/bench/tx-generator/src/Cardano/TxGenerator/Setup/NixService.hs index 49b8ef472e4..7ad4d27a19e 100644 --- a/bench/tx-generator/src/Cardano/TxGenerator/Setup/NixService.hs +++ b/bench/tx-generator/src/Cardano/TxGenerator/Setup/NixService.hs @@ -1,12 +1,13 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Cardano.TxGenerator.Setup.NixService - ( NixServiceOptions(..) + ( NixServiceOptions (..) , getNodeConfigFile , setNodeConfigFile , txGenTxParams @@ -24,9 +25,11 @@ import Cardano.Node.Types (AdjustFilePaths (..)) import Cardano.TxGenerator.Internal.Orphans () import Cardano.TxGenerator.Types -import Data.Aeson +import Data.Aeson (FromJSON (..), Options (fieldLabelModifier), (.:), (.:?)) +import qualified Data.Aeson as Aeson (Options, defaultOptions, genericParseJSON, withObject) import Data.List.NonEmpty (NonEmpty) import Data.Maybe (fromMaybe) +import qualified Data.Time.Clock as Clock (DiffTime) import GHC.Generics (Generic) @@ -42,6 +45,7 @@ data NixServiceOptions = NixServiceOptions { , _nix_init_cooldown :: Double , _nix_era :: AnyCardanoEra , _nix_plutus :: Maybe TxGenPlutusParams + , _nix_keepalive :: Maybe Clock.DiffTime , _nix_nodeConfigFile :: Maybe FilePath , _nix_cardanoTracerSocket :: Maybe FilePath , _nix_sigKey :: SigningKeyFile In @@ -59,14 +63,11 @@ setNodeConfigFile opts filePath = opts {_nix_nodeConfigFile = Just filePath } -- dropping the '_nix_ prefix of above Haskell ADT field labels is assumed -- to match JSON attribute names as provided by the Nix service definition -jsonOptions :: Options -jsonOptions = defaultOptions { fieldLabelModifier = stripPrefix } - where - stripPrefix :: String -> String - stripPrefix = drop 5 +jsonOptions :: Aeson.Options +jsonOptions = Aeson.defaultOptions { fieldLabelModifier = drop 5 } instance FromJSON NixServiceOptions where - parseJSON = genericParseJSON jsonOptions + parseJSON = Aeson.genericParseJSON jsonOptions instance AdjustFilePaths NixServiceOptions where adjustFilePaths f opts @@ -79,7 +80,7 @@ instance AdjustFilePaths NixServiceOptions where -- | This deserialization is not a general one for that type, but custom-tailored -- to the service definition in: nix/nixos/tx-generator-service.nix instance FromJSON TxGenPlutusParams where - parseJSON = withObject "TxGenPlutusParams" $ \o -> + parseJSON = Aeson.withObject "TxGenPlutusParams" $ \o -> PlutusOn <$> o .: "type" <*> o .: "script" From 2f99dcddcbf8d526441917a2fd7c82b4575eb5a9 Mon Sep 17 00:00:00 2001 From: Nadia Yvette Chambers Date: Wed, 22 May 2024 23:48:58 +0000 Subject: [PATCH 3/9] txgen-mvar: label threads, report labels mkarg@iohk.io wrote the nix code and the beginnings of the Haskell side. So this commit goes about creating node aliases, represented in Haskell in the NodeDescription structure, and using them in reporting, which happens in the exception handlers. The node aliases contribute to thread labels reported in the exception handlers where possible; older base versions lack accessors for thread labels. handleTxSubmissionClientError is the main exception handler involved. txSubmissionClient, consumeTxsNonBlocking and newTpsThrottle are spawned as threads within walletBenchmark and labelled accordingly, with the txSubmissionClient labels further elaborated upon with the node submitted to. SubmitMode's threadName field for the Benchmark alternative is produced by the compiler and corresponds to a label for a set of threads tracked in an AsyncBenchmarkControl structure as opposed to a label for an individual thread, hence the effort to generate thread labels by other means. --- .../src/Cardano/Benchmarking/Command.hs | 2 +- .../src/Cardano/Benchmarking/GeneratorTx.hs | 87 ++++++++++++------- .../src/Cardano/Benchmarking/Script/Types.hs | 3 +- .../src/Cardano/Benchmarking/TpsThrottle.hs | 15 ++-- .../Cardano/TxGenerator/Setup/NixService.hs | 62 +++++++++++-- nix/nixos/tx-generator-service.nix | 4 +- nix/workbench/service/generator.nix | 2 +- 7 files changed, 129 insertions(+), 46 deletions(-) diff --git a/bench/tx-generator/src/Cardano/Benchmarking/Command.hs b/bench/tx-generator/src/Cardano/Benchmarking/Command.hs index ffc9ab8fa6c..f7ab8c6c261 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/Command.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/Command.hs @@ -73,7 +73,7 @@ runCommand = withIOManager $ \iocp -> do handleError :: Show a => Either a b -> IO () handleError = \case Right _ -> exitSuccess - Left err -> die $ show err + Left err -> die $ "tx-generator:Cardano.Command: " ++ show err mangleNodeConfig :: Maybe FilePath -> NixServiceOptions -> IO NixServiceOptions mangleNodeConfig fp opts = case (getNodeConfigFile opts, fp) of diff --git a/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx.hs b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx.hs index 563e3820d0c..13a6b94040e 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx.hs @@ -1,5 +1,7 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UndecidableInstances #-} @@ -16,21 +18,6 @@ module Cardano.Benchmarking.GeneratorTx , waitBenchmark ) where -import Cardano.Prelude -import Prelude (String) - -import qualified Control.Concurrent.STM as STM -import qualified Data.Time.Clock as Clock - -import qualified Data.List.NonEmpty as NE -import Data.Text (pack) -import Network.Socket (AddrInfo (..), AddrInfoFlag (..), Family (..), SocketType (Stream), - addrFamily, addrFlags, addrSocketType, defaultHints, getAddrInfo) - -import Cardano.Logging - -import Cardano.Node.Configuration.NodeAddress - import Cardano.Api hiding (txFee) import Cardano.Benchmarking.GeneratorTx.NodeToNode @@ -40,8 +27,32 @@ import Cardano.Benchmarking.LogTypes import Cardano.Benchmarking.TpsThrottle import Cardano.Benchmarking.Types import Cardano.Benchmarking.Wallet (TxStream) +import Cardano.Logging +import Cardano.Node.Configuration.NodeAddress +import Cardano.Prelude +import Cardano.TxGenerator.Setup.NixService import Cardano.TxGenerator.Types (NumberOfTxs, TPSRate, TxGenError (..)) +import Prelude (String) + +import qualified Control.Concurrent.STM as STM +import qualified Data.List as List (unwords) +import qualified Data.List.NonEmpty as NE +import Data.Text (pack) +import qualified Data.Time.Clock as Clock +import Data.Tuple.Extra (secondM) +import GHC.Conc (labelThread) + +#if MIN_VERSION_base(4,18,0) +-- fromMaybe is imported via Cardano.Prelude +-- However, this configuration actually uses it. +-- import Data.Maybe (fromMaybe) +import GHC.Conc.Sync (threadLabel) +#endif + +import Network.Socket (AddrInfo (..), AddrInfoFlag (..), Family (..), SocketType (Stream), + addrFamily, addrFlags, addrSocketType, defaultHints, getAddrInfo) + type AsyncBenchmarkControl = (Async (), [Async ()], IO SubmissionSummary, IO ()) @@ -50,8 +61,7 @@ waitBenchmark traceSubmit (feeder, workers, mkSummary, _) = liftIO $ do mapM_ waitCatch (feeder : workers) traceWith traceSubmit . TraceBenchTxSubSummary =<< mkSummary -lookupNodeAddress :: - NodeAddress' NodeHostIPv4Address -> IO AddrInfo +lookupNodeAddress :: NodeIPv4Address -> IO AddrInfo lookupNodeAddress node = do (remoteAddr:_) <- getAddrInfo (Just hints) (Just targetNodeHost) (Just targetNodePort) return remoteAddr @@ -68,34 +78,44 @@ lookupNodeAddress node = do handleTxSubmissionClientError :: Trace IO (TraceBenchTxSubmit TxId) - -> Network.Socket.AddrInfo + -> (String, Network.Socket.AddrInfo) -> ReportRef -> SubmissionErrorPolicy -> SomeException -> IO () handleTxSubmissionClientError traceSubmit - remoteAddr + (remoteName, remoteAddr) reportRef errorPolicy (SomeException err) = do + tid <- myThreadId +#if MIN_VERSION_base(4,18,0) + label <- threadLabel tid + let labelStr = fromMaybe "(unlabelled)" label +#else + let labelStr = "(base version too low to examine thread labels)" +#endif + let errDesc = List.unwords + [ "Thread" + , show tid + , labelStr + , "Exception while talking to peer " + , remoteName + , "(" ++ show (addrAddress remoteAddr) ++ "):" + , show err ] submitThreadReport reportRef (Left errDesc) case errorPolicy of FailOnError -> throwIO err LogErrors -> traceWith traceSubmit $ TraceBenchTxSubError (pack errDesc) - where - errDesc = mconcat - [ "Exception while talking to peer " - , " (", show (addrAddress remoteAddr), "): " - , show err] walletBenchmark :: forall era. IsShelleyBasedEra era => Trace IO (TraceBenchTxSubmit TxId) -> Trace IO NodeToNodeSubmissionTrace -> ConnectClient -> String - -> NonEmpty NodeIPv4Address + -> NonEmpty NodeDescription -> TPSRate -> SubmissionErrorPolicy -> AsType era @@ -122,8 +142,10 @@ walletBenchmark = liftIO $ do traceDebug "******* Tx generator, phase 2: pay to recipients *******" - remoteAddresses <- forM targets lookupNodeAddress let numTargets :: Natural = fromIntegral $ NE.length targets + lookupTarget :: NodeDescription -> IO (String, AddrInfo) + lookupTarget NodeDescription {..} = secondM lookupNodeAddress (ndName, ndAddr) + remoteAddresses <- forM targets lookupTarget traceDebug $ "******* Tx generator, launching Tx peers: " ++ show (NE.length remoteAddresses) ++ " of them" @@ -134,20 +156,27 @@ walletBenchmark txStreamRef <- newMVar $ StreamActive txSource allAsyncs <- forM (zip reportRefs $ NE.toList remoteAddresses) $ - \(reportRef, remoteAddr) -> do - let errorHandler = handleTxSubmissionClientError traceSubmit remoteAddr reportRef errorPolicy + \(reportRef, remoteInfo@(remoteName, remoteAddrInfo)) -> do + let errorHandler = handleTxSubmissionClientError traceSubmit remoteInfo reportRef errorPolicy client = txSubmissionClient traceN2N traceSubmit (txStreamSource txStreamRef tpsThrottle) (submitSubmissionThreadStats reportRef) - async $ handle errorHandler (connectClient remoteAddr client) + remoteAddrString = show $ addrAddress remoteAddrInfo + asyncThread <- async $ handle errorHandler (connectClient remoteAddrInfo client) + let tid = asyncThreadId asyncThread + labelThread tid $ "txSubmissionClient " ++ show tid ++ + " servicing " ++ remoteName ++ " (" ++ remoteAddrString ++ ")" + pure asyncThread tpsThrottleThread <- async $ do startSending tpsThrottle traceWith traceSubmit $ TraceBenchTxSubDebug "tpsLimitedFeeder : transmitting done" atomically $ sendStop tpsThrottle traceWith traceSubmit $ TraceBenchTxSubDebug "tpsLimitedFeeder : shutdown done" + let tid = asyncThreadId tpsThrottleThread + labelThread tid $ "tpsThrottleThread " ++ show tid let tpsFeederShutdown = do cancel tpsThrottleThread diff --git a/bench/tx-generator/src/Cardano/Benchmarking/Script/Types.hs b/bench/tx-generator/src/Cardano/Benchmarking/Script/Types.hs index ccb1b44551b..a6121a41709 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/Script/Types.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/Script/Types.hs @@ -44,6 +44,7 @@ import Cardano.Api.Shelley import Cardano.Benchmarking.OuroborosImports (SigningKeyFile) import Cardano.Node.Configuration.NodeAddress (NodeIPv4Address) +import Cardano.TxGenerator.Setup.NixService (NodeDescription) import Cardano.TxGenerator.Types import Prelude @@ -177,7 +178,7 @@ data ProtocolParametersSource where deriving (Show, Eq) deriving instance Generic ProtocolParametersSource -type TargetNodes = NonEmpty NodeIPv4Address +type TargetNodes = NonEmpty NodeDescription data SubmitMode where LocalSocket :: SubmitMode diff --git a/bench/tx-generator/src/Cardano/Benchmarking/TpsThrottle.hs b/bench/tx-generator/src/Cardano/Benchmarking/TpsThrottle.hs index 0dfb129d7e7..b1e8c554d20 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/TpsThrottle.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/TpsThrottle.hs @@ -2,15 +2,16 @@ module Cardano.Benchmarking.TpsThrottle where +import Cardano.Benchmarking.Types +import Cardano.TxGenerator.Types (TPSRate) + +import Prelude + import Control.Concurrent (forkIO, threadDelay) import Control.Concurrent.STM as STM import Control.Monad -import Prelude - import qualified Data.Time.Clock as Clock - -import Cardano.Benchmarking.Types -import Cardano.TxGenerator.Types (TPSRate) +import GHC.Conc (labelThread, myThreadId) data Step = Next | Stop deriving (Eq, Show) @@ -109,12 +110,16 @@ test = do consumer :: TpsThrottle -> Int -> IO () consumer t n = do + tid <- myThreadId + labelThread tid $ "TpsThrottle consumer " ++ show n ++ " ThreadId = " ++ show tid s <- atomically $ receiveBlocking t print (n, s) if s == Next then consumer t n else putStrLn $ "Done " ++ show n consumer2 :: TpsThrottle -> Int -> IO () consumer2 t n = do + tid <- myThreadId + labelThread tid $ "TpsThrottle consumer2 " ++ show n ++ " ThreadId = " ++ show tid r <- atomically $ receiveNonBlocking t case r of Just s -> do diff --git a/bench/tx-generator/src/Cardano/TxGenerator/Setup/NixService.hs b/bench/tx-generator/src/Cardano/TxGenerator/Setup/NixService.hs index 7ad4d27a19e..e5d3ebf6140 100644 --- a/bench/tx-generator/src/Cardano/TxGenerator/Setup/NixService.hs +++ b/bench/tx-generator/src/Cardano/TxGenerator/Setup/NixService.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE RecordWildCards #-} @@ -8,6 +9,9 @@ module Cardano.TxGenerator.Setup.NixService ( NixServiceOptions (..) + , NodeDescription (..) + , getKeepaliveTimeout + , getNodeAlias , getNodeConfigFile , setNodeConfigFile , txGenTxParams @@ -20,16 +24,18 @@ import Cardano.Api (AnyCardanoEra, mapFile) import Cardano.CLI.Types.Common (FileDirection (..), SigningKeyFile) import qualified Cardano.Ledger.Coin as L -import Cardano.Node.Configuration.NodeAddress (NodeIPv4Address) +import Cardano.Node.Configuration.NodeAddress (NodeAddress' (..), + NodeHostIPv4Address (..), NodeIPv4Address) import Cardano.Node.Types (AdjustFilePaths (..)) import Cardano.TxGenerator.Internal.Orphans () import Cardano.TxGenerator.Types -import Data.Aeson (FromJSON (..), Options (fieldLabelModifier), (.:), (.:?)) -import qualified Data.Aeson as Aeson (Options, defaultOptions, genericParseJSON, withObject) -import Data.List.NonEmpty (NonEmpty) +import Data.Aeson.Types as Aeson +import Data.Foldable (find) +import Data.Function (on) +import Data.List.NonEmpty (NonEmpty (..)) import Data.Maybe (fromMaybe) -import qualified Data.Time.Clock as Clock (DiffTime) +import qualified Data.Time.Clock as Clock (DiffTime, secondsToDiffTime) import GHC.Generics (Generic) @@ -45,21 +51,61 @@ data NixServiceOptions = NixServiceOptions { , _nix_init_cooldown :: Double , _nix_era :: AnyCardanoEra , _nix_plutus :: Maybe TxGenPlutusParams - , _nix_keepalive :: Maybe Clock.DiffTime + , _nix_keepalive :: Maybe Integer , _nix_nodeConfigFile :: Maybe FilePath , _nix_cardanoTracerSocket :: Maybe FilePath , _nix_sigKey :: SigningKeyFile In , _nix_localNodeSocketPath :: String - , _nix_targetNodes :: NonEmpty NodeIPv4Address + , _nix_targetNodes :: NonEmpty NodeDescription } deriving (Show, Eq) deriving instance Generic NixServiceOptions +-- only works on JSON Object types +data NodeDescription = + NodeDescription { + -- NodeIPAddress would be agnostic to IPv4 vs. IPv6 and likely + -- a small investment here. + ndAddr :: NodeIPv4Address + , ndName :: String + } deriving (Eq, Show, Generic) + +-- { "alias": "foo", "addr": ..., "port": ... } +instance FromJSON NodeDescription where + parseJSON = withObject "NodeDescription" \v -> do + unNodeHostIPv4Address + <- v .: "addr" Key "addr" + naPort <- fmap toEnum $ + v .: "port" Key "port" + let naHostAddress = NodeHostIPv4Address {..} + ndAddr = NodeAddress {..} + ndName <- v .:? "name" Key "name" .!= show ndAddr + pure $ NodeDescription {..} + +instance ToJSON NodeDescription where + toJSON NodeDescription {..} = object + [ "name" .= ndName + , "addr" .= unNodeHostIPv4Address + , "port" .= fromEnum naPort ] where + _addr@NodeAddress {..} = ndAddr + _hostAddr@NodeHostIPv4Address {..} = naHostAddress + + +-- Long GC pauses on target nodes can trigger spurious MVar deadlock +-- detection. Increasing this timeout can help mitigate those errors. +getKeepaliveTimeout :: NixServiceOptions -> Clock.DiffTime +getKeepaliveTimeout = maybe 30 Clock.secondsToDiffTime . _nix_keepalive + +getNodeAlias :: NixServiceOptions -> NodeIPv4Address -> Maybe String +getNodeAlias NixServiceOptions {..} ip = ndName <$> + find ((=:=:= ip) . ndAddr) _nix_targetNodes where + (=:=:=) = (==) `on` naHostAddress + getNodeConfigFile :: NixServiceOptions -> Maybe FilePath getNodeConfigFile = _nix_nodeConfigFile setNodeConfigFile :: NixServiceOptions -> FilePath -> NixServiceOptions -setNodeConfigFile opts filePath = opts {_nix_nodeConfigFile = Just filePath } +setNodeConfigFile opts filePath = opts { _nix_nodeConfigFile = Just filePath } -- dropping the '_nix_ prefix of above Haskell ADT field labels is assumed -- to match JSON attribute names as provided by the Nix service definition diff --git a/nix/nixos/tx-generator-service.nix b/nix/nixos/tx-generator-service.nix index 9e13992205d..1d76c50cb95 100644 --- a/nix/nixos/tx-generator-service.nix +++ b/nix/nixos/tx-generator-service.nix @@ -68,7 +68,7 @@ let capitalise = x: (pkgs.lib.toUpper (__substring 0 1 x)) + __substring 1 99999 x; targetNodesList = targets: __attrValues (__mapAttrs - (name: { ip, port }: { addr = ip; port = port; }) + (name: { ip, port, name }: { addr = ip; port = port; name = name; }) targets); in pkgs.commonLib.defServiceModule (lib: with lib; @@ -114,6 +114,8 @@ in pkgs.commonLib.defServiceModule "Strength of generated load, in TPS."; init_cooldown = opt int 50 "Delay between init and main submissions."; min_utxo_value = opt int 10000000 "Minimum value allowed per UTxO entry"; + keepalive = opt int 30 "Default timeout for keep-alive mini-protocol"; + runScriptFn = opt (functionTo attrs) defaultGeneratorScriptFn "Function accepting this service config and producing the generator run script (a list of command attrsets). Takes effect unless runScript or runScriptFile are specified."; runScript = mayOpt (listOf attrs) diff --git a/nix/workbench/service/generator.nix b/nix/workbench/service/generator.nix index 9688e7bab86..3f347c2a643 100644 --- a/nix/workbench/service/generator.nix +++ b/nix/workbench/service/generator.nix @@ -67,7 +67,7 @@ let targetNodes = __mapAttrs (name: { name, port, ...}@nodeSpec: - { inherit port; + { inherit name port; ip = let ip = nodePublicIP nodeSpec; # getPublicIp resources nodes name in __trace "generator target: ${name}/${ip}:${toString port}" ip; }) From da4d58458c11f1566f80564f7ed5e70efe259819 Mon Sep 17 00:00:00 2001 From: Nadia Yvette Chambers Date: Fri, 10 May 2024 11:38:02 +0000 Subject: [PATCH 4/9] txgen-mvar: basic signal handler This installs a signal handler in Cardano.Benchmarking.Command.runCommand It borrows heavily from the signal handler from cardano-node. --- .../src/Cardano/Benchmarking/Command.hs | 86 +++++++++++++++++-- .../src/Cardano/Benchmarking/GeneratorTx.hs | 49 +++++------ .../src/Cardano/Benchmarking/LogTypes.hs | 37 ++++---- .../src/Cardano/Benchmarking/Script.hs | 71 ++++++++++----- .../src/Cardano/Benchmarking/Script/Core.hs | 12 ++- .../src/Cardano/Benchmarking/Script/Env.hs | 59 ++++++++----- .../Cardano/Benchmarking/Script/Selftest.hs | 33 +++++-- bench/tx-generator/test/Bench.hs | 14 ++- bench/tx-generator/tx-generator.cabal | 7 +- 9 files changed, 259 insertions(+), 109 deletions(-) diff --git a/bench/tx-generator/src/Cardano/Benchmarking/Command.hs b/bench/tx-generator/src/Cardano/Benchmarking/Command.hs index f7ab8c6c261..26c5e3a9e55 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/Command.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/Command.hs @@ -1,8 +1,11 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} - +{-# LANGUAGE StandaloneDeriving #-} {-# OPTIONS_GHC -Wno-all-missed-specialisations -Wno-orphans #-} module Cardano.Benchmarking.Command @@ -12,9 +15,14 @@ module Cardano.Benchmarking.Command ) where +#if !defined(mingw32_HOST_OS) +#define UNIX +#endif + import Cardano.Benchmarking.Compiler (compileOptions) import Cardano.Benchmarking.Script (parseScriptFileAeson, runScript) import Cardano.Benchmarking.Script.Aeson (parseJSONFile, prettyPrint) +import Cardano.Benchmarking.Script.Env as Env (Env (Env, envThreads), mkNewEnv) import Cardano.Benchmarking.Script.Selftest (runSelftest) import Cardano.Benchmarking.Version as Version import Cardano.TxGenerator.PlutusContext (readScriptData) @@ -32,6 +40,28 @@ import Data.Text.IO as T import Options.Applicative as Opt import System.Exit +#ifdef UNIX +import Control.Concurrent as Conc (myThreadId) +import Control.Concurrent.Async as Async (cancelWith) +import Control.Concurrent.STM as STM (readTVar) +import Control.Monad.STM as STM (atomically) + +import Data.Foldable as Fold (forM_) +import Data.List as List (unwords) +import Data.Map as Map (lookup) +import Data.Time.Format as Time (defaultTimeLocale, formatTime) +import Data.Time.Clock.System as Time (getSystemTime, systemToUTCTime) +import System.Posix.Signals as Sig (Handler (CatchInfoOnce), SignalInfo (..), SignalSpecificInfo (..), installHandler, sigINT, sigTERM) +#if MIN_VERSION_base(4,18,0) +import Data.Maybe as Maybe (fromMaybe) +import GHC.Conc.Sync as Conc (threadLabel) +#endif +#endif + +#ifdef UNIX +deriving instance Show SignalInfo +deriving instance Show SignalSpecificInfo +#endif data Command = Json FilePath @@ -42,13 +72,14 @@ data Command runCommand :: IO () runCommand = withIOManager $ \iocp -> do + env <- installSignalHandler cmd <- customExecParser (prefs showHelpOnEmpty) (info commandParser mempty) case cmd of Json file -> do script <- parseScriptFileAeson file - runScript script iocp >>= handleError + runScript env script iocp >>= handleError . fst JsonHL file nodeConfigOverwrite cardanoTracerOverwrite -> do opts <- parseJSONFile fromJSON file finalOpts <- mangleTracerConfig cardanoTracerOverwrite <$> mangleNodeConfig nodeConfigOverwrite opts @@ -60,20 +91,61 @@ runCommand = withIOManager $ \iocp -> do quickTestPlutusDataOrDie finalOpts case compileOptions finalOpts of - Right script -> runScript script iocp >>= handleError - err -> handleError err + Right script -> runScript env script iocp >>= handleError . fst + err -> die $ "tx-generator:Cardano.Command.runCommand JsonHL: " ++ show err Compile file -> do o <- parseJSONFile fromJSON file case compileOptions o of Right script -> BSL.putStr $ prettyPrint script - err -> handleError err - Selftest outFile -> runSelftest iocp outFile >>= handleError + Left err -> die $ "tx-generator:Cardano.Command.runCommand Compile: " ++ show err + Selftest outFile -> runSelftest env iocp outFile >>= handleError VersionCmd -> runVersionCommand where handleError :: Show a => Either a b -> IO () handleError = \case Right _ -> exitSuccess - Left err -> die $ "tx-generator:Cardano.Command: " ++ show err + Left err -> die $ "tx-generator:Cardano.Command.runCommand handleError: " ++ show err + installSignalHandler :: IO Env + installSignalHandler = do + env@Env { .. } <- STM.atomically mkNewEnv + Just abcTVar <- pure $ "tx-submit-benchmark" `Map.lookup` envThreads + abc <- STM.atomically $ STM.readTVar abcTVar + _ <- pure abc +#ifdef UNIX + let signalHandler = Sig.CatchInfoOnce signalHandler' + signalHandler' sigInfo = do + tid <- Conc.myThreadId + Just (throttler, workers, _, _) <- STM.atomically $ STM.readTVar abcTVar + utcTime <- Time.systemToUTCTime <$> Time.getSystemTime + -- It's meant to match Cardano.Tracers.Handlers.Logs.Utils + -- The hope was to avoid the package dependency. + let formatTimeStamp = formatTime' "%Y-%m-%dT%H-%M-%S" + formatTime' = Time.formatTime Time.defaultTimeLocale + timeStamp = formatTimeStamp utcTime +#if MIN_VERSION_base(4,18,0) + maybeLabel <- Conc.threadLabel tid + let labelStr' :: String + labelStr' = fromMaybe "(thread label unset)" maybeLabel +#else + labelStr' = "(base version insufficient to read thread label)" +#endif + labelStr :: String + labelStr = List.unwords [ timeStamp + , labelStr' + , show tid + , "received signal" + , show sigInfo ] + errorToThrow :: IOError + errorToThrow = userError labelStr + + Prelude.putStrLn labelStr + Async.cancelWith throttler errorToThrow + Fold.forM_ workers \work -> do + Async.cancelWith work errorToThrow + Fold.forM_ [Sig.sigINT, Sig.sigTERM] $ \sig -> + Sig.installHandler sig signalHandler Nothing +#endif + pure env mangleNodeConfig :: Maybe FilePath -> NixServiceOptions -> IO NixServiceOptions mangleNodeConfig fp opts = case (getNodeConfigFile opts, fp) of diff --git a/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx.hs b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx.hs index 13a6b94040e..6de4f1cccd0 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} @@ -35,30 +36,29 @@ import Cardano.TxGenerator.Types (NumberOfTxs, TPSRate, TxGenError (.. import Prelude (String) -import qualified Control.Concurrent.STM as STM +import qualified Control.Concurrent.STM.TMVar as STM (newEmptyTMVar) +import qualified Control.Monad.STM as STM (atomically) import qualified Data.List as List (unwords) import qualified Data.List.NonEmpty as NE import Data.Text (pack) import qualified Data.Time.Clock as Clock import Data.Tuple.Extra (secondM) -import GHC.Conc (labelThread) +import GHC.Conc as Conc (labelThread) +-- For some reason, stylish-haskell wants to delete this. #if MIN_VERSION_base(4,18,0) --- fromMaybe is imported via Cardano.Prelude --- However, this configuration actually uses it. --- import Data.Maybe (fromMaybe) -import GHC.Conc.Sync (threadLabel) +--- fromMaybe is imported via Cardano.Prelude +--- However, this configuration actually uses it. +--- import Data.Maybe (fromMaybe) +import GHC.Conc.Sync as Conc (threadLabel) #endif - import Network.Socket (AddrInfo (..), AddrInfoFlag (..), Family (..), SocketType (Stream), addrFamily, addrFlags, addrSocketType, defaultHints, getAddrInfo) -type AsyncBenchmarkControl = (Async (), [Async ()], IO SubmissionSummary, IO ()) - waitBenchmark :: Trace IO (TraceBenchTxSubmit TxId) -> AsyncBenchmarkControl -> ExceptT TxGenError IO () waitBenchmark traceSubmit (feeder, workers, mkSummary, _) = liftIO $ do - mapM_ waitCatch (feeder : workers) + mapM_ waitCatch $ feeder : workers traceWith traceSubmit . TraceBenchTxSubSummary =<< mkSummary lookupNodeAddress :: NodeIPv4Address -> IO AddrInfo @@ -91,7 +91,7 @@ handleTxSubmissionClientError (SomeException err) = do tid <- myThreadId #if MIN_VERSION_base(4,18,0) - label <- threadLabel tid + label <- Conc.threadLabel tid let labelStr = fromMaybe "(unlabelled)" label #else let labelStr = "(base version too low to examine thread labels)" @@ -152,35 +152,36 @@ walletBenchmark startTime <- Clock.getCurrentTime tpsThrottle <- newTpsThrottle 32 count tpsRate - reportRefs <- STM.atomically $ replicateM (fromIntegral numTargets) STM.newEmptyTMVar - txStreamRef <- newMVar $ StreamActive txSource - allAsyncs <- forM (zip reportRefs $ NE.toList remoteAddresses) $ - \(reportRef, remoteInfo@(remoteName, remoteAddrInfo)) -> do - let errorHandler = handleTxSubmissionClientError traceSubmit remoteInfo reportRef errorPolicy - client = txSubmissionClient + + reportRefs <- atomically do replicateM (fromIntegral numTargets) STM.newEmptyTMVar + let asyncList = zip reportRefs $ NE.toList remoteAddresses + + allAsyncs <- forM asyncList \(reportRef, remoteInfo@(remoteName, remoteAddrInfo)) -> do + let errorHandler = handleTxSubmissionClientError traceSubmit remoteInfo reportRef errorPolicy + client = txSubmissionClient traceN2N traceSubmit (txStreamSource txStreamRef tpsThrottle) (submitSubmissionThreadStats reportRef) - remoteAddrString = show $ addrAddress remoteAddrInfo - asyncThread <- async $ handle errorHandler (connectClient remoteAddrInfo client) - let tid = asyncThreadId asyncThread - labelThread tid $ "txSubmissionClient " ++ show tid ++ + remoteAddrString = show $ addrAddress remoteAddrInfo + asyncThread <- async do handle errorHandler $ connectClient remoteAddrInfo client + let tid = asyncThreadId asyncThread + Conc.labelThread tid $ "txSubmissionClient " ++ show tid ++ " servicing " ++ remoteName ++ " (" ++ remoteAddrString ++ ")" - pure asyncThread + pure asyncThread tpsThrottleThread <- async $ do startSending tpsThrottle traceWith traceSubmit $ TraceBenchTxSubDebug "tpsLimitedFeeder : transmitting done" - atomically $ sendStop tpsThrottle + STM.atomically $ sendStop tpsThrottle traceWith traceSubmit $ TraceBenchTxSubDebug "tpsLimitedFeeder : shutdown done" let tid = asyncThreadId tpsThrottleThread labelThread tid $ "tpsThrottleThread " ++ show tid let tpsFeederShutdown = do cancel tpsThrottleThread - liftIO $ atomically $ sendStop tpsThrottle + liftIO $ STM.atomically $ sendStop tpsThrottle return (tpsThrottleThread, allAsyncs, mkSubmissionSummary threadName startTime reportRefs, tpsFeederShutdown) where diff --git a/bench/tx-generator/src/Cardano/Benchmarking/LogTypes.hs b/bench/tx-generator/src/Cardano/Benchmarking/LogTypes.hs index eb04bcd9d11..6ee89ae6415 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/LogTypes.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/LogTypes.hs @@ -12,7 +12,8 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Cardano.Benchmarking.LogTypes - ( BenchTracers(..) + ( AsyncBenchmarkControl + , BenchTracers(..) , NodeToNodeSubmissionTrace(..) , SendRecvConnect , SendRecvTxSubmission2 @@ -20,39 +21,35 @@ module Cardano.Benchmarking.LogTypes , TraceBenchTxSubmit(..) ) where -import Prelude - -import Data.Text -import Data.Time.Clock (DiffTime, NominalDiffTime) - -import GHC.Generics - - import Cardano.Api -import qualified Codec.CBOR.Term as CBOR - -import Network.Mux (WithMuxBearer (..)) +import Cardano.Benchmarking.OuroborosImports +import Cardano.Benchmarking.Types +import Cardano.Benchmarking.Version as Version import Cardano.Logging - 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 Cardano.TxGenerator.PlutusContext (PlutusBudgetSummary) +import Cardano.TxGenerator.Types (TPSRate) import Ouroboros.Consensus.Ledger.SupportsMempool (GenTx, GenTxId) import Ouroboros.Network.Driver (TraceSendRecv (..)) import Ouroboros.Network.NodeToNode (NodeToNodeVersion, RemoteConnectionId) import Ouroboros.Network.Protocol.Handshake.Type (Handshake) import Ouroboros.Network.Protocol.TxSubmission2.Type (TxSubmission2) -import Cardano.Benchmarking.Types -import Cardano.Benchmarking.Version as Version -import Cardano.TxGenerator.PlutusContext (PlutusBudgetSummary) -import Cardano.TxGenerator.Types (TPSRate) +import Prelude + +import qualified Codec.CBOR.Term as CBOR +import qualified Control.Concurrent.Async as Async (Async) +import Data.Text +import Data.Time.Clock (DiffTime, NominalDiffTime) +import GHC.Generics +import Network.Mux (WithMuxBearer (..)) + +type AsyncBenchmarkControl = (Async.Async (), [Async.Async ()], IO SubmissionSummary, IO ()) data BenchTracers = BenchTracers diff --git a/bench/tx-generator/src/Cardano/Benchmarking/Script.hs b/bench/tx-generator/src/Cardano/Benchmarking/Script.hs index 636dc248b38..20d57cb4c16 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/Script.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/Script.hs @@ -1,5 +1,8 @@ +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE RecordWildCards #-} + module Cardano.Benchmarking.Script ( Script , runScript @@ -7,45 +10,71 @@ module Cardano.Benchmarking.Script ) where +import Cardano.Benchmarking.LogTypes +import Cardano.Benchmarking.Script.Action +import Cardano.Benchmarking.Script.Aeson (parseScriptFileAeson) +import Cardano.Benchmarking.Script.Core (setProtocolParameters) +import qualified Cardano.Benchmarking.Script.Env as Env (ActionM, Env (Env, envThreads), + Error (TxGenError), getEnvThreads, runActionMEnv, traceError) +import Cardano.Benchmarking.Script.Types +import qualified Cardano.TxGenerator.Types as Types (TxGenError (..)) +import Ouroboros.Network.NodeToClient (IOManager) + import Prelude import Control.Concurrent (threadDelay) +import Control.Concurrent.STM.TVar as STM (readTVar) import Control.Monad import Control.Monad.IO.Class +import Control.Monad.STM as STM (atomically) +import Control.Monad.Trans.Except as Except (throwE) +import qualified Data.List as List (unwords) +import qualified Data.Map as Map (lookup) import System.Mem (performGC) -import Ouroboros.Network.NodeToClient (IOManager) - -import Cardano.Benchmarking.Script.Action -import Cardano.Benchmarking.Script.Aeson (parseScriptFileAeson) -import Cardano.Benchmarking.Script.Core (setProtocolParameters) -import Cardano.Benchmarking.Script.Env -import Cardano.Benchmarking.Script.Types - type Script = [Action] -runScript :: Script -> IOManager -> IO (Either Error ()) -runScript script iom = do +runScript :: Env.Env -> Script -> IOManager -> IO (Either Env.Error (), AsyncBenchmarkControl) +runScript env script iom = do result <- go performGC threadDelay $ 150 * 1_000 return result where - go = runActionM execScript iom >>= \case - (Right a , s , ()) -> do - cleanup s shutDownLogging - return $ Right a - (Left err , s , ()) -> do - cleanup s (traceError (show err) >> shutDownLogging) - return $ Left err + go :: IO (Either Env.Error (), AsyncBenchmarkControl) + go = Env.runActionMEnv env execScript iom >>= \case + (Right abc, env', ()) -> do + cleanup env' shutDownLogging + pure (Right (), abc) + (Left err, env'@Env.Env { .. }, ()) -> do + cleanup env' (Env.traceError (show err) >> shutDownLogging) + case "tx-submit-benchmark" `Map.lookup` envThreads of + Just abcTVar -> do + abcMaybe <- STM.atomically $ STM.readTVar abcTVar + case abcMaybe of + Just abc -> pure (Left err, abc) + Nothing -> error $ List.unwords + [ "Cardano.Benchmarking.Script.runScript:" + , "AsyncBenchmarkControl uninitialized" ] + Nothing -> error $ List.unwords + [ "Cardano.Benchmarking.Script.runScript:" + , "AsyncBenchmarkControl absent from map" ] where - cleanup s a = void $ runActionMEnv s a iom - + cleanup :: Env.Env -> Env.ActionM () -> IO () + cleanup env' acts = void $ Env.runActionMEnv env' acts iom + execScript :: Env.ActionM AsyncBenchmarkControl execScript = do setProtocolParameters QueryLocalNode forM_ script action + abcMaybe <- Env.getEnvThreads "tx-submit-benchmark" + case abcMaybe of + Nothing -> throwE $ Env.TxGenError $ Types.TxGenError $ + List.unwords + [ "Cardano.Benchmarking.Script.runScript:" + , "AsyncBenchmarkControl absent from map in execScript" ] + Just abc -> pure abc -shutDownLogging :: ActionM () +shutDownLogging :: Env.ActionM () shutDownLogging = do - traceError "QRT Last Message. LoggingLayer going to shutdown. 73 . . . ." + Env.traceError "QRT Last Message. LoggingLayer shutting down ..." liftIO $ threadDelay $ 350 * 1_000 diff --git a/bench/tx-generator/src/Cardano/Benchmarking/Script/Core.hs b/bench/tx-generator/src/Cardano/Benchmarking/Script/Core.hs index 8d78e4a9790..4ece43785c2 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/Script/Core.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/Script/Core.hs @@ -18,7 +18,6 @@ module Cardano.Benchmarking.Script.Core where -import "contra-tracer" Control.Tracer (Tracer (..)) import Cardano.Api import Cardano.Api.Shelley (PlutusScriptOrReferenceInput (..), ProtocolParameters, ShelleyLedgerEra, convertToLedgerProtocolParameters, protocolParamMaxTxExUnits, @@ -59,6 +58,7 @@ import Prelude import Control.Concurrent (threadDelay) import Control.Monad +import "contra-tracer" Control.Tracer (Tracer (..)) import Data.ByteString.Lazy.Char8 as BSL (writeFile) import Data.Ratio ((%)) import qualified Data.Text as Text (unpack) @@ -144,11 +144,17 @@ getConnectClient = do (protocolToCodecConfig protocol) networkMagic waitBenchmark :: String -> ActionM () -waitBenchmark n = getEnvThreads n >>= waitBenchmarkCore +waitBenchmark n = do + abcMaybe <- getEnvThreads n + case abcMaybe of + Just abc -> waitBenchmarkCore abc + Nothing -> do + throwE . Env.TxGenError . TxGenError $ + ("waitBenchmark: missing AsyncBenchmarkControl" :: String) cancelBenchmark :: String -> ActionM () cancelBenchmark n = do - ctl@(_, _ , _ , shutdownAction) <- getEnvThreads n + Just ctl@(_, _ , _ , shutdownAction) <- getEnvThreads n liftIO shutdownAction waitBenchmarkCore ctl diff --git a/bench/tx-generator/src/Cardano/Benchmarking/Script/Env.hs b/bench/tx-generator/src/Cardano/Benchmarking/Script/Env.hs index 91400b2eb0f..cc47d4e65db 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/Script/Env.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/Script/Env.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} @@ -26,7 +27,9 @@ ran into circular dependency issues during the above transition. -} module Cardano.Benchmarking.Script.Env ( ActionM - , Error(..) + , Env (Env, envThreads) + , Error (..) + , mkNewEnv , runActionM , runActionMEnv , liftTxGenError @@ -57,20 +60,8 @@ module Cardano.Benchmarking.Script.Env ( , setEnvSummary ) where -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 Data.Map.Strict (Map) -import qualified Data.Map.Strict as Map -import qualified Data.Text as Text -import Prelude - import Cardano.Api (File (..), SocketPath) -import Cardano.Logging - import Cardano.Benchmarking.GeneratorTx import qualified Cardano.Benchmarking.LogTypes as Tracer import Cardano.Benchmarking.OuroborosImports (NetworkId, PaymentKey, ShelleyGenesis, @@ -78,11 +69,24 @@ import Cardano.Benchmarking.OuroborosImports (NetworkId, PaymentKey, S import Cardano.Benchmarking.Script.Types import Cardano.Benchmarking.Wallet import Cardano.Ledger.Crypto (StandardCrypto) +import Cardano.Logging import Cardano.Node.Protocol.Types (SomeConsensusProtocol) -import Ouroboros.Network.NodeToClient (IOManager) - import Cardano.TxGenerator.PlutusContext (PlutusBudgetSummary) import Cardano.TxGenerator.Types (TxGenError (..)) +import Ouroboros.Network.NodeToClient (IOManager) + +import Prelude + +import Control.Concurrent.STM (STM) +import qualified Control.Concurrent.STM as STM (TVar, atomically, newTVar, readTVar, writeTVar) +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 Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import qualified Data.Text as Text -- | The 'Env' type represents the state maintained while executing @@ -98,7 +102,7 @@ data Env = Env { -- | 'Cardano.Api.ProtocolParameters' is ultimately , envNetworkId :: Maybe NetworkId , envSocketPath :: Maybe FilePath , envKeys :: Map String (SigningKey PaymentKey) - , envThreads :: Map String AsyncBenchmarkControl + , envThreads :: Map String (STM.TVar (Maybe AsyncBenchmarkControl)) , envWallets :: Map String WalletRef , envSummary :: Maybe PlutusBudgetSummary } @@ -119,13 +123,20 @@ emptyEnv = Env { protoParams = Nothing , envSummary = Nothing } +mkNewEnv :: STM Env +mkNewEnv = do + ctl <- STM.newTVar Nothing + pure emptyEnv { envThreads = "tx-submit-benchmark" `Map.singleton` ctl } + -- | This abbreviates an `ExceptT` and `RWST` with particular types -- used as parameters. type ActionM a = ExceptT Error (RWST IOManager () Env IO) a -- | This runs an `ActionM` starting with an empty `Env`. runActionM :: ActionM ret -> IOManager -> IO (Either Error ret, Env, ()) -runActionM = runActionMEnv emptyEnv +runActionM actions ioManager = do + env <- STM.atomically mkNewEnv + runActionMEnv env actions ioManager -- | This runs an `ActionM` starting with the `Env` being passed. runActionMEnv :: Env -> ActionM ret -> IOManager -> IO (Either Error ret, Env, ()) @@ -196,7 +207,13 @@ setEnvSocketPath val = modifyEnv (\e -> e { envSocketPath = Just val }) -- | Write accessor for `envThreads`. setEnvThreads :: String -> AsyncBenchmarkControl -> ActionM () -setEnvThreads key val = modifyEnv (\e -> e { envThreads = Map.insert key val (envThreads e) }) +setEnvThreads key val = do + threadMap <- lift $ RWS.gets envThreads + case Map.lookup key threadMap of + Nothing -> do + abcTVar <- liftIO do STM.atomically do STM.newTVar $ Just val + modifyEnv (\env -> env { envThreads = Map.insert key abcTVar threadMap }) + Just abcTVar -> liftIO do STM.atomically $ abcTVar `STM.writeTVar` Just val -- | Write accessor for `envWallets`. setEnvWallets :: String -> WalletRef -> ActionM () @@ -250,8 +267,10 @@ getEnvSocketPath :: ActionM SocketPath getEnvSocketPath = File <$> getEnvVal envSocketPath "SocketPath" -- | Read accessor for `envThreads`. -getEnvThreads :: String -> ActionM AsyncBenchmarkControl -getEnvThreads = getEnvMap envThreads +getEnvThreads :: String -> ActionM (Maybe AsyncBenchmarkControl) +getEnvThreads key = do + abcTVar <- getEnvMap envThreads key + liftIO do STM.atomically $ STM.readTVar abcTVar -- | Read accessor for `envWallets`. getEnvWallets :: String -> ActionM WalletRef diff --git a/bench/tx-generator/src/Cardano/Benchmarking/Script/Selftest.hs b/bench/tx-generator/src/Cardano/Benchmarking/Script/Selftest.hs index 384e3240a17..0c1d47a750f 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/Script/Selftest.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/Script/Selftest.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} {-| Module : Cardano.Benchmarking.Script.Selftest Description : Run self-tests using statically-defined data. @@ -9,11 +9,12 @@ It actually does use a protocol file taken in from IO. module Cardano.Benchmarking.Script.Selftest where -import Cardano.Api +import Cardano.Api hiding (Env) import Cardano.Benchmarking.Script.Action import Cardano.Benchmarking.Script.Aeson (prettyPrint) -import Cardano.Benchmarking.Script.Env as Script +import Cardano.Benchmarking.Script.Env as Env (Env (Env, envThreads)) +import qualified Cardano.Benchmarking.Script.Env as Env (Error, runActionMEnv, setBenchTracers) import Cardano.Benchmarking.Script.Types import Cardano.Benchmarking.Tracer (initNullTracers) import qualified Cardano.Ledger.Coin as L @@ -23,9 +24,12 @@ import Ouroboros.Network.NodeToClient (IOManager) import Prelude +import qualified Control.Concurrent.STM as STM (atomically, readTVar) import Control.Monad import qualified Data.ByteString.Lazy.Char8 as BSL import Data.Either (fromRight) +import qualified Data.List as List (unwords) +import qualified Data.Map as Map (lookup) import Data.String import Paths_tx_generator @@ -37,17 +41,28 @@ import Paths_tx_generator -- transaction 'Streaming.Stream' that -- 'Cardano.Benchmarking.Script.Core.submitInEra' -- does 'show' and 'writeFile' on. -runSelftest :: IOManager -> Maybe FilePath -> IO (Either Script.Error ()) -runSelftest iom outFile = do +runSelftest :: Env -> IOManager -> Maybe FilePath -> IO (Either Env.Error ()) +runSelftest env iom outFile = do protocolFile <- getDataFileName "data/protocol-parameters.json" let submitMode = maybe DiscardTX DumpToFile outFile fullScript = do - setBenchTracers initNullTracers + Env.setBenchTracers initNullTracers forM_ (testScript protocolFile submitMode) action - runActionM fullScript iom >>= \case - (Right a , _ , ()) -> return $ Right a - (Left err , _ , ()) -> return $ Left err + (result, Env { envThreads }, ()) <- Env.runActionMEnv env fullScript iom + case "tx-submit-benchmark" `Map.lookup` envThreads of + Nothing -> do + error $ List.unwords + [ "Cardano.Benchmarking.Script.Selftest.runSelftest:" + , "thread state uninitialized" ] + Just abcTVar -> do + abcMaybe <- STM.atomically $ STM.readTVar abcTVar + case abcMaybe of + Nothing -> pure result + Just _ -> do + error $ List.unwords + [ "Cardano.Benchmarking.Script.Selftest.runSelftest:" + , "thread state spuriously initialized" ] -- | 'printJSON' prints out the list of actions using Aeson. -- It has no callers within @cardano-node@. diff --git a/bench/tx-generator/test/Bench.hs b/bench/tx-generator/test/Bench.hs index c9d7c0c7ac1..d22a4dc55c5 100644 --- a/bench/tx-generator/test/Bench.hs +++ b/bench/tx-generator/test/Bench.hs @@ -2,16 +2,22 @@ {-# LANGUAGE Trustworthy #-} module Main (main) where -import Prelude -import Criterion.Main +import Cardano.Benchmarking.Script.Env (mkNewEnv) import Cardano.Benchmarking.Script.Selftest +import Prelude + +import Control.Monad.STM (atomically) + +import Criterion.Main hiding (env) + main :: IO () main = defaultMain [ bgroup "cardano-tx-generator-integration" [ bench "tx-gen" $ whnfIO $ do - runSelftest (error "noIOManager") Nothing >>= \case - Right _ -> return () + env <- atomically mkNewEnv + runSelftest env (error "noIOManager") Nothing >>= \case + Right _ -> pure () Left err -> error $ show err ] ] diff --git a/bench/tx-generator/tx-generator.cabal b/bench/tx-generator/tx-generator.cabal index 21577534b44..3bf98786797 100644 --- a/bench/tx-generator/tx-generator.cabal +++ b/bench/tx-generator/tx-generator.cabal @@ -29,8 +29,12 @@ common with-library build-depends: plutus-scripts-bench ^>= 1.0.4 cpp-options: -DWITH_LIBRARY +common maybe-unix + if !os(windows) + build-depends: unix + library - import: project-config, with-library + import: project-config, with-library, maybe-unix hs-source-dirs: src ghc-options: -Wall @@ -228,6 +232,7 @@ benchmark tx-generator-bench build-depends: base , criterion + , stm , tx-generator default-language: Haskell2010 From aca615e0226e442ccc178e0f7bc429fcbfdff1b8 Mon Sep 17 00:00:00 2001 From: Nadia Yvette Chambers Date: Thu, 23 May 2024 04:22:08 +0000 Subject: [PATCH 5/9] txgen-mvar: rework AsyncBenchmarkControl I. make AsyncBenchmarkControl a record The type alias of a tuple was not very mnemonic or self-explanatory. This replaces it with a record and haddock documents its fields. II. use ABC to cancel threads The AsyncBenchmarkControl that should be initialized by the time a signal is received is fetched from the TVar and unpacked to be used to throw exceptions to the other threads. The other threads can now catch the exceptions in order to carry out orderly shutdowns in the sequel. III. use TVar for Env AsyncBenchmarkControl In order to thread the AsyncBenchmarkControl through the contexts surrounding the creation and destruction of the Async structures and overall container, this stores a TVar (Maybe AsyncBenchmarkControl) as a value in a Map where previously it was just AsyncBenchmarkControl. The idea is to use the reference to it to be able to use it in the context of a signal handler by packaging the reference data with the code pointer in a partial application or monadic context or similar. With that data in hand, it's just a matter of iterating over the threads and reaping them all. --- .../src/Cardano/Benchmarking/Command.hs | 21 +++-- .../src/Cardano/Benchmarking/Compiler.hs | 4 +- .../src/Cardano/Benchmarking/GeneratorTx.hs | 23 +++-- .../Benchmarking/GeneratorTx/Submission.hs | 5 +- .../src/Cardano/Benchmarking/LogTypes.hs | 17 +++- .../src/Cardano/Benchmarking/Script.hs | 16 ++-- .../src/Cardano/Benchmarking/Script/Action.hs | 13 ++- .../src/Cardano/Benchmarking/Script/Core.hs | 29 +++--- .../src/Cardano/Benchmarking/Script/Env.hs | 35 +++----- .../Cardano/Benchmarking/Script/Selftest.hs | 17 ++-- .../src/Cardano/Benchmarking/Script/Types.hs | 8 +- bench/tx-generator/test/script.json | 89 +++---------------- 12 files changed, 98 insertions(+), 179 deletions(-) diff --git a/bench/tx-generator/src/Cardano/Benchmarking/Command.hs b/bench/tx-generator/src/Cardano/Benchmarking/Command.hs index 26c5e3a9e55..da36e064694 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/Command.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/Command.hs @@ -20,6 +20,7 @@ where #endif import Cardano.Benchmarking.Compiler (compileOptions) +import Cardano.Benchmarking.LogTypes (AsyncBenchmarkControl (..)) import Cardano.Benchmarking.Script (parseScriptFileAeson, runScript) import Cardano.Benchmarking.Script.Aeson (parseJSONFile, prettyPrint) import Cardano.Benchmarking.Script.Env as Env (Env (Env, envThreads), mkNewEnv) @@ -48,7 +49,6 @@ import Control.Monad.STM as STM (atomically) import Data.Foldable as Fold (forM_) import Data.List as List (unwords) -import Data.Map as Map (lookup) import Data.Time.Format as Time (defaultTimeLocale, formatTime) import Data.Time.Clock.System as Time (getSystemTime, systemToUTCTime) import System.Posix.Signals as Sig (Handler (CatchInfoOnce), SignalInfo (..), SignalSpecificInfo (..), installHandler, sigINT, sigTERM) @@ -108,14 +108,12 @@ runCommand = withIOManager $ \iocp -> do installSignalHandler :: IO Env installSignalHandler = do env@Env { .. } <- STM.atomically mkNewEnv - Just abcTVar <- pure $ "tx-submit-benchmark" `Map.lookup` envThreads - abc <- STM.atomically $ STM.readTVar abcTVar + abc <- STM.atomically $ STM.readTVar envThreads _ <- pure abc #ifdef UNIX let signalHandler = Sig.CatchInfoOnce signalHandler' signalHandler' sigInfo = do tid <- Conc.myThreadId - Just (throttler, workers, _, _) <- STM.atomically $ STM.readTVar abcTVar utcTime <- Time.systemToUTCTime <$> Time.getSystemTime -- It's meant to match Cardano.Tracers.Handlers.Logs.Utils -- The hope was to avoid the package dependency. @@ -139,9 +137,18 @@ runCommand = withIOManager $ \iocp -> do errorToThrow = userError labelStr Prelude.putStrLn labelStr - Async.cancelWith throttler errorToThrow - Fold.forM_ workers \work -> do - Async.cancelWith work errorToThrow + mABC <- STM.atomically $ STM.readTVar envThreads + case mABC of + Nothing -> do + -- Catching a signal at this point makes it a higher than + -- average risk of the tracer not being initialized, so + -- this pursues some alternatives. + let errMsg = "Signal received before AsyncBenchmarkControl creation." + Prelude.putStrLn errMsg + Just AsyncBenchmarkControl { .. } -> do + abcFeeder `Async.cancelWith` errorToThrow + Fold.forM_ abcWorkers \work -> do + work `Async.cancelWith` errorToThrow Fold.forM_ [Sig.sigINT, Sig.sigTERM] $ \sig -> Sig.installHandler sig signalHandler Nothing #endif diff --git a/bench/tx-generator/src/Cardano/Benchmarking/Compiler.hs b/bench/tx-generator/src/Cardano/Benchmarking/Compiler.hs index c448828a34b..6881f9ab428 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/Compiler.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/Compiler.hs @@ -201,11 +201,11 @@ benchmarkingPhase wallet collateralWallet = do payMode = PayToAddr keyNameBenchmarkDone doneWallet submitMode = if debugMode then LocalSocket - else Benchmark targetNodes "tx-submit-benchmark" tps txCount + else Benchmark targetNodes tps txCount generator = Take txCount $ Cycle $ NtoM wallet payMode inputs outputs (Just $ txParamAddTxSize txParams) collateralWallet emit $ Submit era submitMode txParams generator unless debugMode $ do - emit $ WaitBenchmark "tx-submit-benchmark" + emit WaitBenchmark return doneWallet data Fees = Fees { diff --git a/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx.hs b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx.hs index 6de4f1cccd0..11574e7e28b 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx.hs @@ -57,9 +57,9 @@ import Network.Socket (AddrInfo (..), AddrInfoFlag (..), Family (..), waitBenchmark :: Trace IO (TraceBenchTxSubmit TxId) -> AsyncBenchmarkControl -> ExceptT TxGenError IO () -waitBenchmark traceSubmit (feeder, workers, mkSummary, _) = liftIO $ do - mapM_ waitCatch $ feeder : workers - traceWith traceSubmit . TraceBenchTxSubSummary =<< mkSummary +waitBenchmark traceSubmit AsyncBenchmarkControl { .. } = liftIO $ do + mapM_ waitCatch $ abcFeeder : abcWorkers + traceWith traceSubmit . TraceBenchTxSubSummary =<< abcSummary lookupNodeAddress :: NodeIPv4Address -> IO AddrInfo lookupNodeAddress node = do @@ -114,7 +114,6 @@ walletBenchmark :: forall era. IsShelleyBasedEra era => Trace IO (TraceBenchTxSubmit TxId) -> Trace IO NodeToNodeSubmissionTrace -> ConnectClient - -> String -> NonEmpty NodeDescription -> TPSRate -> SubmissionErrorPolicy @@ -132,7 +131,6 @@ walletBenchmark traceSubmit traceN2N connectClient - threadName targets tpsRate errorPolicy @@ -156,8 +154,7 @@ walletBenchmark reportRefs <- atomically do replicateM (fromIntegral numTargets) STM.newEmptyTMVar let asyncList = zip reportRefs $ NE.toList remoteAddresses - - allAsyncs <- forM asyncList \(reportRef, remoteInfo@(remoteName, remoteAddrInfo)) -> do + abcWorkers <- forM asyncList \(reportRef, remoteInfo@(remoteName, remoteAddrInfo)) -> do let errorHandler = handleTxSubmissionClientError traceSubmit remoteInfo reportRef errorPolicy client = txSubmissionClient traceN2N @@ -171,19 +168,19 @@ walletBenchmark " servicing " ++ remoteName ++ " (" ++ remoteAddrString ++ ")" pure asyncThread - tpsThrottleThread <- async $ do + abcFeeder <- async $ do startSending tpsThrottle traceWith traceSubmit $ TraceBenchTxSubDebug "tpsLimitedFeeder : transmitting done" STM.atomically $ sendStop tpsThrottle traceWith traceSubmit $ TraceBenchTxSubDebug "tpsLimitedFeeder : shutdown done" - let tid = asyncThreadId tpsThrottleThread + let tid = asyncThreadId abcFeeder labelThread tid $ "tpsThrottleThread " ++ show tid - let tpsFeederShutdown = do - cancel tpsThrottleThread - liftIO $ STM.atomically $ sendStop tpsThrottle + let abcShutdown = do + cancel abcFeeder + liftIO . STM.atomically $ sendStop tpsThrottle - return (tpsThrottleThread, allAsyncs, mkSubmissionSummary threadName startTime reportRefs, tpsFeederShutdown) + pure AsyncBenchmarkControl { abcSummary = mkSubmissionSummary startTime reportRefs, .. } where traceDebug :: String -> IO () traceDebug = traceWith traceSubmit . TraceBenchTxSubDebug diff --git a/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/Submission.hs b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/Submission.hs index 157c481b924..e2d98eddf78 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/Submission.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/Submission.hs @@ -95,11 +95,10 @@ submitSubmissionThreadStats reportRef strStats = do return () mkSubmissionSummary :: - String - -> UTCTime + UTCTime -> [ReportRef] -> IO SubmissionSummary -mkSubmissionSummary ssThreadName startTime reportsRefs +mkSubmissionSummary startTime reportsRefs = do results <- mapM (STM.atomically . STM.readTMVar) reportsRefs let (failures, reports) = partitionEithers results diff --git a/bench/tx-generator/src/Cardano/Benchmarking/LogTypes.hs b/bench/tx-generator/src/Cardano/Benchmarking/LogTypes.hs index 6ee89ae6415..ba20d771257 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/LogTypes.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/LogTypes.hs @@ -12,7 +12,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Cardano.Benchmarking.LogTypes - ( AsyncBenchmarkControl + ( AsyncBenchmarkControl (..) , BenchTracers(..) , NodeToNodeSubmissionTrace(..) , SendRecvConnect @@ -49,7 +49,17 @@ import Data.Time.Clock (DiffTime, NominalDiffTime) import GHC.Generics import Network.Mux (WithMuxBearer (..)) -type AsyncBenchmarkControl = (Async.Async (), [Async.Async ()], IO SubmissionSummary, IO ()) +data AsyncBenchmarkControl = + AsyncBenchmarkControl + { abcFeeder :: Async.Async () + -- ^ The thread to feed transactions, also called a throttler. + , abcWorkers :: [Async.Async ()] + -- ^ The per-node transaction submission threads. + , abcSummary :: IO SubmissionSummary + -- ^ IO action to emit a summary. + , abcShutdown :: IO () + -- ^ IO action to shut down the feeder thread. + } data BenchTracers = BenchTracers @@ -99,8 +109,7 @@ data TraceBenchTxSubmit txid data SubmissionSummary = SubmissionSummary - { ssThreadName :: !String - , ssTxSent :: !Sent + { ssTxSent :: !Sent , ssTxUnavailable :: !Unav , ssElapsed :: !NominalDiffTime , ssEffectiveTps :: !TPSRate diff --git a/bench/tx-generator/src/Cardano/Benchmarking/Script.hs b/bench/tx-generator/src/Cardano/Benchmarking/Script.hs index 20d57cb4c16..d69801b2d7c 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/Script.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/Script.hs @@ -29,7 +29,6 @@ import Control.Monad.IO.Class import Control.Monad.STM as STM (atomically) import Control.Monad.Trans.Except as Except (throwE) import qualified Data.List as List (unwords) -import qualified Data.Map as Map (lookup) import System.Mem (performGC) type Script = [Action] @@ -48,17 +47,12 @@ runScript env script iom = do pure (Right (), abc) (Left err, env'@Env.Env { .. }, ()) -> do cleanup env' (Env.traceError (show err) >> shutDownLogging) - case "tx-submit-benchmark" `Map.lookup` envThreads of - Just abcTVar -> do - abcMaybe <- STM.atomically $ STM.readTVar abcTVar - case abcMaybe of - Just abc -> pure (Left err, abc) - Nothing -> error $ List.unwords - [ "Cardano.Benchmarking.Script.runScript:" - , "AsyncBenchmarkControl uninitialized" ] + abcMaybe <- STM.atomically $ STM.readTVar envThreads + case abcMaybe of + Just abc -> pure (Left err, abc) Nothing -> error $ List.unwords [ "Cardano.Benchmarking.Script.runScript:" - , "AsyncBenchmarkControl absent from map" ] + , "AsyncBenchmarkControl uninitialized" ] where cleanup :: Env.Env -> Env.ActionM () -> IO () cleanup env' acts = void $ Env.runActionMEnv env' acts iom @@ -66,7 +60,7 @@ runScript env script iom = do execScript = do setProtocolParameters QueryLocalNode forM_ script action - abcMaybe <- Env.getEnvThreads "tx-submit-benchmark" + abcMaybe <- Env.getEnvThreads case abcMaybe of Nothing -> throwE $ Env.TxGenError $ Types.TxGenError $ List.unwords diff --git a/bench/tx-generator/src/Cardano/Benchmarking/Script/Action.hs b/bench/tx-generator/src/Cardano/Benchmarking/Script/Action.hs index 45a7bbfed4c..3435fbddeb9 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/Script/Action.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/Script/Action.hs @@ -13,11 +13,6 @@ module Cardano.Benchmarking.Script.Action ) where -import qualified Data.Text as Text (unpack) - -import Control.Monad.IO.Class -import Control.Monad.Trans.Except.Extra - import Cardano.Benchmarking.OuroborosImports as Core (protocolToNetworkId) import Cardano.Benchmarking.Script.Core import Cardano.Benchmarking.Script.Env @@ -26,6 +21,10 @@ import Cardano.Benchmarking.Tracer import Cardano.TxGenerator.Setup.NodeConfig import Cardano.TxGenerator.Types (TxGenError) +import Control.Monad.IO.Class +import Control.Monad.Trans.Except.Extra +import qualified Data.Text as Text (unpack) + -- | 'action' has as its sole callers -- 'Cardano.Benchmark.Script.runScript' from "Cardano.Benchmark.Script" @@ -47,8 +46,8 @@ action a = case a of AddFund era wallet txIn lovelace keyName -> addFund era wallet txIn lovelace keyName Delay t -> delay t Submit era submitMode txParams generator -> submitAction era submitMode generator txParams - WaitBenchmark thread -> waitBenchmark thread - CancelBenchmark thread -> cancelBenchmark thread + WaitBenchmark -> waitBenchmark + CancelBenchmark -> cancelBenchmark WaitForEra era -> waitForEra era LogMsg txt -> traceDebug $ Text.unpack txt Reserved options -> reserved options diff --git a/bench/tx-generator/src/Cardano/Benchmarking/Script/Core.hs b/bench/tx-generator/src/Cardano/Benchmarking/Script/Core.hs index 4ece43785c2..000270d1825 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/Script/Core.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/Script/Core.hs @@ -28,8 +28,8 @@ import qualified Cardano.Benchmarking.GeneratorTx as GeneratorTx (waitBenchmark, import Cardano.Benchmarking.GeneratorTx.NodeToNode (ConnectClient, benchmarkConnectTxSubmit) import Cardano.Benchmarking.GeneratorTx.SizedMetadata (mkMetadata) -import Cardano.Benchmarking.LogTypes as Core (TraceBenchTxSubmit (..), btConnect_, btN2N_, - btSubmission2_, btTxSubmit_) +import Cardano.Benchmarking.LogTypes as Core (AsyncBenchmarkControl (..), + TraceBenchTxSubmit (..), btConnect_, btN2N_, btSubmission2_, btTxSubmit_) import Cardano.Benchmarking.OuroborosImports as Core (LocalSubmitTx, SigningKeyFile, makeLocalConnectInfo, protocolToCodecConfig) import Cardano.Benchmarking.Script.Aeson (prettyPrintOrdered, readProtocolParametersFile) @@ -143,20 +143,20 @@ getConnectClient = do mempty -- (btSubmission2_ tracers) (protocolToCodecConfig protocol) networkMagic -waitBenchmark :: String -> ActionM () -waitBenchmark n = do - abcMaybe <- getEnvThreads n +waitBenchmark :: ActionM () +waitBenchmark = do + abcMaybe <- getEnvThreads case abcMaybe of Just abc -> waitBenchmarkCore abc Nothing -> do throwE . Env.TxGenError . TxGenError $ ("waitBenchmark: missing AsyncBenchmarkControl" :: String) -cancelBenchmark :: String -> ActionM () -cancelBenchmark n = do - Just ctl@(_, _ , _ , shutdownAction) <- getEnvThreads n - liftIO shutdownAction - waitBenchmarkCore ctl +cancelBenchmark :: ActionM () +cancelBenchmark = do + Just abc@AsyncBenchmarkControl { .. } <- getEnvThreads + liftIO abcShutdown + waitBenchmarkCore abc getLocalConnectInfo :: ActionM LocalNodeConnectInfo getLocalConnectInfo = makeLocalConnectInfo <$> getEnvNetworkId <*> getEnvSocketPath @@ -246,7 +246,7 @@ submitInEra submitMode generator txParams era = do txStream <- evalGenerator generator txParams era case submitMode of NodeToNode _ -> error "NodeToNode deprecated: ToDo: remove" - Benchmark nodes threadName tpsRate txCount -> benchmarkTxStream txStream nodes threadName tpsRate txCount era + Benchmark nodes tpsRate txCount -> benchmarkTxStream txStream nodes tpsRate txCount era LocalSocket -> submitAll (void . localSubmitTx . Utils.mkTxInModeCardano) txStream DumpToFile filePath -> liftIO $ Streaming.writeFile filePath $ Streaming.map showTx txStream DiscardTX -> liftIO $ Streaming.mapM_ forceTx txStream @@ -269,22 +269,21 @@ submitInEra submitMode generator txParams era = do benchmarkTxStream :: forall era. IsShelleyBasedEra era => TxStream IO era -> TargetNodes - -> String -> TPSRate -> NumberOfTxs -> AsType era -> ActionM () -benchmarkTxStream txStream targetNodes threadName tps txCount era = do +benchmarkTxStream txStream targetNodes tps txCount era = do tracers <- getBenchTracers connectClient <- getConnectClient let coreCall :: AsType era -> ExceptT TxGenError IO AsyncBenchmarkControl coreCall eraProxy = GeneratorTx.walletBenchmark (btTxSubmit_ tracers) (btN2N_ tracers) connectClient - threadName targetNodes tps LogErrors eraProxy txCount txStream + targetNodes tps LogErrors eraProxy txCount txStream ret <- liftIO $ runExceptT $ coreCall era case ret of Left err -> liftTxGenError err - Right ctl -> setEnvThreads threadName ctl + Right ctl -> setEnvThreads ctl evalGenerator :: IsShelleyBasedEra era => Generator -> TxGenTxParams -> AsType era -> ActionM (TxStream IO era) evalGenerator generator txParams@TxGenTxParams{txParamFee = fee} era = do diff --git a/bench/tx-generator/src/Cardano/Benchmarking/Script/Env.hs b/bench/tx-generator/src/Cardano/Benchmarking/Script/Env.hs index cc47d4e65db..c4bad9d09ad 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/Script/Env.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/Script/Env.hs @@ -4,6 +4,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} @@ -30,7 +31,6 @@ module Cardano.Benchmarking.Script.Env ( , Env (Env, envThreads) , Error (..) , mkNewEnv - , runActionM , runActionMEnv , liftTxGenError , liftIOSafe @@ -102,7 +102,7 @@ data Env = Env { -- | 'Cardano.Api.ProtocolParameters' is ultimately , envNetworkId :: Maybe NetworkId , envSocketPath :: Maybe FilePath , envKeys :: Map String (SigningKey PaymentKey) - , envThreads :: Map String (STM.TVar (Maybe AsyncBenchmarkControl)) + , envThreads :: STM.TVar (Maybe AsyncBenchmarkControl) , envWallets :: Map String WalletRef , envSummary :: Maybe PlutusBudgetSummary } @@ -118,26 +118,21 @@ emptyEnv = Env { protoParams = Nothing , envProtocol = Nothing , envNetworkId = Nothing , envSocketPath = Nothing - , envThreads = Map.empty + -- This never escapes: it's always overridden. + , envThreads = undefined , envWallets = Map.empty , envSummary = Nothing } mkNewEnv :: STM Env mkNewEnv = do - ctl <- STM.newTVar Nothing - pure emptyEnv { envThreads = "tx-submit-benchmark" `Map.singleton` ctl } + envThreads <- STM.newTVar Nothing + pure emptyEnv { envThreads } -- | This abbreviates an `ExceptT` and `RWST` with particular types -- used as parameters. type ActionM a = ExceptT Error (RWST IOManager () Env IO) a --- | This runs an `ActionM` starting with an empty `Env`. -runActionM :: ActionM ret -> IOManager -> IO (Either Error ret, Env, ()) -runActionM actions ioManager = do - env <- STM.atomically mkNewEnv - runActionMEnv env actions ioManager - -- | This runs an `ActionM` starting with the `Env` being passed. runActionMEnv :: Env -> ActionM ret -> IOManager -> IO (Either Error ret, Env, ()) runActionMEnv env action iom = RWS.runRWST (runExceptT action) iom env @@ -206,14 +201,10 @@ setEnvSocketPath :: FilePath -> ActionM () setEnvSocketPath val = modifyEnv (\e -> e { envSocketPath = Just val }) -- | Write accessor for `envThreads`. -setEnvThreads :: String -> AsyncBenchmarkControl -> ActionM () -setEnvThreads key val = do - threadMap <- lift $ RWS.gets envThreads - case Map.lookup key threadMap of - Nothing -> do - abcTVar <- liftIO do STM.atomically do STM.newTVar $ Just val - modifyEnv (\env -> env { envThreads = Map.insert key abcTVar threadMap }) - Just abcTVar -> liftIO do STM.atomically $ abcTVar `STM.writeTVar` Just val +setEnvThreads :: AsyncBenchmarkControl -> ActionM () +setEnvThreads abc = do + abcTVar <- lift $ RWS.gets envThreads + liftIO do STM.atomically $ abcTVar `STM.writeTVar` Just abc -- | Write accessor for `envWallets`. setEnvWallets :: String -> WalletRef -> ActionM () @@ -267,9 +258,9 @@ getEnvSocketPath :: ActionM SocketPath getEnvSocketPath = File <$> getEnvVal envSocketPath "SocketPath" -- | Read accessor for `envThreads`. -getEnvThreads :: String -> ActionM (Maybe AsyncBenchmarkControl) -getEnvThreads key = do - abcTVar <- getEnvMap envThreads key +getEnvThreads :: ActionM (Maybe AsyncBenchmarkControl) +getEnvThreads = do + abcTVar <- lift $ RWS.gets envThreads liftIO do STM.atomically $ STM.readTVar abcTVar -- | Read accessor for `envWallets`. diff --git a/bench/tx-generator/src/Cardano/Benchmarking/Script/Selftest.hs b/bench/tx-generator/src/Cardano/Benchmarking/Script/Selftest.hs index 0c1d47a750f..591015c844a 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/Script/Selftest.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/Script/Selftest.hs @@ -29,7 +29,6 @@ import Control.Monad import qualified Data.ByteString.Lazy.Char8 as BSL import Data.Either (fromRight) import qualified Data.List as List (unwords) -import qualified Data.Map as Map (lookup) import Data.String import Paths_tx_generator @@ -50,19 +49,13 @@ runSelftest env iom outFile = do Env.setBenchTracers initNullTracers forM_ (testScript protocolFile submitMode) action (result, Env { envThreads }, ()) <- Env.runActionMEnv env fullScript iom - case "tx-submit-benchmark" `Map.lookup` envThreads of - Nothing -> do - error $ List.unwords - [ "Cardano.Benchmarking.Script.Selftest.runSelftest:" - , "thread state uninitialized" ] - Just abcTVar -> do - abcMaybe <- STM.atomically $ STM.readTVar abcTVar - case abcMaybe of - Nothing -> pure result - Just _ -> do - error $ List.unwords + abcMaybe <- STM.atomically $ STM.readTVar envThreads + case abcMaybe of + Just _ -> error $ + List.unwords [ "Cardano.Benchmarking.Script.Selftest.runSelftest:" , "thread state spuriously initialized" ] + Nothing -> pure result -- | 'printJSON' prints out the list of actions using Aeson. -- It has no callers within @cardano-node@. diff --git a/bench/tx-generator/src/Cardano/Benchmarking/Script/Types.hs b/bench/tx-generator/src/Cardano/Benchmarking/Script/Types.hs index a6121a41709..06ca89cd594 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/Script/Types.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/Script/Types.hs @@ -99,8 +99,8 @@ data Action where AddFund :: !AnyCardanoEra -> !String -> !TxIn -> !L.Coin -> !String -> Action -- | 'WaitBenchmark' signifies a 'Control.Concurrent.Async.waitCatch' -- on the 'Cardano.Benchmarking.GeneratorTx.AsyncBenchmarkControl' - -- associated with the ID and also folds tracers into the completion. - WaitBenchmark :: !String -> Action + -- for the environment and also folds tracers into the completion. + WaitBenchmark :: Action -- | 'Submit' mostly wraps -- 'Cardano.Benchamrking.Script.Core.benchmarkTxStream' -- which in turn wraps @@ -112,7 +112,7 @@ data Action where -- | 'CancelBenchmark' wraps a callback from the -- 'Cardano.Benchmarking.GeneratorTx.AsyncBenchmarkControl' type, -- which is a shutdown action. - CancelBenchmark :: !String -> Action + CancelBenchmark :: Action -- | 'Reserved' just emits an error and is a placeholder that helps -- with testing and quick fixes. Reserved :: [String] -> Action @@ -182,7 +182,7 @@ type TargetNodes = NonEmpty NodeDescription data SubmitMode where LocalSocket :: SubmitMode - Benchmark :: !TargetNodes -> !String -> !TPSRate -> !NumberOfTxs -> SubmitMode + Benchmark :: !TargetNodes -> !TPSRate -> !NumberOfTxs -> SubmitMode DumpToFile :: !FilePath -> SubmitMode DiscardTX :: SubmitMode NodeToNode :: NonEmpty NodeIPv4Address -> SubmitMode --deprecated diff --git a/bench/tx-generator/test/script.json b/bench/tx-generator/test/script.json index 198acfc53ec..c247152ac6a 100644 --- a/bench/tx-generator/test/script.json +++ b/bench/tx-generator/test/script.json @@ -1,94 +1,25 @@ [ + "-- This is a comment.", { - "setNumberOfInputsPerTx": 1 + "comment": "This is another comment.", + "SetSocketPath": "logs/sockets/1" }, { - "setNumberOfOutputsPerTx": 1 + "ReadSigningKey": ["pass-partout", "configuration/genesis-shelley/utxo-keys/utxo1.skey"] }, { - "setNumberOfTxs": 500 + "Delay": 10 }, { - "setTxAdditionalSize": 0 + "Delay": 10 }, { - "setFee": 0 + "WaitForEra": "Byron" }, { - "setTTL": 1000000 + "CancelBenchmark": [] }, { - "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": [] + "Reserved": [] } -] \ No newline at end of file +] From d2eab3684fc5312e7b30dc925ef5a748feec5efc Mon Sep 17 00:00:00 2001 From: Nadia Yvette Chambers Date: Thu, 23 May 2024 04:54:19 +0000 Subject: [PATCH 6/9] txgen-mvar: pass NixServiceOptions to keepalive This took a fair amount of rearrangement to broaden the constant environment in order to pass the keepalive interval in the NixServiceOptions around. So a few different things happened: I. create EnvConsts structure encompassing A. AsyncBenchmarkControl TVar (potentially changing to IORef) B. IOManager C. Maybe NixServiceOptions This moves the mutable reference in A. to the Reader environment from the State of the ExceptionT Env.Error (RWST EnvConsts () Env IO) ActionM monad. The reference stays constant though the referenced data changes. II. pass EnvConsts to runScript and runSelftest III. update Env.hs and NixService.hs accessors Some of it represents changing a little of the design of the Env and ActionM once again even after the prior commits, so a fair amount of squashing commits that entirely redo earlier commits' changes and rewriting commit messages will need to be done in the sequel. --- .../src/Cardano/Benchmarking/Command.hs | 34 +++++++++------- .../src/Cardano/Benchmarking/GeneratorTx.hs | 2 +- .../Benchmarking/GeneratorTx/NodeToNode.hs | 14 ++++--- .../src/Cardano/Benchmarking/LogTypes.hs | 24 ++++++++++-- .../src/Cardano/Benchmarking/Script.hs | 15 ++++--- .../src/Cardano/Benchmarking/Script/Core.hs | 5 ++- .../src/Cardano/Benchmarking/Script/Env.hs | 39 +++++++++++-------- .../Cardano/Benchmarking/Script/Selftest.hs | 12 +++--- .../Cardano/TxGenerator/Setup/NixService.hs | 8 +++- bench/tx-generator/test/Bench.hs | 12 +++--- 10 files changed, 100 insertions(+), 65 deletions(-) diff --git a/bench/tx-generator/src/Cardano/Benchmarking/Command.hs b/bench/tx-generator/src/Cardano/Benchmarking/Command.hs index da36e064694..99c4da5bcc4 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/Command.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/Command.hs @@ -20,16 +20,16 @@ where #endif import Cardano.Benchmarking.Compiler (compileOptions) -import Cardano.Benchmarking.LogTypes (AsyncBenchmarkControl (..)) +import Cardano.Benchmarking.LogTypes (AsyncBenchmarkControl (..), EnvConsts (..)) import Cardano.Benchmarking.Script (parseScriptFileAeson, runScript) import Cardano.Benchmarking.Script.Aeson (parseJSONFile, prettyPrint) -import Cardano.Benchmarking.Script.Env as Env (Env (Env, envThreads), mkNewEnv) +import Cardano.Benchmarking.Script.Env as Env (emptyEnv, newEnvConsts) import Cardano.Benchmarking.Script.Selftest (runSelftest) import Cardano.Benchmarking.Version as Version import Cardano.TxGenerator.PlutusContext (readScriptData) import Cardano.TxGenerator.Setup.NixService import Cardano.TxGenerator.Types (TxGenPlutusParams (..)) -import Ouroboros.Network.NodeToClient (withIOManager) +import Ouroboros.Network.NodeToClient (IOManager, withIOManager) import Prelude @@ -71,18 +71,22 @@ data Command | VersionCmd runCommand :: IO () -runCommand = withIOManager $ \iocp -> do - env <- installSignalHandler +runCommand = withIOManager runCommand' + +runCommand' :: IOManager -> IO () +runCommand' iocp = do + envConsts <- installSignalHandler cmd <- customExecParser (prefs showHelpOnEmpty) (info commandParser mempty) case cmd of - Json file -> do - script <- parseScriptFileAeson file - runScript env script iocp >>= handleError . fst - JsonHL file nodeConfigOverwrite cardanoTracerOverwrite -> do - opts <- parseJSONFile fromJSON file + Json actionFile -> do + script <- parseScriptFileAeson actionFile + runScript emptyEnv script envConsts >>= handleError . fst + JsonHL nixSvcOptsFile nodeConfigOverwrite cardanoTracerOverwrite -> do + opts <- parseJSONFile fromJSON nixSvcOptsFile finalOpts <- mangleTracerConfig cardanoTracerOverwrite <$> mangleNodeConfig nodeConfigOverwrite opts + let consts = envConsts { envNixSvcOpts = Just finalOpts } Prelude.putStrLn $ "--> initial options:\n" ++ show opts ++ @@ -91,23 +95,23 @@ runCommand = withIOManager $ \iocp -> do quickTestPlutusDataOrDie finalOpts case compileOptions finalOpts of - Right script -> runScript env script iocp >>= handleError . fst + Right script -> runScript emptyEnv script consts >>= handleError . fst err -> die $ "tx-generator:Cardano.Command.runCommand JsonHL: " ++ show err Compile file -> do o <- parseJSONFile fromJSON file case compileOptions o of Right script -> BSL.putStr $ prettyPrint script Left err -> die $ "tx-generator:Cardano.Command.runCommand Compile: " ++ show err - Selftest outFile -> runSelftest env iocp outFile >>= handleError + Selftest outFile -> runSelftest emptyEnv envConsts outFile >>= handleError VersionCmd -> runVersionCommand where handleError :: Show a => Either a b -> IO () handleError = \case Right _ -> exitSuccess Left err -> die $ "tx-generator:Cardano.Command.runCommand handleError: " ++ show err - installSignalHandler :: IO Env + installSignalHandler :: IO EnvConsts installSignalHandler = do - env@Env { .. } <- STM.atomically mkNewEnv + envConsts@EnvConsts { .. } <- STM.atomically $ newEnvConsts iocp Nothing abc <- STM.atomically $ STM.readTVar envThreads _ <- pure abc #ifdef UNIX @@ -152,7 +156,7 @@ runCommand = withIOManager $ \iocp -> do Fold.forM_ [Sig.sigINT, Sig.sigTERM] $ \sig -> Sig.installHandler sig signalHandler Nothing #endif - pure env + pure envConsts mangleNodeConfig :: Maybe FilePath -> NixServiceOptions -> IO NixServiceOptions mangleNodeConfig fp opts = case (getNodeConfigFile opts, fp) of diff --git a/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx.hs b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx.hs index 11574e7e28b..f87af0bfdfa 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx.hs @@ -31,7 +31,7 @@ import Cardano.Benchmarking.Wallet (TxStream) import Cardano.Logging import Cardano.Node.Configuration.NodeAddress import Cardano.Prelude -import Cardano.TxGenerator.Setup.NixService +import Cardano.TxGenerator.Setup.NixService as Nix (NodeDescription (..)) import Cardano.TxGenerator.Types (NumberOfTxs, TPSRate, TxGenError (..)) import Prelude (String) diff --git a/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/NodeToNode.hs b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/NodeToNode.hs index 8587bdb6866..b56d4f04786 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/NodeToNode.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/NodeToNode.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE PackageImports #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} @@ -46,7 +47,7 @@ import Ouroboros.Network.KeepAlive import Ouroboros.Network.Magic import Ouroboros.Network.Mux (MiniProtocolCb (..), MuxMode (..), OuroborosApplication (..), OuroborosBundle, RunMiniProtocol (..)) -import Ouroboros.Network.NodeToClient (IOManager, chainSyncPeerNull) +import Ouroboros.Network.NodeToClient (chainSyncPeerNull) import Ouroboros.Network.NodeToNode (NetworkConnectTracers (..)) import qualified Ouroboros.Network.NodeToNode as NtN import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing (..)) @@ -64,14 +65,15 @@ import Ouroboros.Network.Protocol.PeerSharing.Client (PeerSharingClien import Ouroboros.Network.Snocket (socketSnocket) -import Cardano.Benchmarking.LogTypes (SendRecvConnect, SendRecvTxSubmission2) +import Cardano.Benchmarking.LogTypes (EnvConsts (..), SendRecvConnect, SendRecvTxSubmission2) +import Cardano.TxGenerator.Setup.NixService (defaultKeepaliveTimeout, getKeepaliveTimeout) type CardanoBlock = Consensus.CardanoBlock StandardCrypto type ConnectClient = AddrInfo -> TxSubmissionClient (GenTxId CardanoBlock) (GenTx CardanoBlock) IO () -> IO () benchmarkConnectTxSubmit :: forall blk. (blk ~ CardanoBlock, RunNode blk ) - => IOManager + => EnvConsts -> Tracer IO SendRecvConnect -> Tracer IO SendRecvTxSubmission2 -> CodecConfig CardanoBlock @@ -82,9 +84,9 @@ benchmarkConnectTxSubmit -- ^ the particular txSubmission peer -> IO () -benchmarkConnectTxSubmit ioManager handshakeTracer submissionTracer codecConfig networkMagic remoteAddr myTxSubClient = +benchmarkConnectTxSubmit EnvConsts { .. } handshakeTracer submissionTracer codecConfig networkMagic remoteAddr myTxSubClient = NtN.connectTo - (socketSnocket ioManager) + (socketSnocket envIOManager) NetworkConnectTracers { nctMuxTracer = mempty, nctHandshakeTracer = handshakeTracer @@ -178,7 +180,7 @@ benchmarkConnectTxSubmit ioManager handshakeTracer submissionTracer codecConfig mempty keepAliveRng (continueForever (Proxy :: Proxy IO)) them peerGSVMap - (KeepAliveInterval 10) + (KeepAliveInterval $ maybe defaultKeepaliveTimeout getKeepaliveTimeout envNixSvcOpts) -- the null block fetch client blockFetchClientNull diff --git a/bench/tx-generator/src/Cardano/Benchmarking/LogTypes.hs b/bench/tx-generator/src/Cardano/Benchmarking/LogTypes.hs index ba20d771257..93471039db9 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/LogTypes.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/LogTypes.hs @@ -13,12 +13,13 @@ module Cardano.Benchmarking.LogTypes ( AsyncBenchmarkControl (..) - , BenchTracers(..) - , NodeToNodeSubmissionTrace(..) + , BenchTracers (..) + , EnvConsts (..) + , NodeToNodeSubmissionTrace (..) , SendRecvConnect , SendRecvTxSubmission2 - , SubmissionSummary(..) - , TraceBenchTxSubmit(..) + , SubmissionSummary (..) + , TraceBenchTxSubmit (..) ) where import Cardano.Api @@ -33,9 +34,11 @@ import Cardano.Tracing.OrphanInstances.Consensus () import Cardano.Tracing.OrphanInstances.Network () import Cardano.Tracing.OrphanInstances.Shelley () import Cardano.TxGenerator.PlutusContext (PlutusBudgetSummary) +import Cardano.TxGenerator.Setup.NixService (NixServiceOptions (..)) import Cardano.TxGenerator.Types (TPSRate) import Ouroboros.Consensus.Ledger.SupportsMempool (GenTx, GenTxId) import Ouroboros.Network.Driver (TraceSendRecv (..)) +import Ouroboros.Network.IOManager (IOManager) import Ouroboros.Network.NodeToNode (NodeToNodeVersion, RemoteConnectionId) import Ouroboros.Network.Protocol.Handshake.Type (Handshake) import Ouroboros.Network.Protocol.TxSubmission2.Type (TxSubmission2) @@ -44,6 +47,7 @@ import Prelude import qualified Codec.CBOR.Term as CBOR import qualified Control.Concurrent.Async as Async (Async) +import qualified Control.Concurrent.STM as STM (TVar) import Data.Text import Data.Time.Clock (DiffTime, NominalDiffTime) import GHC.Generics @@ -61,6 +65,18 @@ data AsyncBenchmarkControl = -- ^ IO action to shut down the feeder thread. } +data EnvConsts = + EnvConsts + { envIOManager :: IOManager + , envThreads :: STM.TVar (Maybe AsyncBenchmarkControl) + -- ^ The reference needs to be a constant, but the referred-to data + -- (`AsyncBenchmarkControl`) needs to be able to be initialized. + -- This could in principle be an `IORef` instead of a `STM.TVar`. + , envNixSvcOpts :: Maybe NixServiceOptions + -- ^ There are situations `NixServiceOptions` won't be available and + -- defaults will have to be used. + } + data BenchTracers = BenchTracers { btTxSubmit_ :: Trace IO (TraceBenchTxSubmit TxId) diff --git a/bench/tx-generator/src/Cardano/Benchmarking/Script.hs b/bench/tx-generator/src/Cardano/Benchmarking/Script.hs index d69801b2d7c..9b7537bc250 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/Script.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/Script.hs @@ -14,11 +14,10 @@ import Cardano.Benchmarking.LogTypes import Cardano.Benchmarking.Script.Action import Cardano.Benchmarking.Script.Aeson (parseScriptFileAeson) import Cardano.Benchmarking.Script.Core (setProtocolParameters) -import qualified Cardano.Benchmarking.Script.Env as Env (ActionM, Env (Env, envThreads), - Error (TxGenError), getEnvThreads, runActionMEnv, traceError) +import qualified Cardano.Benchmarking.Script.Env as Env (ActionM, Env (..), Error (TxGenError), + getEnvThreads, runActionMEnv, traceError) import Cardano.Benchmarking.Script.Types import qualified Cardano.TxGenerator.Types as Types (TxGenError (..)) -import Ouroboros.Network.NodeToClient (IOManager) import Prelude @@ -33,19 +32,19 @@ import System.Mem (performGC) type Script = [Action] -runScript :: Env.Env -> Script -> IOManager -> IO (Either Env.Error (), AsyncBenchmarkControl) -runScript env script iom = do +runScript :: Env.Env -> Script -> EnvConsts -> IO (Either Env.Error (), AsyncBenchmarkControl) +runScript env script constants@EnvConsts { .. } = do result <- go performGC threadDelay $ 150 * 1_000 return result where go :: IO (Either Env.Error (), AsyncBenchmarkControl) - go = Env.runActionMEnv env execScript iom >>= \case + go = Env.runActionMEnv env execScript constants >>= \case (Right abc, env', ()) -> do cleanup env' shutDownLogging pure (Right (), abc) - (Left err, env'@Env.Env { .. }, ()) -> do + (Left err, env', ()) -> do cleanup env' (Env.traceError (show err) >> shutDownLogging) abcMaybe <- STM.atomically $ STM.readTVar envThreads case abcMaybe of @@ -55,7 +54,7 @@ runScript env script iom = do , "AsyncBenchmarkControl uninitialized" ] where cleanup :: Env.Env -> Env.ActionM () -> IO () - cleanup env' acts = void $ Env.runActionMEnv env' acts iom + cleanup env' acts = void $ Env.runActionMEnv env' acts constants execScript :: Env.ActionM AsyncBenchmarkControl execScript = do setProtocolParameters QueryLocalNode diff --git a/bench/tx-generator/src/Cardano/Benchmarking/Script/Core.hs b/bench/tx-generator/src/Cardano/Benchmarking/Script/Core.hs index 000270d1825..7860d2e30d2 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/Script/Core.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/Script/Core.hs @@ -58,6 +58,7 @@ import Prelude import Control.Concurrent (threadDelay) import Control.Monad +import Control.Monad.Trans.RWS.Strict (ask) import "contra-tracer" Control.Tracer (Tracer (..)) import Data.ByteString.Lazy.Char8 as BSL (writeFile) import Data.Ratio ((%)) @@ -136,9 +137,9 @@ getConnectClient = do (Testnet networkMagic) <- getEnvNetworkId protocol <- getEnvProtocol void $ return $ btSubmission2_ tracers - ioManager <- askIOManager + envConsts <- lift ask return $ benchmarkConnectTxSubmit - ioManager + envConsts (Tracer $ traceWith (btConnect_ tracers)) mempty -- (btSubmission2_ tracers) (protocolToCodecConfig protocol) diff --git a/bench/tx-generator/src/Cardano/Benchmarking/Script/Env.hs b/bench/tx-generator/src/Cardano/Benchmarking/Script/Env.hs index c4bad9d09ad..2944e096c92 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/Script/Env.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/Script/Env.hs @@ -4,8 +4,8 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} @@ -28,13 +28,16 @@ ran into circular dependency issues during the above transition. -} module Cardano.Benchmarking.Script.Env ( ActionM - , Env (Env, envThreads) + , Env (..) , Error (..) - , mkNewEnv + , emptyEnv + , newEnvConsts , runActionMEnv , liftTxGenError , liftIOSafe , askIOManager + , askNixSvcOpts + , askEnvThreads , traceDebug , traceError , traceBenchTxSubmit @@ -72,6 +75,7 @@ import Cardano.Ledger.Crypto (StandardCrypto) import Cardano.Logging import Cardano.Node.Protocol.Types (SomeConsensusProtocol) import Cardano.TxGenerator.PlutusContext (PlutusBudgetSummary) +import Cardano.TxGenerator.Setup.NixService as Nix (NixServiceOptions) import Cardano.TxGenerator.Types (TxGenError (..)) import Ouroboros.Network.NodeToClient (IOManager) @@ -102,11 +106,9 @@ data Env = Env { -- | 'Cardano.Api.ProtocolParameters' is ultimately , envNetworkId :: Maybe NetworkId , envSocketPath :: Maybe FilePath , envKeys :: Map String (SigningKey PaymentKey) - , envThreads :: STM.TVar (Maybe AsyncBenchmarkControl) , envWallets :: Map String WalletRef , envSummary :: Maybe PlutusBudgetSummary } - -- | `Env` uses `Maybe` to represent values that might be uninitialized. -- This being empty means `Nothing` is used across the board, along with -- all of the `Map.Map` structures being `Map.empty`. @@ -118,24 +120,22 @@ emptyEnv = Env { protoParams = Nothing , envProtocol = Nothing , envNetworkId = Nothing , envSocketPath = Nothing - -- This never escapes: it's always overridden. - , envThreads = undefined , envWallets = Map.empty , envSummary = Nothing } -mkNewEnv :: STM Env -mkNewEnv = do +newEnvConsts :: IOManager -> Maybe Nix.NixServiceOptions -> STM Tracer.EnvConsts +newEnvConsts envIOManager envNixSvcOpts = do envThreads <- STM.newTVar Nothing - pure emptyEnv { envThreads } + pure Tracer.EnvConsts { .. } -- | This abbreviates an `ExceptT` and `RWST` with particular types -- used as parameters. -type ActionM a = ExceptT Error (RWST IOManager () Env IO) a +type ActionM a = ExceptT Error (RWST Tracer.EnvConsts () Env IO) a -- | This runs an `ActionM` starting with the `Env` being passed. -runActionMEnv :: Env -> ActionM ret -> IOManager -> IO (Either Error ret, Env, ()) -runActionMEnv env action iom = RWS.runRWST (runExceptT action) iom env +runActionMEnv :: Env -> ActionM ret -> Tracer.EnvConsts -> IO (Either Error ret, Env, ()) +runActionMEnv env action envConsts = RWS.runRWST (runExceptT action) envConsts env -- | 'Error' adds two cases to 'Cardano.TxGenerator.Types.TxGenError' -- which in turn wraps 'Cardano.Api.Error' implicit contexts to a @@ -166,7 +166,14 @@ liftIOSafe a = liftIO a >>= either liftTxGenError pure -- | Accessor for the `IOManager` reader monad aspect of the `RWST`. askIOManager :: ActionM IOManager -askIOManager = lift RWS.ask +askIOManager = lift $ RWS.asks Tracer.envIOManager + +-- | Accessor for the `NixServiceOptions` reader monad aspect of the `RWST`. +askNixSvcOpts :: ActionM (Maybe Nix.NixServiceOptions) +askNixSvcOpts = lift $ RWS.asks Tracer.envNixSvcOpts + +askEnvThreads :: ActionM (STM.TVar (Maybe AsyncBenchmarkControl)) +askEnvThreads = lift $ RWS.asks Tracer.envThreads -- | Helper to modify `Env` record fields. modifyEnv :: (Env -> Env) -> ActionM () @@ -203,7 +210,7 @@ setEnvSocketPath val = modifyEnv (\e -> e { envSocketPath = Just val }) -- | Write accessor for `envThreads`. setEnvThreads :: AsyncBenchmarkControl -> ActionM () setEnvThreads abc = do - abcTVar <- lift $ RWS.gets envThreads + abcTVar <- lift $ RWS.asks Tracer.envThreads liftIO do STM.atomically $ abcTVar `STM.writeTVar` Just abc -- | Write accessor for `envWallets`. @@ -260,7 +267,7 @@ getEnvSocketPath = File <$> getEnvVal envSocketPath "SocketPath" -- | Read accessor for `envThreads`. getEnvThreads :: ActionM (Maybe AsyncBenchmarkControl) getEnvThreads = do - abcTVar <- lift $ RWS.gets envThreads + abcTVar <- lift $ RWS.asks Tracer.envThreads liftIO do STM.atomically $ STM.readTVar abcTVar -- | Read accessor for `envWallets`. diff --git a/bench/tx-generator/src/Cardano/Benchmarking/Script/Selftest.hs b/bench/tx-generator/src/Cardano/Benchmarking/Script/Selftest.hs index 591015c844a..03677bbc69b 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/Script/Selftest.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/Script/Selftest.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} {-| Module : Cardano.Benchmarking.Script.Selftest Description : Run self-tests using statically-defined data. @@ -11,16 +11,16 @@ where import Cardano.Api hiding (Env) +import Cardano.Benchmarking.LogTypes (EnvConsts (..)) import Cardano.Benchmarking.Script.Action import Cardano.Benchmarking.Script.Aeson (prettyPrint) -import Cardano.Benchmarking.Script.Env as Env (Env (Env, envThreads)) +import Cardano.Benchmarking.Script.Env as Env (Env (..)) import qualified Cardano.Benchmarking.Script.Env as Env (Error, runActionMEnv, setBenchTracers) import Cardano.Benchmarking.Script.Types import Cardano.Benchmarking.Tracer (initNullTracers) import qualified Cardano.Ledger.Coin as L import Cardano.TxGenerator.Setup.SigningKey import Cardano.TxGenerator.Types -import Ouroboros.Network.NodeToClient (IOManager) import Prelude @@ -40,15 +40,15 @@ import Paths_tx_generator -- transaction 'Streaming.Stream' that -- 'Cardano.Benchmarking.Script.Core.submitInEra' -- does 'show' and 'writeFile' on. -runSelftest :: Env -> IOManager -> Maybe FilePath -> IO (Either Env.Error ()) -runSelftest env iom outFile = do +runSelftest :: Env -> EnvConsts -> Maybe FilePath -> IO (Either Env.Error ()) +runSelftest env envConsts@EnvConsts { .. } outFile = do protocolFile <- getDataFileName "data/protocol-parameters.json" let submitMode = maybe DiscardTX DumpToFile outFile fullScript = do Env.setBenchTracers initNullTracers forM_ (testScript protocolFile submitMode) action - (result, Env { envThreads }, ()) <- Env.runActionMEnv env fullScript iom + (result, Env { }, ()) <- Env.runActionMEnv env fullScript envConsts abcMaybe <- STM.atomically $ STM.readTVar envThreads case abcMaybe of Just _ -> error $ diff --git a/bench/tx-generator/src/Cardano/TxGenerator/Setup/NixService.hs b/bench/tx-generator/src/Cardano/TxGenerator/Setup/NixService.hs index e5d3ebf6140..1badcc32d48 100644 --- a/bench/tx-generator/src/Cardano/TxGenerator/Setup/NixService.hs +++ b/bench/tx-generator/src/Cardano/TxGenerator/Setup/NixService.hs @@ -10,6 +10,7 @@ module Cardano.TxGenerator.Setup.NixService ( NixServiceOptions (..) , NodeDescription (..) + , defaultKeepaliveTimeout , getKeepaliveTimeout , getNodeAlias , getNodeConfigFile @@ -70,7 +71,6 @@ data NodeDescription = , ndName :: String } deriving (Eq, Show, Generic) --- { "alias": "foo", "addr": ..., "port": ... } instance FromJSON NodeDescription where parseJSON = withObject "NodeDescription" \v -> do unNodeHostIPv4Address @@ -93,8 +93,12 @@ instance ToJSON NodeDescription where -- Long GC pauses on target nodes can trigger spurious MVar deadlock -- detection. Increasing this timeout can help mitigate those errors. +-- 10s turned out to be a problem, so it's 30s now. +defaultKeepaliveTimeout :: Clock.DiffTime +defaultKeepaliveTimeout = 30 + getKeepaliveTimeout :: NixServiceOptions -> Clock.DiffTime -getKeepaliveTimeout = maybe 30 Clock.secondsToDiffTime . _nix_keepalive +getKeepaliveTimeout = maybe defaultKeepaliveTimeout Clock.secondsToDiffTime . _nix_keepalive getNodeAlias :: NixServiceOptions -> NodeIPv4Address -> Maybe String getNodeAlias NixServiceOptions {..} ip = ndName <$> diff --git a/bench/tx-generator/test/Bench.hs b/bench/tx-generator/test/Bench.hs index d22a4dc55c5..ec35408a6e1 100644 --- a/bench/tx-generator/test/Bench.hs +++ b/bench/tx-generator/test/Bench.hs @@ -1,22 +1,24 @@ +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE Trustworthy #-} module Main (main) where -import Cardano.Benchmarking.Script.Env (mkNewEnv) +import Cardano.Benchmarking.Script.Env (emptyEnv, newEnvConsts) import Cardano.Benchmarking.Script.Selftest import Prelude import Control.Monad.STM (atomically) -import Criterion.Main hiding (env) +import Criterion.Main main :: IO () main = defaultMain [ bgroup "cardano-tx-generator-integration" [ - bench "tx-gen" $ whnfIO $ do - env <- atomically mkNewEnv - runSelftest env (error "noIOManager") Nothing >>= \case + bench "tx-gen" $ whnfIO do + envConsts <- atomically do + newEnvConsts (error "No IOManager!") Nothing + runSelftest emptyEnv envConsts Nothing >>= \case Right _ -> pure () Left err -> error $ show err ] From 690333901836f7eeb363d4f045d4515831572d26 Mon Sep 17 00:00:00 2001 From: Nadia Yvette Chambers Date: Fri, 24 May 2024 19:24:18 +0000 Subject: [PATCH 7/9] txgen-mvar: incorporate feedback I. Make tracers potentially available within signal handlers. This logs the event better. II. killThread weak main TID. Killing the main thread if the signal is received in a secondary thread makes sense as a back-up strategy. --- .../src/Cardano/Benchmarking/Command.hs | 42 ++++++++++++++----- .../src/Cardano/Benchmarking/LogTypes.hs | 2 + .../src/Cardano/Benchmarking/Script/Env.hs | 29 +++++++++++-- 3 files changed, 59 insertions(+), 14 deletions(-) diff --git a/bench/tx-generator/src/Cardano/Benchmarking/Command.hs b/bench/tx-generator/src/Cardano/Benchmarking/Command.hs index 99c4da5bcc4..41b391ecb66 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/Command.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/Command.hs @@ -20,7 +20,8 @@ where #endif import Cardano.Benchmarking.Compiler (compileOptions) -import Cardano.Benchmarking.LogTypes (AsyncBenchmarkControl (..), EnvConsts (..)) +import Cardano.Benchmarking.LogTypes (AsyncBenchmarkControl (..), BenchTracers (..), + EnvConsts (..), TraceBenchTxSubmit (..)) import Cardano.Benchmarking.Script (parseScriptFileAeson, runScript) import Cardano.Benchmarking.Script.Aeson (parseJSONFile, prettyPrint) import Cardano.Benchmarking.Script.Env as Env (emptyEnv, newEnvConsts) @@ -29,29 +30,33 @@ import Cardano.Benchmarking.Version as Version import Cardano.TxGenerator.PlutusContext (readScriptData) import Cardano.TxGenerator.Setup.NixService import Cardano.TxGenerator.Types (TxGenPlutusParams (..)) -import Ouroboros.Network.NodeToClient (IOManager, withIOManager) - -import Prelude - import Data.Aeson (fromJSON) import Data.ByteString.Lazy as BSL import Data.Foldable (for_) import Data.Maybe (catMaybes) +import Data.Text as T import Data.Text.IO as T import Options.Applicative as Opt +import Ouroboros.Network.NodeToClient (IOManager, withIOManager) + import System.Exit #ifdef UNIX -import Control.Concurrent as Conc (myThreadId) +import Cardano.Logging as Tracer (traceWith) +import Control.Concurrent as Conc (killThread, myThreadId) +import Control.Concurrent as Weak (mkWeakThreadId) import Control.Concurrent.Async as Async (cancelWith) import Control.Concurrent.STM as STM (readTVar) import Control.Monad.STM as STM (atomically) - import Data.Foldable as Fold (forM_) import Data.List as List (unwords) import Data.Time.Format as Time (defaultTimeLocale, formatTime) import Data.Time.Clock.System as Time (getSystemTime, systemToUTCTime) -import System.Posix.Signals as Sig (Handler (CatchInfoOnce), SignalInfo (..), SignalSpecificInfo (..), installHandler, sigINT, sigTERM) +import GHC.Weak as Weak (deRefWeak) + +import System.Posix.Signals as Sig (Handler (CatchInfo), + SignalInfo (..), SignalSpecificInfo (..), installHandler, + sigINT, sigTERM) #if MIN_VERSION_base(4,18,0) import Data.Maybe as Maybe (fromMaybe) import GHC.Conc.Sync as Conc (threadLabel) @@ -111,11 +116,13 @@ runCommand' iocp = do Left err -> die $ "tx-generator:Cardano.Command.runCommand handleError: " ++ show err installSignalHandler :: IO EnvConsts installSignalHandler = do + -- The main thread does not appear in the set of asyncs. + wkMainTID <- Weak.mkWeakThreadId =<< myThreadId envConsts@EnvConsts { .. } <- STM.atomically $ newEnvConsts iocp Nothing abc <- STM.atomically $ STM.readTVar envThreads - _ <- pure abc + _ <- pure (abc, wkMainTID) #ifdef UNIX - let signalHandler = Sig.CatchInfoOnce signalHandler' + let signalHandler = Sig.CatchInfo signalHandler' signalHandler' sigInfo = do tid <- Conc.myThreadId utcTime <- Time.systemToUTCTime <$> Time.getSystemTime @@ -139,8 +146,18 @@ runCommand' iocp = do , show sigInfo ] errorToThrow :: IOError errorToThrow = userError labelStr + tag = TraceBenchTxSubError . T.pack + traceWith' msg = do + mBenchTracer <- STM.atomically do readTVar benchTracers + case mBenchTracer of + Nothing -> pure () + Just tracers -> do + let wrappedMsg = tag msg + submittedTracers = btTxSubmit_ tracers + Tracer.traceWith submittedTracers wrappedMsg Prelude.putStrLn labelStr + traceWith' labelStr mABC <- STM.atomically $ STM.readTVar envThreads case mABC of Nothing -> do @@ -149,10 +166,15 @@ runCommand' iocp = do -- this pursues some alternatives. let errMsg = "Signal received before AsyncBenchmarkControl creation." Prelude.putStrLn errMsg + traceWith' errMsg Just AsyncBenchmarkControl { .. } -> do abcFeeder `Async.cancelWith` errorToThrow Fold.forM_ abcWorkers \work -> do work `Async.cancelWith` errorToThrow + -- The main thread does __NOT__ appear in the above list. + -- In order to kill that off, this, or some equivalent, + -- absolutely /must/ be done separately. + mapM_ Conc.killThread =<< Weak.deRefWeak wkMainTID Fold.forM_ [Sig.sigINT, Sig.sigTERM] $ \sig -> Sig.installHandler sig signalHandler Nothing #endif diff --git a/bench/tx-generator/src/Cardano/Benchmarking/LogTypes.hs b/bench/tx-generator/src/Cardano/Benchmarking/LogTypes.hs index 93471039db9..e20db4daa5a 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/LogTypes.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/LogTypes.hs @@ -75,6 +75,8 @@ data EnvConsts = , envNixSvcOpts :: Maybe NixServiceOptions -- ^ There are situations `NixServiceOptions` won't be available and -- defaults will have to be used. + , benchTracers :: STM.TVar (Maybe BenchTracers) + -- ^ This also needs to be accessible to the signal handlers. } data BenchTracers = diff --git a/bench/tx-generator/src/Cardano/Benchmarking/Script/Env.hs b/bench/tx-generator/src/Cardano/Benchmarking/Script/Env.hs index 2944e096c92..e17a94b7c8b 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/Script/Env.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/Script/Env.hs @@ -91,6 +91,7 @@ import qualified Control.Monad.Trans.RWS.Strict as RWS import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import qualified Data.Text as Text +import qualified System.IO as IO (hPutStrLn, stderr) -- | The 'Env' type represents the state maintained while executing @@ -100,7 +101,6 @@ data Env = Env { -- | 'Cardano.Api.ProtocolParameters' is ultimately -- wrapped by 'ProtocolParameterMode' which itself is -- a sort of custom 'Maybe'. protoParams :: Maybe ProtocolParameterMode - , benchTracers :: Maybe Tracer.BenchTracers , envGenesis :: Maybe (ShelleyGenesis StandardCrypto) , envProtocol :: Maybe SomeConsensusProtocol , envNetworkId :: Maybe NetworkId @@ -114,7 +114,6 @@ data Env = Env { -- | 'Cardano.Api.ProtocolParameters' is ultimately -- all of the `Map.Map` structures being `Map.empty`. emptyEnv :: Env emptyEnv = Env { protoParams = Nothing - , benchTracers = Nothing , envGenesis = Nothing , envKeys = Map.empty , envProtocol = Nothing @@ -127,6 +126,7 @@ emptyEnv = Env { protoParams = Nothing newEnvConsts :: IOManager -> Maybe Nix.NixServiceOptions -> STM Tracer.EnvConsts newEnvConsts envIOManager envNixSvcOpts = do envThreads <- STM.newTVar Nothing + benchTracers <- STM.newTVar Nothing pure Tracer.EnvConsts { .. } -- | This abbreviates an `ExceptT` and `RWST` with particular types @@ -185,7 +185,9 @@ setProtoParamMode val = modifyEnv (\e -> e { protoParams = Just val }) -- | Write accessor for `benchTracers`. setBenchTracers :: Tracer.BenchTracers -> ActionM () -setBenchTracers val = modifyEnv (\e -> e { benchTracers = Just val }) +setBenchTracers val = do + btTVar <- lift $ RWS.asks Tracer.benchTracers + liftIO $ STM.atomically do STM.writeTVar btTVar $ Just val -- | Write accessor for `envGenesis`. setEnvGenesis :: ShelleyGenesis StandardCrypto -> ActionM () @@ -241,8 +243,27 @@ getProtoParamMode :: ActionM ProtocolParameterMode getProtoParamMode = getEnvVal protoParams "ProtocolParameterMode" -- | Read accessor for `benchTracers`. +-- It would be burdensome on callers to have to have to case analyze +-- this result. EnvConsts :: (Type -> Type) -> Type would make sense, +-- using the pattern of data HKT f = HKT { f1 :: f t1, f2 :: f t2, ..} +-- Then EnvConsts Maybe can be converted to EnvConsts Identity once +-- initialization is complete so the main phase doesn't need to do this. getBenchTracers :: ActionM Tracer.BenchTracers -getBenchTracers = getEnvVal benchTracers "BenchTracers" +getBenchTracers = do + btTVar <- lift $ RWS.asks Tracer.benchTracers + mTracer <- liftIO $ STM.atomically do STM.readTVar btTVar + case mTracer of + Just tracer -> pure tracer + Nothing -> do + -- If this occurs, it may be worthwhile to output it in more ways + -- because the tracer isn't actually initialized. + let errMsg = "Env.getBenchTracers: attempted to set tracer before\ + \ STM.TVar init" + traceError errMsg + liftIO $ do + putStrLn errMsg + IO.hPutStrLn IO.stderr errMsg + pure $ error errMsg -- | Read accessor for `envGenesis`. getEnvGenesis :: ActionM (ShelleyGenesis StandardCrypto) From 4804566ae66e19f28fc8ca5be9a27adab24b1057 Mon Sep 17 00:00:00 2001 From: Nadia Yvette Chambers Date: Fri, 28 Jun 2024 14:06:25 +0000 Subject: [PATCH 8/9] txgen-mvar: version bump + changelog The changelog is new. --- bench/tx-generator/CHANGELOG.md | 8 ++++++++ bench/tx-generator/tx-generator.cabal | 2 +- 2 files changed, 9 insertions(+), 1 deletion(-) create mode 100644 bench/tx-generator/CHANGELOG.md diff --git a/bench/tx-generator/CHANGELOG.md b/bench/tx-generator/CHANGELOG.md new file mode 100644 index 00000000000..c99e8eedcbe --- /dev/null +++ b/bench/tx-generator/CHANGELOG.md @@ -0,0 +1,8 @@ +# ChangeLog + +## 2.14.1 -- June 2024 +* A new NixSvcOptions field is introduced: `_nix_keepalive` + and it's propagated down to the `kaClient` that does keepalives. + This makes keepalive timeouts configurable. +* The fast-solo profile is introduced for quick test runs. +* A `CHANGELOG.md` is created for the tx-generator. diff --git a/bench/tx-generator/tx-generator.cabal b/bench/tx-generator/tx-generator.cabal index 3bf98786797..ca3f7d1b400 100644 --- a/bench/tx-generator/tx-generator.cabal +++ b/bench/tx-generator/tx-generator.cabal @@ -1,7 +1,7 @@ cabal-version: 3.0 name: tx-generator -version: 2.14 +version: 2.14.1 synopsis: A transaction workload generator for Cardano clusters description: A transaction workload generator for Cardano clusters. category: Cardano, From dd32da1e63e5d554617874b33a131c7c13f545c8 Mon Sep 17 00:00:00 2001 From: Michael Karg Date: Mon, 1 Jul 2024 17:20:27 +0200 Subject: [PATCH 9/9] tx-generator: revert example script.json --- bench/tx-generator/test/script.json | 89 +++++++++++++++++++++++++---- 1 file changed, 79 insertions(+), 10 deletions(-) diff --git a/bench/tx-generator/test/script.json b/bench/tx-generator/test/script.json index c247152ac6a..cb87c251c48 100644 --- a/bench/tx-generator/test/script.json +++ b/bench/tx-generator/test/script.json @@ -1,25 +1,94 @@ [ - "-- This is a comment.", { - "comment": "This is another comment.", - "SetSocketPath": "logs/sockets/1" + "setNumberOfInputsPerTx": 1 }, { - "ReadSigningKey": ["pass-partout", "configuration/genesis-shelley/utxo-keys/utxo1.skey"] + "setNumberOfOutputsPerTx": 1 }, { - "Delay": 10 + "setNumberOfTxs": 500 }, { - "Delay": 10 + "setTxAdditionalSize": 0 }, { - "WaitForEra": "Byron" + "setFee": 0 }, { - "CancelBenchmark": [] + "setTTL": 1000000 }, { - "Reserved": [] + "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": [], + "txList": "txlist", + "tps": 10 + }, + { + "waitForEra": "Byron" + }, + { + "cancelBenchmark": [] + }, + { + "reserved": [] } -] +] \ No newline at end of file