From 4341e3ee6b026c8d1e7f8aa28b36dd9cc5072b84 Mon Sep 17 00:00:00 2001 From: Sebastian Nagel Date: Mon, 24 Aug 2026 10:59:18 +0200 Subject: [PATCH 1/6] tx-firehose: tag transactions with a colour --color ff0000 or --color auto puts three bytes of RGB into metadata label 1022, so a mempool observer can attribute each tx to the generator that made it. That is what makes mempool fragmentation visible when several generators feed different corners of a network. auto takes a hue from the verification key hash and fixes saturation and lightness, since hash bytes read directly as RGB leave a good share of keys dark or muddy, which is the opposite of what colouring is for. Builds the auxiliary data through cardano-api's toAuxiliaryData for the same reason signing already goes through cardano-api: it case-analyses the era, so the aux-data constraints resolve where an era-generic build cannot. The hash lands in the body before the witness is computed, which the witness covers. --- bench/tx-firehose/README.md | 24 ++++ bench/tx-firehose/app/Main.hs | 59 +++++++++- .../Cardano/Benchmarking/TxFirehose/Color.hs | 110 ++++++++++++++++++ .../src/Cardano/Benchmarking/TxFirehose/Tx.hs | 27 ++++- bench/tx-firehose/tx-firehose.cabal | 4 +- 5 files changed, 215 insertions(+), 9 deletions(-) create mode 100644 bench/tx-firehose/src/Cardano/Benchmarking/TxFirehose/Color.hs diff --git a/bench/tx-firehose/README.md b/bench/tx-firehose/README.md index a82ff2f6812..0081d3ddee6 100644 --- a/bench/tx-firehose/README.md +++ b/bench/tx-firehose/README.md @@ -48,6 +48,30 @@ Every output is an equal split of (inputs − fee), so values stay balanced acro the set. `--fee` must be covered by the inputs and each resulting output must clear min-UTxO; otherwise the build fails (traced as `TxFirehose.Build.Fail`). +## Colouring the load + +`--color` tags every generated tx with a colour in metadata label `1022`, three +bytes of RGB. A mempool observer can then attribute each tx to the firehose that +made it, which is what makes mempool fragmentation visible when several +generators feed different parts of a network. + + --color ff0000 # or #ff0000 + --color auto # derive one from the signing key + +`auto` hashes the verification key and takes a hue from it, keeping saturation +and lightness fixed so the result is always vivid. Hues are uniform over the +circle, but at fixed saturation and lightness there are only about 1500 +distinguishable colours, so with a handful of generators expect some pairs to +land close together. **Assign explicit colours for a run whose whole point is +telling generators apart**; `auto` is for convenience. + +The colour is printed on stderr at startup, as a swatch when stderr is a +terminal and as bare hex otherwise (`NO_COLOR` is honoured). + +Metadata is not free: the auxiliary data hash alone is 32 bytes in the body, so +a coloured tx runs roughly 45 bytes larger. That is about +20% on a minimal +228-byte tx, so coloured runs are not byte-comparable with uncoloured baselines. + ## Output One JSON line per event on **stderr**, in the cardano-node trace schema (`{at, diff --git a/bench/tx-firehose/app/Main.hs b/bench/tx-firehose/app/Main.hs index 257587d1948..06d40d51432 100644 --- a/bench/tx-firehose/app/Main.hs +++ b/bench/tx-firehose/app/Main.hs @@ -43,6 +43,14 @@ import Cardano.Api , UTxO (UTxO) ) import Cardano.Api qualified as Api +import Cardano.Benchmarking.TxFirehose.Color + ( Color + , ColorSpec + , colorHex + , colorSwatch + , parseColorSpec + , resolveColor + ) import Cardano.Benchmarking.TxFirehose.Tx ( BuiltTx (BuiltTx, btxId, btxInputs, btxOutputs, btxSigned, btxSize) , Fund (Fund, fundTxIn, fundValue) @@ -60,6 +68,7 @@ import Data.ByteString.Lazy.Char8 qualified as BSL import Data.List (isInfixOf, sortOn) import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map +import Data.Foldable (traverse_) import Data.Maybe (fromMaybe) import Data.Set qualified as Set import Data.Text (Text) @@ -73,7 +82,16 @@ import Ouroboros.Network.Protocol.LocalTxSubmission.Client , LocalTxSubmissionClient (LocalTxSubmissionClient) ) import System.Exit (die) -import System.IO (BufferMode (LineBuffering), hSetBuffering, hSetEncoding, stderr, utf8) +import System.Environment (lookupEnv) +import System.IO + ( BufferMode (LineBuffering) + , hIsTerminalDevice + , hPutStrLn + , hSetBuffering + , hSetEncoding + , stderr + , utf8 + ) -------------------------------------------------------------------------------- -- CLI @@ -89,6 +107,7 @@ data Options = Options , optOutputsPerTx :: !Natural , optFee :: !Integer , optMaxConsecutiveErrors :: !Int + , optColor :: !(Maybe ColorSpec) } parseOptions :: IO Options @@ -167,6 +186,15 @@ optionsParser = <> Opt.showDefault <> Opt.help "Exit after this many consecutive rejects (for supervisor restart)" ) + <*> optional + ( Opt.option + (Opt.eitherReader parseColorSpec) + ( Opt.long "color" + <> Opt.metavar "HEX|auto" + <> Opt.help + "Tag every tx with this colour as metadata, e.g. ff0000, or 'auto' to derive one from the signing key" + ) + ) main :: IO () main = do @@ -191,9 +219,25 @@ main = do -- Dispatch on whatever era the node reports; the tx builder is -- generic over ShelleyBasedEra. + -- Resolve the colour once, here, so the swatch we print and the metadata we + -- attach cannot disagree. + let mColor = flip resolveColor (Api.getVerificationKey signingKey) <$> optColor opts + traverse_ announceColor mColor + currentEra <- queryCurrentEra connInfo runInEra currentEra $ \sbe -> - runFirehoseInEra sbe opts connInfo networkId signingKey mStakeVk + runFirehoseInEra sbe opts connInfo networkId signingKey mStakeVk mColor + +-- | Show the colour on stderr at startup, as a block when the terminal can +-- render it and as bare hex otherwise. +announceColor :: Color -> IO () +announceColor color = do + tty <- hIsTerminalDevice stderr + noColor <- lookupEnv "NO_COLOR" + let swatch + | tty && noColor == Nothing = " " ++ colorSwatch color + | otherwise = "" + hPutStrLn stderr ("tx-firehose colour: " ++ colorHex color ++ swatch) -- | Fail if the node is in Byron; otherwise run the continuation with -- the era's 'ShelleyBasedEra' witness. @@ -234,8 +278,9 @@ runFirehoseInEra :: NetworkId -> SigningKey Api.PaymentKey -> Maybe (Api.VerificationKey Api.StakeKey) -> + Maybe Color -> IO () -runFirehoseInEra sbe opts connInfo networkId signingKey mStakeVk = do +runFirehoseInEra sbe opts connInfo networkId signingKey mStakeVk mColor = do trace "TxFirehose.Startup.Query" "Info" $ Aeson.object ["address" .= T.pack (show addrAny), "era" .= show sbe] @@ -255,7 +300,7 @@ runFirehoseInEra sbe opts connInfo networkId signingKey mStakeVk = do { localChainSyncClient = NoLocalChainSyncClient , localStateQueryClient = Nothing , localTxSubmissionClient = - Just (mkFirehoseClient sbe opts addrInEra signingKey initialFunds) + Just (mkFirehoseClient sbe opts addrInEra signingKey initialFunds mColor) , localTxMonitoringClient = Nothing } where @@ -274,8 +319,9 @@ mkFirehoseClient :: AddressInEra era -> SigningKey Api.PaymentKey -> Map TxIn Integer -> + Maybe Color -> LocalTxSubmissionClient TxInMode TxValidationErrorInCardanoMode IO () -mkFirehoseClient sbe opts addr sk initialFunds = +mkFirehoseClient sbe opts addr sk initialFunds mColor = LocalTxSubmissionClient (step initialFunds 0) where !period = round (1_000_000 / optTps opts) :: Int @@ -306,7 +352,8 @@ mkFirehoseClient sbe opts addr sk initialFunds = sk inFunds (optOutputsPerTx opts) - (Coin (optFee opts)) of + (Coin (optFee opts)) + mColor of Left err -> do trace "TxFirehose.Build.Fail" "Error" $ Aeson.object ["error" .= T.pack err] diff --git a/bench/tx-firehose/src/Cardano/Benchmarking/TxFirehose/Color.hs b/bench/tx-firehose/src/Cardano/Benchmarking/TxFirehose/Color.hs new file mode 100644 index 00000000000..4032fe8ee89 --- /dev/null +++ b/bench/tx-firehose/src/Cardano/Benchmarking/TxFirehose/Color.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE ImportQualifiedPost #-} + +-- | Colours that tag a firehose's transactions, so a mempool observer can tell +-- whose load a mempool is holding. +module Cardano.Benchmarking.TxFirehose.Color + ( Color (..) + , ColorSpec (..) + , parseColorSpec + , resolveColor + , colorHex + , colorBytes + , colorSwatch + , colorMetadataLabel + ) where + +import Cardano.Api (PaymentKey, VerificationKey, serialiseToRawBytes, verificationKeyHash) +import Data.Bits (shiftL, (.|.)) +import Data.ByteString (ByteString) +import Data.ByteString qualified as BS +import Data.Char (isHexDigit, toLower) +import Data.Word (Word64, Word8) +import Text.Printf (printf) + +-- | A 24-bit RGB colour. +data Color = Color + { colorRed :: !Word8 + , colorGreen :: !Word8 + , colorBlue :: !Word8 + } + deriving (Eq, Show) + +-- | What @--color@ asked for: a literal colour, or one derived from the key. +data ColorSpec + = ColorLiteral !Color + | ColorFromKey + deriving (Eq, Show) + +-- | Metadata label carrying the colour, named after the issue this was built for. +colorMetadataLabel :: Word64 +colorMetadataLabel = 1022 + +-- | Parse @ff0000@, @#ff0000@ or @auto@. +parseColorSpec :: String -> Either String ColorSpec +parseColorSpec s + | normalised == "auto" = Right ColorFromKey + | length normalised == 6 && all isHexDigit normalised = + Right (ColorLiteral (Color (octet 0) (octet 1) (octet 2))) + | otherwise = + Left ("not a colour: " ++ s ++ " (expected six hex digits or 'auto')") + where + normalised = map toLower (dropWhile (== '#') s) + + octet i = 16 * hexValue (normalised !! (2 * i)) + hexValue (normalised !! (2 * i + 1)) + + hexValue c + | c >= '0' && c <= '9' = fromIntegral (fromEnum c - fromEnum '0') + | otherwise = fromIntegral (fromEnum c - fromEnum 'a' + 10) + +-- | Resolve a spec against the key whose transactions will carry the colour. +resolveColor :: ColorSpec -> VerificationKey PaymentKey -> Color +resolveColor (ColorLiteral c) _ = c +resolveColor ColorFromKey vk = hueColor hue + where + -- Two bytes of the key hash pick a hue, while saturation and lightness stay + -- fixed. Taking hash bytes as RGB directly would leave a good share of keys + -- dark or muddy, which is exactly what makes colours hard to tell apart. + hue = case BS.unpack (serialiseToRawBytes (verificationKeyHash vk)) of + (hi : lo : _) -> 360 * fromIntegral (word16 hi lo) / 65536 + _ -> 0 + + word16 hi lo = (fromIntegral hi `shiftL` 8) .|. fromIntegral lo :: Int + +-- | A vivid colour at the given hue. +hueColor :: Double -> Color +hueColor h = Color r g b + where + (r, g, b) = hslToRgb h 0.85 0.55 + +-- | Hue in [0,360), saturation and lightness in [0,1]. +hslToRgb :: Double -> Double -> Double -> (Word8, Word8, Word8) +hslToRgb h s l = (toOctet (r + m), toOctet (g + m), toOctet (b + m)) + where + chroma = (1 - abs (2 * l - 1)) * s + sector = h / 60 + x = chroma * (1 - abs (sector `fmod` 2 - 1)) + m = l - chroma / 2 + + (r, g, b) + | sector < 1 = (chroma, x, 0) + | sector < 2 = (x, chroma, 0) + | sector < 3 = (0, chroma, x) + | sector < 4 = (0, x, chroma) + | sector < 5 = (x, 0, chroma) + | otherwise = (chroma, 0, x) + + fmod a n = a - n * fromIntegral (floor (a / n) :: Int) + + toOctet v = round (255 * max 0 (min 1 v)) + +-- | Six lowercase hex digits, no leading @#@. +colorHex :: Color -> String +colorHex (Color r g b) = printf "%02x%02x%02x" r g b + +-- | The three bytes that go into transaction metadata. +colorBytes :: Color -> ByteString +colorBytes (Color r g b) = BS.pack [r, g, b] + +-- | The colour itself, as a 24-bit background block for a terminal. +colorSwatch :: Color -> String +colorSwatch (Color r g b) = printf "\ESC[48;2;%d;%d;%dm \ESC[0m" r g b diff --git a/bench/tx-firehose/src/Cardano/Benchmarking/TxFirehose/Tx.hs b/bench/tx-firehose/src/Cardano/Benchmarking/TxFirehose/Tx.hs index 3a9d19ed49f..28a2cc69f38 100644 --- a/bench/tx-firehose/src/Cardano/Benchmarking/TxFirehose/Tx.hs +++ b/bench/tx-firehose/src/Cardano/Benchmarking/TxFirehose/Tx.hs @@ -14,8 +14,11 @@ module Cardano.Benchmarking.TxFirehose.Tx where import Cardano.Api qualified as Api +import Cardano.Benchmarking.TxFirehose.Color (Color, colorBytes, colorMetadataLabel) import Cardano.Ledger.Api ( addrTxWitsL + , auxDataHashTxBodyL + , auxDataTxL , feeTxBodyL , inputsTxBodyL , mkBasicTx @@ -25,9 +28,12 @@ import Cardano.Ledger.Api , txIdTx , witsTxL ) +import Cardano.Ledger.Api.Tx.AuxData (EraTxAuxData (TxAuxData), hashTxAuxData) import Cardano.Ledger.Api.Tx.In (TxId, TxIn, mkTxInPartial) import Cardano.Ledger.Coin (Coin (Coin)) import Data.Function ((&)) +import Data.Map.Strict qualified as Map +import Data.Maybe.Strict (StrictMaybe, maybeToStrictMaybe) import Data.Sequence.Strict qualified as StrictSeq import Data.Set qualified as Set import Data.Word (Word32) @@ -64,8 +70,9 @@ buildTx :: [Fund] -> Natural -> Coin -> + Maybe Color -> Either String (BuiltTx era) -buildTx sbe destAddr signingKey inFunds numOutputs fee +buildTx sbe destAddr signingKey inFunds numOutputs fee mColor | null inFunds = Left "buildTx: no input funds" | numOutputs == 0 = Left "buildTx: outputs_per_tx must be >= 1" | feeLovelace < 0 = Left "buildTx: fee must be >= 0" @@ -87,12 +94,27 @@ buildTx sbe destAddr signingKey inFunds numOutputs fee ++ " per output" | otherwise = Right built where - -- Body: pure ledger, era-generic via EraTxBody. + -- Optional colour, carried as transaction metadata so a mempool observer + -- can attribute the tx to the firehose that made it. + -- Via cardano-api for the same reason signing is: it case-analyses the era, + -- so the aux-data constraints resolve where an era-generic build cannot. + mAuxData :: StrictMaybe (TxAuxData (Api.ShelleyLedgerEra era)) + mAuxData = maybeToStrictMaybe (Api.toAuxiliaryData sbe metadataInEra Api.TxAuxScriptsNone) + + metadataInEra = case mColor of + Nothing -> Api.TxMetadataNone + Just color -> + Api.TxMetadataInEra sbe . Api.makeTransactionMetadata $ + Map.singleton colorMetadataLabel (Api.TxMetaBytes (colorBytes color)) + + -- Body: pure ledger, era-generic via EraTxBody. The aux-data hash has to be + -- in place before signing, since the witness covers it. body = mkBasicTxBody & inputsTxBodyL .~ Set.fromList (map fundTxIn inFunds) & outputsTxBodyL %~ (<> StrictSeq.fromList (map mkOut outAmounts)) & feeTxBodyL .~ fee + & auxDataHashTxBodyL .~ (hashTxAuxData <$> mAuxData) -- Signing via cardano-api - era-generic and Dijkstra-safe. witVKey = case Api.makeShelleyKeyWitness' @@ -105,6 +127,7 @@ buildTx sbe destAddr signingKey inFunds numOutputs fee ledgerTx = mkBasicTx body & witsTxL . addrTxWitsL .~ Set.singleton witVKey + & auxDataTxL .~ mAuxData ledgerTxId = txIdTx ledgerTx diff --git a/bench/tx-firehose/tx-firehose.cabal b/bench/tx-firehose/tx-firehose.cabal index cce56a85228..94c97455137 100644 --- a/bench/tx-firehose/tx-firehose.cabal +++ b/bench/tx-firehose/tx-firehose.cabal @@ -31,8 +31,10 @@ common project-config library import: project-config hs-source-dirs: src - exposed-modules: Cardano.Benchmarking.TxFirehose.Tx + exposed-modules: Cardano.Benchmarking.TxFirehose.Color + Cardano.Benchmarking.TxFirehose.Tx build-depends: base >= 4.14 && < 5 + , bytestring , cardano-api , cardano-ledger-api , cardano-ledger-core From a22bca4ee18e41f62542d380d8fcb4f9e9f63b66 Mon Sep 17 00:00:00 2001 From: Sebastian Nagel Date: Mon, 24 Aug 2026 11:06:25 +0200 Subject: [PATCH 2/6] mempool-monitor: observe one mempool's colour composition Walks a node's mempool over the node-to-client LocalTxMonitor protocol and reports which colours it holds, tallying the metadata tag tx-firehose writes. One instance per node on purpose: fragmentation is a statement about how pools differ, so an aggregate hides the thing under test. A snapshot is acquired once per round and walked within it, so the tally is consistent. Depth and capacity come from GetSizes, a single message, which leaves the per-tx round trips paying only for colour. Hence the ten second default interval. The drained count doubles as a check against the size GetSizes reports for the same snapshot. Reads the ledger tx's auxiliary data directly rather than through cardano-api's body view, which would build a record per tx across tens of thousands of them, and is deprecated besides. Output follows the handle rather than a flag: a repainting pane on a terminal, one line per snapshot in a log, plus optional TSV for later analysis. --- bench/mempool-monitor/LICENSE | 177 ++++++++++++++++++ bench/mempool-monitor/NOTICE | 13 ++ bench/mempool-monitor/README.md | 59 ++++++ bench/mempool-monitor/app/Main.hs | 142 ++++++++++++++ bench/mempool-monitor/mempool-monitor.cabal | 58 ++++++ .../Benchmarking/MempoolMonitor/Render.hs | 144 ++++++++++++++ .../Benchmarking/MempoolMonitor/Snapshot.hs | 140 ++++++++++++++ .../Cardano/Benchmarking/TxFirehose/Color.hs | 15 +- cabal.project | 1 + 9 files changed, 748 insertions(+), 1 deletion(-) create mode 100644 bench/mempool-monitor/LICENSE create mode 100644 bench/mempool-monitor/NOTICE create mode 100644 bench/mempool-monitor/README.md create mode 100644 bench/mempool-monitor/app/Main.hs create mode 100644 bench/mempool-monitor/mempool-monitor.cabal create mode 100644 bench/mempool-monitor/src/Cardano/Benchmarking/MempoolMonitor/Render.hs create mode 100644 bench/mempool-monitor/src/Cardano/Benchmarking/MempoolMonitor/Snapshot.hs diff --git a/bench/mempool-monitor/LICENSE b/bench/mempool-monitor/LICENSE new file mode 100644 index 00000000000..f433b1a53f5 --- /dev/null +++ b/bench/mempool-monitor/LICENSE @@ -0,0 +1,177 @@ + + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS diff --git a/bench/mempool-monitor/NOTICE b/bench/mempool-monitor/NOTICE new file mode 100644 index 00000000000..7b16053c55e --- /dev/null +++ b/bench/mempool-monitor/NOTICE @@ -0,0 +1,13 @@ +Copyright 2019-2023 Input Output Global Inc (IOG), 2023-2026 Intersect. + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. diff --git a/bench/mempool-monitor/README.md b/bench/mempool-monitor/README.md new file mode 100644 index 00000000000..441f0c20c22 --- /dev/null +++ b/bench/mempool-monitor/README.md @@ -0,0 +1,59 @@ +# mempool-monitor + +Watches **one** node's mempool over the node-to-client `LocalTxMonitor` protocol +and reports which colours it holds, where a colour is the metadata tag +`tx-firehose --color` writes. + +One instance per node is the point. Mempool fragmentation is a statement about +how pools *differ*, so an aggregate view hides exactly the thing under test. + +## Run + + mempool-monitor \ + --socket-path /path/to/node.socket \ + --testnet-magic 164 \ + --label bp1 \ + --own-color ff0000 \ + --interval 10 + +`--own-color` is optional and only used to report the local share, that is how +much of this mempool came from the generator attached to this node. + +## What it shows + + mempool-monitor bp1 slot 41205 + depth 27015 tx 17.6 / 25.0 MB + [########################..........] + colours 2 local ff0000 62% + [====================|========|====] <- painted in the real tx colours + ff0000 16700 62% + 00ff88 7200 27% + (none) 3115 12% + drained 27015 tx in 1.84s + +The composition bar is painted with the colours the transactions actually carry, +so nothing here invents a palette. + +Output follows the handle: a repainting pane when stdout is a terminal, one line +per snapshot when it is a log. `--tsv FILE` additionally appends a row per +snapshot for after-the-fact analysis. + +## Cost, and why the interval is generous + +`MsgNextTx` is one round trip per transaction and returns the whole +transaction, so draining a 27,000-transaction mempool means 27,000 round trips +and something like 17 MB. Depth and capacity come from `MsgGetSizes`, which is a +single message, so the expensive part is only the colour tally. + +Ten seconds between snapshots is therefore the default: fragmentation evolves +over tens of seconds, so a faster rate buys nothing and costs real work. + +Two consequences worth keeping in mind: + +- **The observer is not free.** It acquires one snapshot per round rather than + one per transaction, so the cost should be modest, but it is not nothing. + Treat "monitor attached" as a condition to measure rather than a neutral act, + and keep it constant across arms of any comparison. +- **`drained` is a check, not decoration.** It must agree with the `txs` figure + that `MsgGetSizes` reports for the same snapshot. Two independent counts of + one quantity; disagreement means the drain did not complete. diff --git a/bench/mempool-monitor/app/Main.hs b/bench/mempool-monitor/app/Main.hs new file mode 100644 index 00000000000..58d7ddfa291 --- /dev/null +++ b/bench/mempool-monitor/app/Main.hs @@ -0,0 +1,142 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE NumericUnderscores #-} + +-- | Watch one node's mempool over node-to-client and show what colours it +-- holds, so mempool fragmentation is visible per pool rather than in aggregate. +module Main (main) where + +import Cardano.Api qualified as Api +import Cardano.Benchmarking.MempoolMonitor.Render (renderLine, renderPane, tsvHeader, tsvRow) +import Cardano.Benchmarking.MempoolMonitor.Snapshot (monitorClient) +import Cardano.Benchmarking.TxFirehose.Color (Color, ColorSpec (ColorFromKey, ColorLiteral), parseColorSpec) +import Control.Applicative (optional) +import Control.Monad (when) +import Data.Foldable (traverse_) +import Numeric.Natural (Natural) +import Options.Applicative qualified as Opt +import System.Exit (die) +import System.IO + ( BufferMode (LineBuffering) + , IOMode (AppendMode) + , hIsTerminalDevice + , hPutStrLn + , hSetBuffering + , openFile + , stdout + ) + +data Options = Options + { optSocketPath :: !FilePath + , optNetworkMagic :: !Natural + , optLabel :: !(Maybe String) + , optInterval :: !Double + , optOwnColor :: !(Maybe Color) + , optTsv :: !(Maybe FilePath) + } + +main :: IO () +main = do + opts <- parseOptions + when (optInterval opts <= 0) $ die "--interval must be > 0" + + hSetBuffering stdout LineBuffering + -- A repainting pane is right in a terminal and garbage in a log file, so the + -- choice follows the handle rather than a flag. + pane <- hIsTerminalDevice stdout + + mTsvHandle <- traverse openTsv (optTsv opts) + + let label = maybe (optSocketPath opts) id (optLabel opts) + emit snapshot = do + putStr $ + if pane + then renderPane label (optOwnColor opts) snapshot + else renderLine label snapshot ++ "\n" + traverse_ (\h -> hPutStrLn h (tsvRow snapshot)) mTsvHandle + + Api.connectToLocalNode + (connectInfo opts) + Api.LocalNodeClientProtocols + { Api.localChainSyncClient = Api.NoLocalChainSyncClient + , Api.localStateQueryClient = Nothing + , Api.localTxSubmissionClient = Nothing + , Api.localTxMonitoringClient = + Just (monitorClient (round (optInterval opts * 1_000_000)) emit) + } + where + openTsv path = do + handle <- openFile path AppendMode + hSetBuffering handle LineBuffering + hPutStrLn handle tsvHeader + pure handle + +connectInfo :: Options -> Api.LocalNodeConnectInfo +connectInfo opts = + Api.LocalNodeConnectInfo + { Api.localConsensusModeParams = Api.CardanoModeParams (Api.EpochSlots 21600) + , Api.localNodeNetworkId = + Api.Testnet (Api.NetworkMagic (fromIntegral (optNetworkMagic opts))) + , Api.localNodeSocketPath = Api.File (optSocketPath opts) + } + +parseOptions :: IO Options +parseOptions = + Opt.execParser $ + Opt.info + (optionsParser Opt.<**> Opt.helper) + ( Opt.fullDesc + <> Opt.progDesc "Show which colours one node's mempool is holding." + <> Opt.header "mempool-monitor - watch a single mempool's composition" + ) + +optionsParser :: Opt.Parser Options +optionsParser = + Options + <$> Opt.strOption + ( Opt.long "socket-path" + <> Opt.metavar "SOCKET_PATH" + <> Opt.help "Path to the node socket (node-to-client)" + ) + <*> Opt.option + Opt.auto + ( Opt.long "testnet-magic" + <> Opt.metavar "NATURAL" + <> Opt.help "Specify a testnet magic id (e.g. 164 for leios proto-devnet)" + ) + <*> optional + ( Opt.strOption + ( Opt.long "label" + <> Opt.metavar "NAME" + <> Opt.help "Name for this node in the display (defaults to the socket path)" + ) + ) + <*> Opt.option + Opt.auto + ( Opt.long "interval" + <> Opt.metavar "SECONDS" + <> Opt.value 10 + <> Opt.showDefault + <> Opt.help "Seconds between snapshots; a drain is one round trip per tx, so keep it generous" + ) + <*> optional + ( Opt.option + (Opt.eitherReader readOwnColor) + ( Opt.long "own-color" + <> Opt.metavar "HEX" + <> Opt.help "This node's own colour, to report the local share" + ) + ) + <*> optional + ( Opt.strOption + ( Opt.long "tsv" + <> Opt.metavar "FILEPATH" + <> Opt.help "Also append one row per snapshot to this file" + ) + ) + +-- | @auto@ needs a signing key to resolve, which an observer does not have. +readOwnColor :: String -> Either String Color +readOwnColor s = case parseColorSpec s of + Right (ColorLiteral c) -> Right c + Right ColorFromKey -> Left "--own-color needs an explicit colour, not 'auto'" + Left err -> Left err diff --git a/bench/mempool-monitor/mempool-monitor.cabal b/bench/mempool-monitor/mempool-monitor.cabal new file mode 100644 index 00000000000..4e55a9c1bea --- /dev/null +++ b/bench/mempool-monitor/mempool-monitor.cabal @@ -0,0 +1,58 @@ +cabal-version: 3.0 + +name: mempool-monitor +version: 0.1.0.0 +synopsis: Per-node mempool composition observer +description: + Watches one cardano-node's mempool over the node-to-client LocalTxMonitor + protocol and reports which colours it is holding, where a colour is the + metadata tag tx-firehose writes. Observing each pool individually is what + makes mempool fragmentation visible: an aggregate hides it. + +license: Apache-2.0 +license-files: LICENSE + NOTICE +author: IOHK +maintainer: operations@iohk.io +copyright: 2026 Intersect +category: Cardano, Test +build-type: Simple + +common project-config + default-language: Haskell2010 + ghc-options: -Wall + -Wcompat + -Wredundant-constraints + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wpartial-fields + -Wunused-packages + +library + import: project-config + hs-source-dirs: src + exposed-modules: Cardano.Benchmarking.MempoolMonitor.Render + Cardano.Benchmarking.MempoolMonitor.Snapshot + build-depends: base >= 4.14 && < 5 + , cardano-api + , cardano-ledger-api + , cardano-strict-containers + , containers + , microlens + , ouroboros-network:protocols + , primitive + , time + , tx-firehose + +executable mempool-monitor + import: project-config + hs-source-dirs: app + main-is: Main.hs + ghc-options: -threaded + -rtsopts + "-with-rtsopts=-N -T" + build-depends: base >= 4.14 && < 5 + , cardano-api + , mempool-monitor + , optparse-applicative + , tx-firehose diff --git a/bench/mempool-monitor/src/Cardano/Benchmarking/MempoolMonitor/Render.hs b/bench/mempool-monitor/src/Cardano/Benchmarking/MempoolMonitor/Render.hs new file mode 100644 index 00000000000..86a9ad4e5be --- /dev/null +++ b/bench/mempool-monitor/src/Cardano/Benchmarking/MempoolMonitor/Render.hs @@ -0,0 +1,144 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE LambdaCase #-} + +-- | Rendering a snapshot: a repainting pane when there is a terminal, one line +-- per snapshot when the output is a log, and a TSV column set for analysis. +module Cardano.Benchmarking.MempoolMonitor.Render + ( renderPane + , renderLine + , tsvHeader + , tsvRow + ) where + +import Cardano.Benchmarking.MempoolMonitor.Snapshot + ( ColorKey (Colored, Uncolored) + , Snapshot (snapDrained, snapDuration, snapSizes, snapSlot) + , colorKeyLabel + , distinctColors + , localShare + , shares + ) +import Cardano.Benchmarking.TxFirehose.Color (Color, colorHex, colorRed, colorGreen, colorBlue) +import Cardano.Api qualified as Api +import Data.List (intercalate) +import Ouroboros.Network.Protocol.LocalTxMonitor.Type + ( MempoolSizeAndCapacity (capacityInBytes, numberOfTxs, sizeInBytes) + ) +import Text.Printf (printf) + +-- | Width of both bars, in cells. +barWidth :: Int +barWidth = 34 + +-- | The whole pane, ANSI-positioned so successive snapshots repaint in place. +renderPane :: String -> Maybe Color -> Snapshot -> String +renderPane label mOwn snap = + unlines $ + ["\ESC[H\ESC[2J" ++ header] + ++ [depthLine, capacityBar] + ++ [colorLine, compositionBar] + ++ map shareLine (shares snap) + ++ [drainLine] + where + sizes = snapSizes snap + + header = + printf + "mempool-monitor %-20s slot %s" + label + (show (Api.unSlotNo (snapSlot snap))) + + -- The protocol reports capacity in bytes only, so depth in transactions + -- stands alone and the ratio below it is the byte one. + depthLine = + printf + "depth %d tx %.1f / %.1f MB" + (numberOfTxs sizes) + (mb (sizeInBytes sizes)) + (mb (capacityInBytes sizes)) + + capacityBar = meter (fillRatio (sizeInBytes sizes) (capacityInBytes sizes)) + + colorLine = + printf "colours %d%s" (distinctColors snap) ownSuffix + + ownSuffix = case (mOwn, localShare mOwn snap) of + (Just own, Just share) -> printf " local %s %.0f%%" (colorHex own) (100 * share) + _ -> "" + + -- The composition bar is the point of the whole tool: one cell per share of + -- the mempool, painted in the colour the transactions actually carry. + compositionBar = + concat [replicate (cells share) ' ' `paintedWith` key | (key, _, share) <- shares snap] + ++ "\ESC[0m" + where + cells share = max 0 (round (share * fromIntegral barWidth)) + + shareLine (key, n, share) = + printf " %-8s %7d %3.0f%% %s" (colorKeyLabel key) n (100 * share) (swatchFor key) + + drainLine = + printf + "drained %d tx in %.2fs" + (snapDrained snap) + (realToFrac (snapDuration snap) :: Double) + +-- | One line per snapshot, for when stdout is a log rather than a terminal. +renderLine :: String -> Snapshot -> String +renderLine label snap = + printf + "%s slot=%d txs=%d drained=%d colours=%d in=%.2fs %s" + label + (Api.unSlotNo (snapSlot snap)) + (numberOfTxs (snapSizes snap)) + (snapDrained snap) + (distinctColors snap) + (realToFrac (snapDuration snap) :: Double) + (intercalate " " [printf "%s=%d" (colorKeyLabel k) n | (k, n, _) <- shares snap]) + +tsvHeader :: String +tsvHeader = intercalate "\t" ["slot", "txs", "bytes", "capacity", "drained", "colours", "drainSecs", "composition"] + +tsvRow :: Snapshot -> String +tsvRow snap = + intercalate + "\t" + [ show (Api.unSlotNo (snapSlot snap)) + , show (numberOfTxs sizes) + , show (sizeInBytes sizes) + , show (capacityInBytes sizes) + , show (snapDrained snap) + , show (distinctColors snap) + , printf "%.3f" (realToFrac (snapDuration snap) :: Double) + , intercalate "," [printf "%s:%d" (colorKeyLabel k) n | (k, n, _) <- shares snap] + ] + where + sizes = snapSizes snap + +-- Helpers ------------------------------------------------------------------ + +mb :: (Integral a) => a -> Double +mb n = fromIntegral n / 1_000_000 + +fillRatio :: (Integral a) => a -> a -> Double +fillRatio used capacity + | capacity <= 0 = 0 + | otherwise = min 1 (fromIntegral used / fromIntegral capacity) + +meter :: Double -> String +meter ratio = "[" ++ replicate filled '#' ++ replicate (barWidth - filled) '.' ++ "]" + where + filled = max 0 (min barWidth (round (ratio * fromIntegral barWidth))) + +-- | Paint a run of cells with a colour's own background, so the bar shows the +-- real colours rather than a palette we invented. +paintedWith :: String -> ColorKey -> String +paintedWith cells = \case + Colored c -> printf "\ESC[48;2;%d;%d;%dm" (colorRed c) (colorGreen c) (colorBlue c) ++ cells + Uncolored -> "\ESC[48;5;238m" ++ cells + +swatchFor :: ColorKey -> String +swatchFor = \case + Colored c -> printf "\ESC[48;2;%d;%d;%dm \ESC[0m" (colorRed c) (colorGreen c) (colorBlue c) + Uncolored -> "\ESC[48;5;238m \ESC[0m" diff --git a/bench/mempool-monitor/src/Cardano/Benchmarking/MempoolMonitor/Snapshot.hs b/bench/mempool-monitor/src/Cardano/Benchmarking/MempoolMonitor/Snapshot.hs new file mode 100644 index 00000000000..ba196588836 --- /dev/null +++ b/bench/mempool-monitor/src/Cardano/Benchmarking/MempoolMonitor/Snapshot.hs @@ -0,0 +1,140 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE LambdaCase #-} + +-- | Walking one mempool snapshot and tallying what colours it holds. +module Cardano.Benchmarking.MempoolMonitor.Snapshot + ( Snapshot (..) + , ColorKey (..) + , monitorClient + , txColorKey + , colorKeyLabel + , shares + , distinctColors + , localShare + ) where + +import Cardano.Api qualified as Api +import Cardano.Benchmarking.TxFirehose.Color (Color, colorFromOctets, colorHex, colorMetadataLabel) +import Control.Concurrent (threadDelay) +import Cardano.Ledger.Api (auxDataTxL) +import Cardano.Ledger.Api.Tx.AuxData (Metadatum (B), metadataTxAuxDataL) +import Data.Array.Byte (ByteArray) +import Data.List (sortOn) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Maybe.Strict (StrictMaybe (SJust, SNothing)) +import Data.Primitive.ByteArray (indexByteArray, sizeofByteArray) +import Data.Time.Clock (NominalDiffTime, UTCTime, diffUTCTime, getCurrentTime) +import Data.Word (Word8) +import Lens.Micro ((^.)) +import Ouroboros.Network.Protocol.LocalTxMonitor.Client + ( ClientStAcquired (SendMsgGetSizes, SendMsgNextTx, SendMsgRelease) + , ClientStIdle (SendMsgAcquire) + , LocalTxMonitorClient (LocalTxMonitorClient) + ) +import Ouroboros.Network.Protocol.LocalTxMonitor.Type (MempoolSizeAndCapacity) + +-- | A transaction is either tagged with a colour or it is not ours to explain. +data ColorKey + = Colored !Color + | Uncolored + deriving (Eq, Ord, Show) + +-- | One drained snapshot: what the mempool held, and what it cost to find out. +data Snapshot = Snapshot + { snapSlot :: !Api.SlotNo + , snapSizes :: !MempoolSizeAndCapacity + , snapColors :: !(Map ColorKey Int) + , snapDrained :: !Int + , snapDuration :: !NominalDiffTime + , snapTaken :: !UTCTime + } + +-- | Acquire, size, drain, release, wait, repeat. +-- +-- The snapshot is acquired once per round and walked within it, so the whole +-- tally is consistent. Draining is a round trip per transaction, which is why +-- the interval between rounds is generous. +monitorClient :: + Int -> + (Snapshot -> IO ()) -> + LocalTxMonitorClient Api.TxIdInMode Api.TxInMode Api.SlotNo IO () +monitorClient intervalMicros emit = LocalTxMonitorClient (pure idle) + where + idle = + SendMsgAcquire $ \slot -> do + started <- getCurrentTime + pure . SendMsgGetSizes $ \sizes -> + drain slot sizes started Map.empty 0 + + drain slot sizes started !tally !drained = + pure . SendMsgNextTx $ \case + Just tx -> drain slot sizes started (count (txColorKey tx) tally) (drained + 1) + Nothing -> do + finished <- getCurrentTime + emit + Snapshot + { snapSlot = slot + , snapSizes = sizes + , snapColors = tally + , snapDrained = drained + , snapDuration = finished `diffUTCTime` started + , snapTaken = finished + } + pure . SendMsgRelease $ do + threadDelay intervalMicros + pure idle + + count key = Map.insertWith (+) key 1 + +-- | The colour a transaction carries, if any. +-- +-- Reads the ledger tx's auxiliary data directly rather than going through +-- cardano-api's transaction body view, which would build a record per tx and is +-- worth avoiding when a drain walks tens of thousands of them. +txColorKey :: Api.TxInMode -> ColorKey +txColorKey = \case + Api.TxInByronSpecial{} -> Uncolored + Api.TxInMode sbe (Api.ShelleyTx _ ledgerTx) -> + Api.shelleyBasedEraConstraints sbe $ + case ledgerTx ^. auxDataTxL of + SNothing -> Uncolored + SJust auxData -> + case Map.lookup colorMetadataLabel (auxData ^. metadataTxAuxDataL) of + Just (B bytes) -> maybe Uncolored Colored (colorFromOctets (octets bytes)) + _ -> Uncolored + +-- | The ledger keeps metadata bytes in a 'ByteArray', so unpack the few we want. +octets :: ByteArray -> [Word8] +octets ba = [indexByteArray ba i | i <- [0 .. sizeofByteArray ba - 1]] + +-- | How a colour prints when it needs a name. +colorKeyLabel :: ColorKey -> String +colorKeyLabel = \case + Colored c -> colorHex c + Uncolored -> "(none)" + +-- | Colour shares of the snapshot, largest first. +shares :: Snapshot -> [(ColorKey, Int, Double)] +shares snap = + [ (key, n, fromIntegral n / fromIntegral total) + | (key, n) <- sortOn (negate . snd) (Map.toList (snapColors snap)) + ] + where + total = max 1 (snapDrained snap) + +-- | Colours actually present, ignoring untagged transactions. +distinctColors :: Snapshot -> Int +distinctColors = length . filter isColored . Map.keys . snapColors + where + isColored = \case + Colored{} -> True + Uncolored -> False + +-- | Share held by this node's own colour, when one was declared. +localShare :: Maybe Color -> Snapshot -> Maybe Double +localShare mOwn snap = do + own <- mOwn + let n = Map.findWithDefault 0 (Colored own) (snapColors snap) + pure (fromIntegral n / fromIntegral (max 1 (snapDrained snap))) diff --git a/bench/tx-firehose/src/Cardano/Benchmarking/TxFirehose/Color.hs b/bench/tx-firehose/src/Cardano/Benchmarking/TxFirehose/Color.hs index 4032fe8ee89..e728d4c8049 100644 --- a/bench/tx-firehose/src/Cardano/Benchmarking/TxFirehose/Color.hs +++ b/bench/tx-firehose/src/Cardano/Benchmarking/TxFirehose/Color.hs @@ -1,4 +1,5 @@ {-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE LambdaCase #-} -- | Colours that tag a firehose's transactions, so a mempool observer can tell -- whose load a mempool is holding. @@ -9,6 +10,8 @@ module Cardano.Benchmarking.TxFirehose.Color , resolveColor , colorHex , colorBytes + , colorFromBytes + , colorFromOctets , colorSwatch , colorMetadataLabel ) where @@ -27,7 +30,7 @@ data Color = Color , colorGreen :: !Word8 , colorBlue :: !Word8 } - deriving (Eq, Show) + deriving (Eq, Ord, Show) -- | What @--color@ asked for: a literal colour, or one derived from the key. data ColorSpec @@ -105,6 +108,16 @@ colorHex (Color r g b) = printf "%02x%02x%02x" r g b colorBytes :: Color -> ByteString colorBytes (Color r g b) = BS.pack [r, g, b] +-- | Read a colour back out of the three metadata bytes. +colorFromBytes :: ByteString -> Maybe Color +colorFromBytes = colorFromOctets . BS.unpack + +-- | The wire format in one place: exactly three octets, red green blue. +colorFromOctets :: [Word8] -> Maybe Color +colorFromOctets = \case + [r, g, b] -> Just (Color r g b) + _ -> Nothing + -- | The colour itself, as a 24-bit background block for a terminal. colorSwatch :: Color -> String colorSwatch (Color r g b) = printf "\ESC[48;2;%d;%d;%dm \ESC[0m" r g b diff --git a/cabal.project b/cabal.project index 95109d2ec42..46ad7e96406 100644 --- a/cabal.project +++ b/cabal.project @@ -47,6 +47,7 @@ packages: bench/plutus-scripts-bench bench/tx-generator bench/tx-firehose + bench/mempool-monitor bench/cardano-timeseries-io bench/trace-schemas/scripts/schema-gen trace-resources From c8eedf6931c333a70c8cba550fd783f72bd15e46 Mon Sep 17 00:00:00 2001 From: Sebastian Nagel Date: Mon, 24 Aug 2026 11:24:43 +0200 Subject: [PATCH 3/6] tx-firehose: log the colour on each submitted tx Both submit events now carry a color field, so a transaction is attributable from the log and not only from its metadata. Useful when reconciling what a generator sent against what an observer found in a mempool. Absent rather than null when --color is unset, so uncoloured runs keep the log shape the digest scripts already read. --- bench/tx-firehose/README.md | 5 +++++ bench/tx-firehose/app/Main.hs | 9 +++++++-- 2 files changed, 12 insertions(+), 2 deletions(-) diff --git a/bench/tx-firehose/README.md b/bench/tx-firehose/README.md index 0081d3ddee6..f2355406b28 100644 --- a/bench/tx-firehose/README.md +++ b/bench/tx-firehose/README.md @@ -83,6 +83,11 @@ sev, host, thread, ns, data}`). Namespaces: - `TxFirehose.Build.Fail` - `TxFirehose.Exit.MaxErrors` +Both submit events carry a `color` field when `--color` is set, so each +transaction is attributable in the log as well as in its metadata. The field is +absent rather than null without `--color`, leaving uncoloured runs' logs +unchanged. + Pipe stderr into Loki/Vector to filter on `ns` in Grafana. ## Exit behaviour diff --git a/bench/tx-firehose/app/Main.hs b/bench/tx-firehose/app/Main.hs index 06d40d51432..9373b0e6566 100644 --- a/bench/tx-firehose/app/Main.hs +++ b/bench/tx-firehose/app/Main.hs @@ -328,6 +328,9 @@ mkFirehoseClient sbe opts addr sk initialFunds mColor = !target = fromIntegral (optOutputsPerTx opts) :: Int !mFixedInputs = fromIntegral <$> optInputsPerTx opts :: Maybe Int !maxErrs = optMaxConsecutiveErrors opts + -- Present only when there is a colour, so uncoloured runs keep the log shape + -- the digest scripts already read. + colorField = ["color" .= colorHex c | Just c <- [mColor]] -- With a fixed input count we can only ever build a tx while that many -- funds are on hand; ramping instead always has a move, down to one @@ -394,21 +397,23 @@ mkFirehoseClient sbe opts addr sk initialFunds mColor = case result of SubmitSuccess -> do trace "TxFirehose.Submit.Success" "Info" $ - Aeson.object + Aeson.object $ [ "txId" .= btxId , "size" .= btxSize , "inputs" .= btxInputs , "outputs" .= length btxOutputs ] + ++ colorField let !funds'' = foldr addOutput fundsOnSuccess btxOutputs step funds'' 0 SubmitFail reason -> do trace "TxFirehose.Submit.Reject" "Warning" $ - Aeson.object + Aeson.object $ [ "txId" .= btxId , "size" .= btxSize , "reason" .= T.pack (show reason) ] + ++ colorField -- Keeping the inputs is right for a transient reject, but wrong when -- the ledger says they are gone: 'takeInputs' is deterministic, so -- the retry rebuilds this exact tx and earns this exact rejection, From b0001a6002276bfc6525ec0059bd5bb05b43f748 Mon Sep 17 00:00:00 2001 From: Sebastian Nagel Date: Mon, 24 Aug 2026 11:31:17 +0200 Subject: [PATCH 4/6] mempool-monitor: label the capacity bar as bytes GetSizes reports capacityInBytes as txMeasureByteSize of the mempool's capacity, that is one projection of a multi-dimensional measure. The mempool's own measure is TxMeasureWithDiffTime, and every TxMeasureMetrics method forgets the DiffTime, so the validation-time budget reaches neither GetSizes nor GetMeasures. That budget is what binds first on the Leios prototype, where the bounded configuration stopped accepting around 34k transactions on roughly five seconds of validation time rather than on bytes. An unlabelled bar therefore reads as fullness while showing a dimension with plenty of room left. --- bench/mempool-monitor/README.md | 11 +++++++++-- .../src/Cardano/Benchmarking/MempoolMonitor/Render.hs | 7 ++++++- 2 files changed, 15 insertions(+), 3 deletions(-) diff --git a/bench/mempool-monitor/README.md b/bench/mempool-monitor/README.md index 441f0c20c22..18728202da1 100644 --- a/bench/mempool-monitor/README.md +++ b/bench/mempool-monitor/README.md @@ -23,7 +23,7 @@ much of this mempool came from the generator attached to this node. mempool-monitor bp1 slot 41205 depth 27015 tx 17.6 / 25.0 MB - [########################..........] + bytes [########################..........] colours 2 local ff0000 62% [====================|========|====] <- painted in the real tx colours ff0000 16700 62% @@ -48,12 +48,19 @@ single message, so the expensive part is only the colour tally. Ten seconds between snapshots is therefore the default: fragmentation evolves over tens of seconds, so a faster rate buys nothing and costs real work. -Two consequences worth keeping in mind: +Three consequences worth keeping in mind: - **The observer is not free.** It acquires one snapshot per round rather than one per transaction, so the cost should be modest, but it is not nothing. Treat "monitor attached" as a condition to measure rather than a neutral act, and keep it constant across arms of any comparison. +- **The capacity bar is bytes, not fullness.** `MsgGetSizes` reports only the + byte projection of a multi-dimensional capacity, and the mempool's own measure + additionally carries a validation-time dimension that neither `GetSizes` nor + `GetMeasures` exposes. On the Leios prototype that time budget is what binds + first, so a mempool that has stopped accepting can show this bar at a fraction + of full. Trust `depth` and the composition; treat the bar as one dimension of + several. - **`drained` is a check, not decoration.** It must agree with the `txs` figure that `MsgGetSizes` reports for the same snapshot. Two independent counts of one quantity; disagreement means the drain did not complete. diff --git a/bench/mempool-monitor/src/Cardano/Benchmarking/MempoolMonitor/Render.hs b/bench/mempool-monitor/src/Cardano/Benchmarking/MempoolMonitor/Render.hs index 86a9ad4e5be..6463c4ff30a 100644 --- a/bench/mempool-monitor/src/Cardano/Benchmarking/MempoolMonitor/Render.hs +++ b/bench/mempool-monitor/src/Cardano/Benchmarking/MempoolMonitor/Render.hs @@ -58,7 +58,12 @@ renderPane label mOwn snap = (mb (sizeInBytes sizes)) (mb (capacityInBytes sizes)) - capacityBar = meter (fillRatio (sizeInBytes sizes) (capacityInBytes sizes)) + -- Labelled as bytes on purpose. GetSizes reports only the byte projection of + -- a multi-dimensional capacity, and the mempool's own measure also carries a + -- validation-time dimension that this protocol never exposes. On the Leios + -- prototype that time budget is what actually binds, so a full mempool can sit + -- at a fraction of this bar. Read it as bytes, not as fullness. + capacityBar = "bytes " ++ meter (fillRatio (sizeInBytes sizes) (capacityInBytes sizes)) colorLine = printf "colours %d%s" (distinctColors snap) ownSuffix From 1f2526852ab72b96177982f1ce28500feb0234de Mon Sep 17 00:00:00 2001 From: Sebastian Nagel Date: Mon, 24 Aug 2026 12:22:23 +0200 Subject: [PATCH 5/6] mempool-monitor: --interval is a period, not a gap The delay ran after the drain, so a 2 s drain on a 10 s interval gave a 12 s cadence: the requested rate was never the actual one, and the error grew with mempool depth. Now it sleeps only the remainder of the period, so the cadence is what was asked for, and a drain that overruns degrades to draining continuously rather than quietly stretching. --- bench/mempool-monitor/README.md | 11 +++++++++-- .../Cardano/Benchmarking/MempoolMonitor/Snapshot.hs | 11 +++++++---- 2 files changed, 16 insertions(+), 6 deletions(-) diff --git a/bench/mempool-monitor/README.md b/bench/mempool-monitor/README.md index 18728202da1..60a0bf9b6bd 100644 --- a/bench/mempool-monitor/README.md +++ b/bench/mempool-monitor/README.md @@ -45,8 +45,15 @@ transaction, so draining a 27,000-transaction mempool means 27,000 round trips and something like 17 MB. Depth and capacity come from `MsgGetSizes`, which is a single message, so the expensive part is only the colour tally. -Ten seconds between snapshots is therefore the default: fragmentation evolves -over tens of seconds, so a faster rate buys nothing and costs real work. +`--interval` is the period between snapshot *starts*, not a gap after each drain, +so the cadence is what you asked for rather than that plus however long draining +took. A drain that overruns its period degrades to draining continuously instead +of quietly stretching the cadence, which is visible in `drained ... in Xs`. + +Ten seconds is the default because a deployment's mempool depth is unknown and a +drain scales with it. Where the depth is known and drains measure in a second or +two, a shorter period is fine — watch the drain time against the period to see +what fraction of the time a node is being iterated. Three consequences worth keeping in mind: diff --git a/bench/mempool-monitor/src/Cardano/Benchmarking/MempoolMonitor/Snapshot.hs b/bench/mempool-monitor/src/Cardano/Benchmarking/MempoolMonitor/Snapshot.hs index ba196588836..8538a87e656 100644 --- a/bench/mempool-monitor/src/Cardano/Benchmarking/MempoolMonitor/Snapshot.hs +++ b/bench/mempool-monitor/src/Cardano/Benchmarking/MempoolMonitor/Snapshot.hs @@ -51,11 +51,13 @@ data Snapshot = Snapshot , snapTaken :: !UTCTime } --- | Acquire, size, drain, release, wait, repeat. +-- | Acquire, size, drain, release, wait out the rest of the period, repeat. -- -- The snapshot is acquired once per round and walked within it, so the whole --- tally is consistent. Draining is a round trip per transaction, which is why --- the interval between rounds is generous. +-- tally is consistent. Draining is a round trip per transaction, so it takes real +-- time, and the interval is the period between snapshot *starts* rather than a +-- gap tacked on afterwards. A drain that overruns its period therefore degrades +-- to draining continuously instead of silently stretching the cadence. monitorClient :: Int -> (Snapshot -> IO ()) -> @@ -83,7 +85,8 @@ monitorClient intervalMicros emit = LocalTxMonitorClient (pure idle) , snapTaken = finished } pure . SendMsgRelease $ do - threadDelay intervalMicros + let spent = round (realToFrac (finished `diffUTCTime` started) * 1e6 :: Double) + threadDelay (max 0 (intervalMicros - spent)) pure idle count key = Map.insertWith (+) key 1 From e0bfe2a8435b1394a744ecd5f04adaefe6c189f2 Mon Sep 17 00:00:00 2001 From: Sebastian Nagel Date: Mon, 24 Aug 2026 14:13:15 +0200 Subject: [PATCH 6/6] mempool-monitor: TSV header only for a fresh file A restart reopens the file in append mode and wrote another header into the middle of it, which breaks every reader downstream. A dozen-devnet run already had six of them in one file. --- bench/mempool-monitor/app/Main.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/bench/mempool-monitor/app/Main.hs b/bench/mempool-monitor/app/Main.hs index 58d7ddfa291..0545d50b2ad 100644 --- a/bench/mempool-monitor/app/Main.hs +++ b/bench/mempool-monitor/app/Main.hs @@ -18,6 +18,7 @@ import System.Exit (die) import System.IO ( BufferMode (LineBuffering) , IOMode (AppendMode) + , hFileSize , hIsTerminalDevice , hPutStrLn , hSetBuffering @@ -64,10 +65,13 @@ main = do Just (monitorClient (round (optInterval opts * 1_000_000)) emit) } where + -- Header only for a fresh file: a restart appends to the existing one, and a + -- header in the middle of it breaks every reader downstream. openTsv path = do handle <- openFile path AppendMode hSetBuffering handle LineBuffering - hPutStrLn handle tsvHeader + size <- hFileSize handle + when (size == 0) $ hPutStrLn handle tsvHeader pure handle connectInfo :: Options -> Api.LocalNodeConnectInfo