diff --git a/bench/cardano-profile/src/Cardano/Benchmarking/Profile/Builtin/Empty.hs b/bench/cardano-profile/src/Cardano/Benchmarking/Profile/Builtin/Empty.hs index 33040869fcf..e438ae4d677 100644 --- a/bench/cardano-profile/src/Cardano/Benchmarking/Profile/Builtin/Empty.hs +++ b/bench/cardano-profile/src/Cardano/Benchmarking/Profile/Builtin/Empty.hs @@ -48,13 +48,13 @@ baseNoDataset = -- TODO: Move to `base` when "default*" and "oldtracing" genesis are the same. genesis :: Types.Profile -> Types.Profile -genesis = V.genesisVariant300 +genesis = V.genesisVariantVoltaire -------------------------------------------------------------------------------- fastDuration :: Types.Profile -> Types.Profile fastDuration = - V.timescaleCompressed . P.shutdownOnBlock 1 + V.timescaleCompressed . P.shutdownOnBlock 180 -- TODO: dummy "generator.epochs" ignored in favor of "--shutdown-on". -- Create a "time.epochs" or "time.blocks" or similar, IDK! -- This applies to all profiles! @@ -63,7 +63,7 @@ fastDuration = ciTestDuration :: Types.Profile -> Types.Profile ciTestDuration = - V.timescaleCompressed . P.shutdownOnBlock 8 + V.timescaleCompressed . P.shutdownOnBlock 180 -- TODO: dummy "generator.epochs" ignored in favor of "--shutdown-on". -- Create a "time.epochs" or "time.blocks" or similar, IDK! -- This applies to all profiles! @@ -143,7 +143,7 @@ profilesNoEraEmpty = map baseNoDataset -- ci-test-hydra: FixedLoaded and "--shutdown-on-block-synced 3" with 2 nodes. ------------------------------------------------------------------------------ let ciTestHydra = - P.empty & V.datasetEmpty . V.genesisVariantPreVoltaire . ciTestDuration + P.empty & V.datasetEmpty . genesis . ciTestDuration . P.uniCircle . V.hosts 2 . P.loopback . P.analysisSizeSmall in [ diff --git a/bench/cardano-profile/src/Cardano/Benchmarking/Profile/Vocabulary.hs b/bench/cardano-profile/src/Cardano/Benchmarking/Profile/Vocabulary.hs index f9aa0f2af83..e8d7f3b7172 100644 --- a/bench/cardano-profile/src/Cardano/Benchmarking/Profile/Vocabulary.hs +++ b/bench/cardano-profile/src/Cardano/Benchmarking/Profile/Vocabulary.hs @@ -114,13 +114,148 @@ genesisVariantVoltaire = genesisVariantLatest -- Definition vocabulary: funds. -------------------------------- +-- | Estimate the number of genesis UTxO keys (funds) required for continuous +-- load generation using @on_confirm@ recycling. +-- +-- @ +-- funds = ceiling((M + J + D × B + Q × S) / S × I) +-- @ +-- +-- * @M@: single-node mempool capacity in bytes +-- (@MempoolCapacityBytesOverride@ rounded up to whole blocks by Consensus). +-- * @J@: disjoint mempool bytes across all nodes. The caller pre-computes +-- this as @nodes × (1 - syncRatio) × mempool@; 0 for perfect sync. +-- * @D@: confirmation depth (blocks on top before recycling). +-- * @Q@: payload queue depth (built txs waiting to be fetched by workers). +-- * @B@: effective block body size in bytes (@maxBlockBodySize@ minus +-- @fixedBlockBodyOverhead@ (1024) to account for block serialization +-- overhead not captured by summing individual tx sizes). +-- * @S@: serialised transaction size in bytes. +-- * @I@: inputs per transaction (= UTxO keys consumed per tx). +-- +-- Counts the maximum funds simultaneously locked in the pipeline: +-- +-- @ +-- payload queue (Q txs) → mempool (M bytes) → unconfirmed (D blocks) → recycled +-- @ +-- +-- __TPS is irrelevant.__ The tx-centrifuge is pull-based, the node requests +-- transactions when its mempool has room. In steady state the submission rate +-- is driven by block production, not TPS. TPS only determines how quickly the +-- mempool fills initially, that is enough txs to fill all mempools if the +-- resulting drain rate allows it. +-- +-- __Mempool sync ratio.__ With perfect sync (@syncRatio = 1.0@) all mempools +-- hold the same txs and the mempool counts once. In practice, propagation +-- latency and asymmetric connectivity cause partial disjointness: each node +-- has a fraction of unique txs that still consume funds. The effective +-- mempool is @syncRatio × M + nodes × (1 - syncRatio) × M@. With +-- @syncRatio = 1.0@ this collapses to @M@ (count once); with +-- @syncRatio = 0.7@ and 52 nodes it becomes @0.7 × M + 52 × 0.3 × M@. +-- +-- __Confirmation depth and fork safety.__ Forks of depth <= D are safe, the +-- recycler receives orphan events and recycles original inputs. Forks deeper +-- than D cause permanent fund loss (outputs already recycled, originals gone). +-- Fork frequency depends only on the active slot coefficient @f@ (typically +-- 0.05); a depth-K fork requires K consecutive slot battles (≈ 0.001^K), +-- making D = 2 safe for virtually all configurations. +-- +-- __Payload queue (Q).__ The builder's payload queue (bounded TBQueue, +-- hardcoded to 8192 in Config.Runtime) holds already-built transactions +-- whose input funds are already consumed. Back-to-back blocks can drain +-- this queue before the recycler/builder refill it, fatal with +-- @on_exhaustion = error@. The queue depth is counted in transactions +-- (not blocks) and contributes directly to the in-flight fund count. +utxoKeys + :: Integer -- ^ Payload queue capacity (built txs waiting to be fetched). + -- Hardcoded to 8192 in Config.Runtime. + -> Integer -- ^ Mempool capacity in bytes (per node). + -> Integer -- ^ Disjoint mempool bytes across all nodes. Total unique bytes + -- not shared by all mempools: @nodes × (1 - syncRatio) × mempool@. + -- 0 for perfect sync; the caller pre-computes this from the + -- number of nodes and the estimated sync ratio. + -> Integer -- ^ Max block body size in bytes (protocol parameter). + -> Integer -- ^ Confirmation depth (blocks on top before recycling). + -- Also the fork protection depth: forks of depth <= D are safe; + -- deeper forks cause permanent fund loss. + -> Integer -- ^ Serialised transaction size in bytes. + -> Integer -- ^ Inputs per transaction. + -> Integer -- ^ Estimated number of genesis UTxO keys (funds) needed. +utxoKeys queueDepth mempoolBytes disjointBytes blockBytes confirmDepth txBytes inputsPerTx = + let -- Block capacity: blockBytes - fixedBlockBodyOverhead (1024). + effectiveBlockBytes = blockBytes - 1024 + -- The mempool uses its own size accounting, not wire sizes. + -- See fixedBlockBodyOverhead and perTxOverhead in + -- Ouroboros.Consensus.Shelley.Ledger.Mempool. + -- Tx size in mempool: sizeTxF + perTxOverhead (4, hardcoded constant). + -- sizeTxF is ~1 byte smaller than the wire size (Api.serialiseToCBOR), so + -- the net mempool tx size is ~3 bytes larger than the wire size. + txBytesMempool = txBytes + 3 + -- Consensus rounds the override up to whole blocks (ceiling division + -- using the effective block size, not raw maxBlockBodySize); + -- see computeMempoolCapacity in Ouroboros.Consensus.Mempool.Capacity. + effectiveMempoolBlocks = + (mempoolBytes + effectiveBlockBytes - 1) `div` effectiveBlockBytes + effectiveMempoolBytes = effectiveMempoolBlocks * effectiveBlockBytes + -- Total pipeline depth in bytes (switch to Double for division). + pipelineBytes = fromIntegral (effectiveMempoolBytes + disjointBytes) + + fromIntegral (confirmDepth * effectiveBlockBytes) + + fromIntegral (queueDepth * txBytesMempool) :: Double + in ceiling (pipelineBytes / fromIntegral txBytesMempool * fromIntegral inputsPerTx) + -- Defined in the "genesis" property and it's for the tx-generator. fundsDefault :: Types.Profile -> Types.Profile -fundsDefault = P.poolBalance 1000000000000000 . P.funds 10000000000000 . P.utxoKeys 1 +fundsDefault = P.poolBalance 1000000000000000 . P.funds 10000000000000 + . P.utxoKeys + (utxoKeys + -- Payload queue depth (Config.Runtime TBQueue capacity). + 8192 + -- MempoolCapacityBytesOverride, rounded internally like + -- Consensus does. + 25000000 + -- Disjoint mempool bytes (0 = perfect sync). + 0 + -- Max block body size (bytes). + 90112 + -- Confirmation depth (blocks on top); AKA fork protection. + 2 + -- Steady-state tx size (bytes). The initial batch uses + -- genesis keys (one per fund, 2 witnesses → 371 bytes), but + -- after recycling all inputs share the builder's single + -- signing key (1 witness → 270 bytes). Use the steady-state + -- size: smaller txs means more txs fit per block, so more + -- funds are needed to keep the pipeline full. + 270 + -- Inputs per tx. + 2 + ) -- Some profiles have a higher `funds_balance` in `Genesis`. Needed? Fix it? fundsDouble :: Types.Profile -> Types.Profile -fundsDouble = P.poolBalance 1000000000000000 . P.funds 20000000000000 . P.utxoKeys 1 +fundsDouble = P.poolBalance 1000000000000000 . P.funds 20000000000000 + . P.utxoKeys + (utxoKeys + -- Payload queue depth (Config.Runtime TBQueue capacity). + 8192 + -- MempoolCapacityBytesOverride, rounded internally like + -- Consensus does. + 25000000 + -- Disjoint mempool bytes: 52 nodes, 1.1% disjoint each. + (52 * 25000000 * 11 `div` 1000) + -- Max block body size (bytes). + 90112 + -- Confirmation depth (blocks on top); AKA fork protection. + 2 + -- Steady-state tx size (bytes). The initial batch uses + -- genesis keys (one per fund, 2 witnesses → 371 bytes), but + -- after recycling all inputs share the builder's single + -- signing key (1 witness → 270 bytes). Use the steady-state + -- size: smaller txs means more txs fit per block, so more + -- funds are needed to keep the pipeline full. + 270 + -- Inputs per tx. + 2 + ) fundsVoting :: Types.Profile -> Types.Profile fundsVoting = P.poolBalance 1000000000000000 . P.funds 40000000000000 . P.utxoKeys 2 diff --git a/bench/tx-centrifuge/LICENSE b/bench/tx-centrifuge/LICENSE new file mode 100644 index 00000000000..f433b1a53f5 --- /dev/null +++ b/bench/tx-centrifuge/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/tx-centrifuge/NOTICE b/bench/tx-centrifuge/NOTICE new file mode 100644 index 00000000000..df6a765c219 --- /dev/null +++ b/bench/tx-centrifuge/NOTICE @@ -0,0 +1,14 @@ +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/tx-centrifuge/README.md b/bench/tx-centrifuge/README.md new file mode 100644 index 00000000000..9fbe3568d9f --- /dev/null +++ b/bench/tx-centrifuge/README.md @@ -0,0 +1,676 @@ +# Tx Centrifuge & Pull-Fiction + +`tx-centrifuge` is a high-performance load generator for Cardano, built on top of the protocol-agnostic **Pull-Fiction** library. + +Unlike traditional load generators that "push" data at a fixed rate, this system is designed for **pull-based protocols**. It does not generate load by itself; instead, it acts as a **policer** that reacts to requests from downstream consumers, admitting or delaying them to enforce a configured rate ceiling. + +### Minimal Configuration Example + +A basic configuration defines how to load initial resources, how to build payloads, the desired rate, and where to send the results: + +```json +{ + "initial_inputs": { "source": "genesis-funds" }, + "input_sources": { + "genesis-funds": { + "type": "genesis_utxo_keys", + "params": { + "signing_keys_file": "funds.json" + } + } + }, + "builder": { + "type": "value", + "params": { "fee": 1000000 }, + "recycle": { "type": "on_pull" } + }, + "rate_limit": { "type": "token_bucket", "params": { "tps": 10 } }, + "workloads": { + "group-A": { + "targets": { + "node-1": { "addr": "127.0.0.1", "port": 30000 }, + "node-2": { "addr": "127.0.0.1", "port": 30001 } + } + } + }, + "nodeConfig": "node-config.json" +} +``` + +## Core Concepts: The Pull-Fiction Engine + +The underlying `pull-fiction` library implements a reactive rate-limiting strategy. It only produces data when a consumer asks for it, and only as fast as the rate limiter allows. + +### Architecture + +``` + ┌───────────────┐ + │ Initial UTxOs │ + └───────┬───────┘ + │ + (partitioned) + │ + ┌─────────────────────────────┼─────────────────────────────┐ + │ │ │ + ▼ ▼ ▼ +┌─────────────────────────┐ ┌─────────────────────────┐ ┌─────────────────────────┐ +│ Workload A │ │ Workload B │ │ Workload N │ +├─────────────────────────┤ ├─────────────────────────┤ ├─────────────────────────┤ +│ │ │ │ │ │ +│ ┌─────────────────┐ │ │ ┌─────────────────┐ │ │ ┌─────────────────┐ │ +│ │ Input Queue │ │ │ │ Input Queue │ │ │ │ Input Queue │ │ +│ │ (unbounded) │ │ │ │ (unbounded) │ │ │ │ (unbounded) │ │ +│ └────────┬────────┘ │ │ └────────┬────────┘ │ │ └────────┬────────┘ │ +│ │ │ │ │ │ │ │ │ +│ ▼ │ │ ▼ │ │ ▼ │ +│ ┌─────────────────┐ │ │ ┌─────────────────┐ │ │ ┌─────────────────┐ │ +│ │ Builder │ │ │ │ Builder │ │ │ │ Builder │ │ +│ │ (build & sign) │ │ │ │ (build & sign) │ │ │ │ (build & sign) │ │ +│ └────────┬────────┘ │ │ └────────┬────────┘ │ │ └────────┬────────┘ │ +│ │ │ │ │ │ │ │ │ +│ ▼ │ │ ▼ │ │ ▼ │ +│ ┌─────────────────┐ │ │ ┌─────────────────┐ │ │ ┌─────────────────┐ │ +│ │ Payload Queue │ │ │ │ Payload Queue │ │ │ │ Payload Queue │ │ +│ │ (bounded) │ │ │ │ (bounded) │ │ │ │ (bounded) │ │ +│ └────────┬────────┘ │ │ └────────┬────────┘ │ │ └────────┬────────┘ │ +│ │ │ │ │ │ │ │ │ +│ ┌─────┴─────┐ │ │ ┌─────┴─────┐ │ │ ┌─────┴─────┐ │ +│ ▼ ▼ │ │ ▼ ▼ │ │ ▼ ▼ │ +│ ┌────────┐ ┌────────┐ │ │ ┌────────┐ ┌────────┐ │ │ ┌────────┐ ┌────────┐ │ +│ │Worker 1│ │Worker 2│ │ │ │Worker 1│ │Worker 2│ │ │ │Worker 1│ │Worker 2│ │ +│ └───┬────┘ └───┬────┘ │ │ └───┬────┘ └───┬────┘ │ │ └───┬────┘ └───┬────┘ │ +│ │ │ │ │ │ │ │ │ │ │ │ +│ ▼ ▼ │ │ ▼ ▼ │ │ ▼ ▼ │ +│ NodeToNode ... │ │ NodeToNode ... │ │ NodeToNode ... │ +│ (multiplexed) │ │ (multiplexed) │ │ (multiplexed) │ +│ │ │ │ │ │ │ │ │ │ │ │ +│ ▼ ▼ │ │ ▼ ▼ │ │ ▼ ▼ │ +│ ┌──────┐ ┌──────┐ │ │ ┌──────┐ ┌──────┐ │ │ ┌──────┐ ┌──────┐ │ +│ │Node 1│ │Node 2│ │ │ │Node 3│ │Node 4│ │ │ │Node 5│ │Node 6│ │ +│ └──────┘ └──────┘ │ │ └──────┘ └──────┘ │ │ └──────┘ └──────┘ │ +│ │ │ │ │ │ +│ ◄── recycle outputs ───┤ │ ◄── recycle outputs ───┤ │ ◄── recycle outputs ───┤ +│ │ │ │ │ │ +└─────────────────────────┘ └─────────────────────────┘ └─────────────────────────┘ +``` + +**Pipeline flow:** +1. **Initial UTxOs** are loaded and **partitioned** across workloads +2. Each workload's share enters its **Input Queue** (unbounded) +3. A **Builder** (one per workload) pulls inputs, assembles and signs transactions, and pushes `(tx, outputs)` to the **Payload Queue** (bounded — sole source of backpressure) +4. **Workers** (one per target) pull from the Payload Queue via rate-limited fetchers +5. Workers connect to Cardano nodes via a **multiplexed NodeToNode** connection running **TxSubmission2** and **KeepAlive** mini-protocols (optionally **ChainSync** + **BlockFetch** for confirmation-based recycling) +6. **Outputs are recycled** back to the workload's Input Queue according to the configured `recycle` strategy, enabling indefinite-duration runs + +### Reactive Rate Limiting +- **Downstream Driven**: Load is only dispensed in response to an explicit pull from a target. If the target doesn't ask, the engine stays idle. +- **Ceiling Enforcement**: The rate limiter enforces a tokens-per-second (TPS) ceiling. Even if a consumer pulls aggressively, the engine ensures the dispensed items never exceed the configured limit. +- **Fairness**: Token slots are claimed in a single atomic STM transaction, providing FIFO-fair scheduling across multiple workers sharing the same limiter. + +### Workloads and Targets +The configuration is organized into a hierarchy that defines the concurrency model: + +- **Target**: A single network endpoint (e.g., a Cardano node). Each target has a dedicated **Worker thread** that manages the network connection and handles requests. +- **Workload**: A logical grouping of targets. + - All targets within a workload share the same **Builder thread** and the same **Payload Queue**. + - **Transaction Profiles**: Each workload can define its own `builder` configuration. This allows you to generate different "profiles" of transactions (e.g., different sizes, complexities, or fees) for different groups of nodes. + - **Isolation**: By using multiple workloads, you can isolate different groups of targets. For example, one workload could simulate high-volume "small" transactions for one group of nodes, while another generates "heavy" transactions for another. + +### Pipeline Architecture +The engine operates as a decoupled production pipeline using generic `input` and `payload` types: +1. **Initial Inputs**: Starting resources are partitioned across workloads and bulk-loaded into each workload's Input Queue at startup. +2. **Input Queue (Unbounded)**: Holds available inputs. +3. **Builder (One per Workload)**: A dedicated thread that pulls inputs, produces a payload, and handles recycling according to the configured strategy (see [Resource Recycling](#resource-recycling)). It pushes the payload to the payload queue. +4. **Payload Queue (Bounded)**: The sole source of **backpressure**. The builder blocks here if consumers are slower than the production rate. +5. **Workers (One per Target)**: Threads that manage the consumer connection. They pull from the payload queue via a rate-limited fetcher. + +### Resource Recycling +To enable indefinite-duration runs with finite resources, inputs must be returned to the `Input Queue`. The `recycle` field on the `builder` selects when this happens. There are three strategies: + +1. **`on_build`** — Resources return to the `Input Queue` as soon as the payload is constructed: the build itself counts as the confirmation, so the recycler releases the outputs right away (an `AddToBacklog` and an `AddToPipe` trace per payload). This is the highest-throughput mode but assumes the payload will be successfully processed downstream. + ```json + "recycle": { "type": "on_build" } + ``` +2. **`on_pull`** — The recycler remembers the payload's resources when it is built and returns them to the `Input Queue` when a worker **dequeues** the payload from the pipe (triggered by a downstream request), on its own thread. Recycling happens on dequeue, not on downstream acknowledgement. + + > **TODO:** rename the config value `on_pull` to `on_dequeue` — the strategy recycles when the payload is *dequeued* from the pipe, not on a TxSubmission "pull". Kept as `on_pull` for backward compatibility (the code type is already `RecycleOnDequeue`). + + ```json + "recycle": { "type": "on_pull" } + ``` +3. **`on_confirm`** — Resources stay in the recycler's backlog until an **observer** confirms the transaction on-chain at the configured confirmation depth. The builder enqueues the payload without any inputs; a background recycler async reads confirmations from the observer's broadcast channel and recycles matching inputs. This is the safest mode for long-running benchmarks where mempool eviction is a concern. + ```json + "recycle": { "type": "on_confirm", "params": "my-observer" } + ``` +#### Rollback recovery (`recovery`) + +Any builder with a `recycle` strategy may additionally carry a **`recovery`**, a sibling of `recycle` in the builder object, naming the observer whose orphan events trigger it and the input source that rebuilds the queued inputs: +```json +"recycle": { "type": "on_build" }, +"recovery": { "observer": "my-observer", "source": "my-node-utxo" } +``` +For `on_confirm`, `observer` may be omitted and defaults to the confirm observer; `on_build` and `on_pull` require it (they have no observer to default to): +```json +"recycle": { "type": "on_confirm", "params": "my-observer" }, +"recovery": { "source": "my-node-utxo" } +``` +The `source` must name a `utxo_query` entry in the top-level [`input_sources`](#input-sources-input_sources) pool (a static file source cannot reflect the chain after a rollback): +```json +"input_sources": { + "my-node-utxo": { "type": "utxo_query", "params": { "socket_path": "node.socket" } } +} +``` +With a `recovery`, an orphan event from the named observer no longer recovers just that transaction's consumed inputs: the recycler drops every queued input (potentially poisoned by the rollback), drops every queued payload built from those inputs (equally stale: they either descend from orphaned transactions or double-spend the lineage the reseed restarts), and reseeds the input queue from chain truth, querying the UTxOs currently at the builder's destination address through the source's NodeToClient `socket_path`. The observer and the source are independent: any observer type works, and the source's socket may point at a different node than the one the observer follows. The observer stays an independent shared entity: builders with and without a `recovery` can name the same observer, each with its own pipeline, and every observer connection runs once no matter how many builders or purposes reference it. A subscription delivers the observer's full stream, and the workload takes what applies to its strategy (for `on_confirm`, a different `recovery` observer's confirms also count as confirmations). An explicitly named observer is always subscribed, so explicitly repeating the confirm observer creates a second subscription with each event delivered twice: duplicate orphans are ignored or rerun an idempotent reseed, and duplicate confirms are ignored (the payload is no longer held). The socket is probed once at startup, so a wrong `socket_path` fails immediately rather than at the first rollback. At runtime a failed query is reported and retried every second until it succeeds; the builder keeps building from the stale queue meanwhile (payloads delivered in that window fail harmlessly downstream, the rest are flushed by the reset) and the reset replaces the queue once the query lands, traced as `TxCentrifuge.Recycler.Reset`. One rollback triggers one recovery. Under `on_confirm` the reset is additionally **keyed**: the recycler applies it only while the orphaned transaction is still held awaiting its confirm, so an orphan of a *foreign* transaction (the observer stream is unfiltered) or a duplicate delivery is ignored and no reset happens — foreign traffic cannot reset an `on_confirm` recovery, and a rollback's orphan burst collapses at that gate (at one recovery query per orphan event). Under `on_build` and `on_pull` the orphaned transaction was already released at build or dequeue, so the reset cannot be gated: it applies on any settled orphan, foreign or not, and the orphan events that accumulate while the recovery runs are discarded. + +This is what makes the optimistic strategies (`on_build`, `on_pull`) safe to run with few funds (down to a single one): transactions are allowed to fail in the window between submission and confirmation, and the recovery resets the input queue to chain truth when a rollback invalidates them, instead of provisioning enough funds to keep every in-flight transaction valid. + +**Topology note**: an optimistic builder's transactions form dependency chains (each spends the previous one's output), so point each optimistic workload at a **single node**, one workload per node, each with its own signing key, observer and socket. Spreading one optimistic builder across many targets both races transaction diffusion between nodes (a child can reach a node before its parent) and lets a fork on a non-observed node go undetected. + +## Configuration + +### Node Configuration (`nodeConfig`) +The top-level `nodeConfig` field is the path to the Cardano node's configuration file (e.g., `node-config.json`). The generator reads the consensus protocol from it and derives the network it runs against (mainnet or a testnet magic) from that protocol. This is the single source of the network: it is used to build addresses, submit transactions, and query the node for UTxOs, so no network magic is configured anywhere else. + +### Input Sources (`input_sources`) +The top-level `input_sources` pool defines named ways to obtain UTxO funds, as `type` + `params` entries like observers. Sources are referenced by name from [`initial_inputs`](#initial-inputs-initial_inputs) (the startup load) and from builder [`recovery`](#rollback-recovery-recovery) entries (rebuilding a builder's queued inputs after a rollback). Validation enforces that every referenced source is defined and that every defined source is referenced. Observer and input source names live in independent namespaces (every reference field is typed: `source` resolves against `input_sources`, `observer` against `observers`), so an observer and a source may share a name. + +The `type` field selects the source. Two variants are available: + +**`genesis_utxo_keys`** — load funds from a JSON file. `params`: +- **`signing_keys_file`**: Path to a JSON file (e.g., `funds.json`) containing the actual fund data. + +#### `funds.json` entry types +The file contains an array of fund objects. Each object has two required fields (`signing_key`, `value`) and one optional field (`tx_in`): + +| Field | Required | Description | +|---------------|----------|-------------| +| `signing_key` | Yes | Path to a `.skey` file (payment or genesis UTxO key) | +| `value` | Yes | Lovelace amount | +| `tx_in` | No | Explicit UTxO reference in `"txid#ix"` format | + +When `tx_in` is **present**, the fund uses the explicit UTxO reference: +```json +{ "signing_key": "payment.skey", "value": 1000000, "tx_in": "df6...#0" } +``` + +When `tx_in` is **omitted**, the fund is treated as a genesis UTxO: the `TxId` is derived deterministically from the signing key's verification key hash via `genesisUTxOPseudoTxIn`, and the `TxIx` is always 0. +```json +{ "signing_key": "genesis.skey", "value": 1500000000000 } +``` + +**Design Note**: The `funds.json` format is designed to be compatible with the output of `cardano-cli conway create-testnet-data --utxo-keys`. This allows you to immediately use an arbitrary large set of Shelley genesis keys created during testnet bootstrapping as the initial fund pool for the generator, without needing to manually create UTxOs once the network is live. + +#### `utxo_query` +Discover funds **on chain** instead of from a file. The generator queries a node (over its NodeToClient socket) for the UTxOs currently at one or more addresses. The addresses come from the use site: `initial_inputs` supplies signing keys in its `params`, a builder `recovery` queries the builder's own destination address. + +`params`: +- **`socket_path`**: Path to the local node's NodeToClient socket. + +The query era is detected from the node at runtime, so it follows the chain across the Shelley-based eras cardano-api supports (Shelley through Conway today). + +### Initial Inputs (`initial_inputs`) +The generator requires a set of initial UTxOs, loaded through a named input source at startup. `initial_inputs` always has a **`source`** (the name of the `input_sources` entry to load from); whether it also has a **`params`** depends on that source's type. There are exactly two combinations: + +**With a `genesis_utxo_keys` source** — the source is self-contained (its file holds everything), so `initial_inputs` is just the reference. Adding `params` here is a startup error: + +```json +"initial_inputs": { "source": "genesis-funds" }, +"input_sources": { + "genesis-funds": { + "type": "genesis_utxo_keys", + "params": { "signing_keys_file": "funds.json" } + } +} +``` + +**With a `utxo_query` source** — the source only knows *how* to query (the socket); this use site must say *which addresses*, so `params` with **`signing_keys`** is required (omitting it is a startup error). Each listed `.skey`'s derived address is queried, and every UTxO found there becomes an initial fund tagged with that key (so it can be spent): + +```json +"initial_inputs": { + "source": "node-utxo", + "params": { "signing_keys": ["dest.skey"] } +}, +"input_sources": { + "node-utxo": { + "type": "utxo_query", + "params": { "socket_path": "/run/node/node.sock" } + } +} +``` + +(A builder `recovery` using the same `utxo_query` source carries no such params: it always queries the builder's own destination address.) + +Loading through a `utxo_query` source makes restarts **stateless**: each builder recycles its outputs back to its `destination_signing_key` address, so pointing the `signing_keys` at those same keys re-discovers whatever a previous run left on chain. If no UTxOs are found at any queried address, the generator exits with an error rather than starting. Fund the address of at least one configured `signing_keys` entry and restart. + +### Rate Limiting (`rate_limit`) +The `rate_limit` field can be set at the **top level** or at the **workload level** (but not both — setting it at both levels is a validation error). If omitted entirely, targets run **unlimited** (no rate ceiling). + +The `scope` determines the granularity of the TPS ceiling. Available scopes depend on where the rate limit is defined: + +**Top-level scopes:** +- **`shared`** (default): A single rate limiter shared by all targets across all workloads. The configured TPS is the aggregate ceiling. +- **`per_workload`**: Each workload gets its own independent rate limiter at the full configured TPS (shared by its targets). +- **`per_target`**: Every target gets its own independent rate limiter at the full configured TPS. E.g., 10 TPS with 50 targets = 500 TPS aggregate. + +**Workload-level scopes:** +- **`shared`** (default): One rate limiter shared by all targets in the workload. The configured TPS is the aggregate ceiling for the workload. +- **`per_target`**: Every target in the workload gets its own independent rate limiter at the full configured TPS. + +### Cascading Defaults + +Most configuration fields can be set at multiple levels. The most specific value wins: + +- **`builder`**: workload > top-level. Setting it at **both** levels is a validation error. At least one must be set (no default). +- **`rate_limit`**: workload > top-level > **unlimited**. Setting it at **both** levels is a validation error. +- **`max_batch_size`**: target > workload > top-level > **0 (unlimited)**. +- **`on_exhaustion`**: target > workload > top-level > **`block`**. + +Workload, target, observer, and input source names must be non-empty, must not start with `@`, and must not contain `.` or `/` (`@` and `.` are reserved for internal rate-limiter cache keys, `/` for the forwarder pool's wiring-path keys). + +### Batching and Flow Control +- **`max_batch_size`**: Limits the number of items (e.g., transactions) the generator will announce to a target in a single protocol request. **0 means unlimited** (use whatever the node requests). Defaults to 0. + - This acts as a safety cap: even if a target's protocol allows for 500 items, a `max_batch_size` of 100 ensures the generator doesn't commit too much capacity to a single connection at once. + - This helps distribute the available "payload queue" more evenly across multiple targets and prevents a single aggressive node from starving others. +- **`on_exhaustion`**: + - `block`: The worker thread waits until the builder produces a new payload. + - `error`: The generator fails immediately if the builder cannot keep up with the requested TPS. + +### Startup Delay (`startup_delay_seconds`) +An optional **top-level** field that delays the start of transmission. Waits this many seconds before the workers open their connections to the targets but after the builders are spawned and filling the payload queues. + +- **Value**: a non-negative integer number of **seconds**. +- **Default**: `0` (also the effect when the field is absent or `null`). Workers connect as soon as they are spawned (no delay, no log line). +- **Scope**: top level only. It applies to the whole run and does **not** cascade to workloads or targets. + +```json +{ + "rate_limit": { "type": "token_bucket", "params": { "tps": 100000 } }, + "startup_delay_seconds": 300, + "workloads": { "...": {} } +} +``` + +### Tracing + +The generator emits structured traces through `trace-dispatcher` (the same +library the node uses). Trace settings live in the **same config file** you pass +to `tx-centrifuge`, under a `TraceOptions` object keyed by namespace: `""` is the +root default and every other key overrides one namespace. When `TraceOptions` is +absent, a default applies that writes every namespace to **stdout** in machine +(JSON) format at `Debug` severity, so all traces are on out of the box. + +```json +{ + "rate_limit": { "type": "token_bucket", "params": { "tps": 100000 } }, + "workloads": { "...": {} }, + + "TraceOptions": { + "": { + "severity": "Info", + "detail": "DNormal", + "backends": ["Stdout MachineFormat"] + }, + "TxCentrifuge.Pipe": { "severity": "Silence" }, + "TxCentrifuge.Recycler": { "maxFrequency": 1.0 }, + "TxCentrifuge.Observer": { "severity": "Silence" }, + "TxCentrifuge.Builder.NewTx": { "detail": "DMaximum" }, + "TxCentrifuge.TxSubmission": { "detail": "DDetailed" }, + "TxSubmission2": { "severity": "Silence" }, + "KeepAlive": { "severity": "Silence" } + } +} +``` + +Per namespace you can set `severity` (the minimum level to emit, or `Silence` to +drop it), `detail` (`DMinimal`, `DNormal`, `DDetailed`, `DMaximum`), `backends` +(such as `Stdout MachineFormat`, `Stdout HumanFormatColoured`, or `Forwarder`), +and `maxFrequency` (a cap in messages per second). The application-level traces +(severity `Info` unless noted) are: + +| Namespace | What it reports | Detail levels | +| :--- | :--- | :--- | +| `TxCentrifuge.Builder.NewTx` | A new transaction was built from input UTxOs, producing output UTxOs. Carries the builder name and the TxId. Fires once per built transaction. | `DDetailed` adds the `inputs`/`outputs` as UTxO reference strings. `DMaximum` renders each fund in full (`utxo` + `lovelace`) and adds the `destination` address the tx pays to. | +| `TxCentrifuge.Pipe.InputsEnqueued` | Inputs were added to a pipe's input queue (initial funds or recycled ones). Carries the pipe name and the resulting queue `depth`. | `DDetailed` adds a `count` of the inputs. `DMaximum` adds the `inputs` array, each fund with its `utxo` reference and `lovelace` value. | +| `TxCentrifuge.Pipe.InputsDequeued` | Inputs were taken off the input queue for the builder. Carries the pipe name and the resulting queue `depth`. | `DDetailed` adds a `count` of the inputs. `DMaximum` adds the `inputs` array, each fund with its `utxo` reference and `lovelace` value. | +| `TxCentrifuge.Pipe.PayloadEnqueued` | A payload was added to the bounded payload queue. Carries the pipe name and the resulting queue `depth`. | `DMaximum` adds the payload's `txId` (payload events carry no `count`). | +| `TxCentrifuge.Pipe.PayloadDequeued` | A payload was pulled off the payload queue by a worker. Carries the pipe name and the observed queue `depth`. | `DMaximum` adds the payload's `txId` (payload events carry no `count`). | +| `TxCentrifuge.Recycler.AddToBacklog` | A payload's entry was added to the recycler's backlog: its key and its two input sets, held until a release (a confirm or an orphan) picks one. Carries the recycler name and the resulting `backlog` (the number of payloads held but not yet released). | `DDetailed` adds a `consumed_count` and an `outputs_count`. `DMaximum` adds the payload's `txId` and the `consumed` and `outputs` arrays, each fund with its `utxo` reference and `lovelace` value. | +| `TxCentrifuge.Recycler.AddToPipe` | The recycler added a held payload's inputs back onto a pipe's input queue (via `Pipe.addInputs`), closing the loop. Carries the recycler name, the pipe name, and the resulting `backlog`. | `DDetailed` adds a `count` of the recycled inputs. `DMaximum` adds the `inputs` array, each fund with its `utxo` reference and `lovelace` value. | +| `TxCentrifuge.Recycler.Reset` | The recycler reset a pipe for a builder's `recovery`: the queued inputs and the queued payloads built from them were dropped, and the input queue was reseeded from chain truth. Carries the recycler name, the pipe name, and the resulting `backlog` (always 0, a reset clears the backlog). Severity `Warning`. | `DDetailed` adds a `count` of the fresh inputs, a `dropped_inputs_count` and a `dropped_payloads_count`. `DMaximum` adds the `inputs` (fresh) and `dropped_inputs` arrays (each fund with its `utxo` reference and `lovelace` value) and the `dropped_payloads` array of txIds. | +| `TxCentrifuge.Observer.Announce` | The observer saw a transaction confirmed or orphaned (rolled back), carrying the observer name, the TxId, and an `isOrphan` flag. Fires only for confirmation-based workloads, but there it is currently **unfiltered**: it reports every transaction in the confirmed blocks its node sees, not just this generator's, so its volume is roughly the whole chain's throughput. | All fields are shown at every level. | +| `TxCentrifuge.TxSubmission.RequestTxIds` | The node requested TxId announcements (blocking or non-blocking). Carries the `target` node and the ACK and REQ counts. | `DDetailed` and up add the list of currently unacked TxIds. | +| `TxCentrifuge.TxSubmission.ReplyTxIds` | We replied with TxId announcements and their sizes. Carries the `target`. | `DDetailed` and up add the ACK and REQ counts, the announced TxIds with sizes, and the updated unacked list. | +| `TxCentrifuge.TxSubmission.RequestTxs` | The node requested full transactions by TxId. Carries the `target`. | `DDetailed` and up add the list of requested TxIds. | +| `TxCentrifuge.TxSubmission.ReplyTxs` | We sent the requested transactions. Carries the `target`. | `DDetailed` and up add the sent TxIds with sizes, plus the list the node requested. | + +Every `TxSubmission` trace carries a `target` field naming the remote node, so +submission activity can be attributed per target. The `Pipe`, `Recycler`, and +`Observer` traces fire on roughly every transaction. Each `Pipe` event carries +its queue `depth` and each `Recycler` event its `backlog` count (the number of +payloads held but not yet released) on every event and at every detail level. +Raising `detail` to `DDetailed` adds counts of the items involved (input and +recycler events only, since pipe payload events carry no count), and `DMaximum` +adds the items themselves (the funds, or a payload's `txId`). At +high TPS that is a firehose, so you will usually want to silence them or cap them +with `maxFrequency`. Because a `maxFrequency` cap samples a namespace at a fixed +rate, setting it on these depth-carrying traces gives a periodic depth readout +(the equivalent of a periodic queue-depth tracer) straight from config, with no +code change. The `Observer` trace is unfiltered today (see the table above), so +it too runs at roughly chain throughput. Below the application traces, the raw +`ouroboros-network` +protocol is traced verbosely under the `TxSubmission2` and `KeepAlive` +namespaces. + +## Cardano Implementation (`tx-centrifuge`) + +### Value Builder Parameters +These parameters define the **transaction profile** for a workload: +- `inputs_per_tx` / `outputs_per_tx`: Controls the transaction structure (size and complexity). +- `fee`: Fixed Lovelace fee per transaction. +- `destination_signing_key` (optional): Path to a `.skey` file (a payment or genesis UTxO key, like the `signing_key` entries in funds.json) whose address receives every output this builder produces and which spends the recycled UTxOs. When omitted, a built-in per-builder key is derived instead. Supplying your own key lets you fund and inspect a known address, which is printed to stderr at startup. +- `recycle` (optional): Controls when output UTxOs are returned to the input queue. See [Resource Recycling](#resource-recycling) for the three strategies (`on_build`, `on_pull`, `on_confirm`). When omitted, outputs are **not recycled** — the generator consumes initial funds and eventually exhausts them. +- `recovery` (optional): Rollback recovery for this builder, resetting its input queue from an input source when an observer reports one of its transactions orphaned. Requires `recycle`. See [Rollback recovery](#rollback-recovery-recovery). + +## Usage + +```bash +tx-centrifuge config.json # run the generator +tx-centrifuge --dry-run config.json # validate config + funds, then exit 0 +``` + +With `--dry-run`, tx-centrifuge performs all startup validation (config parsing, consensus protocol setup, and on-chain fund discovery) and exits before creating any pipelines or generating traffic. Use it to check a config and its funding (for example after a restart or fresh funding) without producing load. + +## Detailed Examples + +### 1. High-Throughput (On-Build Recycling) +Optimized for maximum TPS using simple 1-in/1-out transactions. Outputs are recycled immediately after building (`on_build`), before the transaction enters the payload queue. + +**`config.json` snippet:** +```json +{ + "initial_inputs": { "source": "genesis-funds" }, + "input_sources": { + "genesis-funds": { + "type": "genesis_utxo_keys", + "params": { + "signing_keys_file": "funds.1.json" + } + } + }, + "builder": { + "type": "value", + "params": { + "inputs_per_tx": 1, + "outputs_per_tx": 1, + "fee": 1000000 + }, + "recycle": { "type": "on_build" } + }, + "rate_limit": { + "type": "token_bucket", + "scope": "shared", + "params": { "tps": 1000 } + }, + "workloads": { + "simulation": { + "targets": { + "node-0": { "addr": "127.0.0.1", "port": 30000 } + } + } + }, + "nodeConfig": "node-config.json" +} +``` + +**`funds.1.json` snippet:** +```json +[ + {"signing_key": "utxo1.skey", "value": 1500000000000}, + {"signing_key": "utxo2.skey", "value": 1500000000000} +] +``` + +### 2. Large Transactions (Target-Specific Limits) +Uses complex transactions with independent rate limits for each target connection. Outputs are recycled on fetch (`on_pull`). + +**`config.json` snippet:** +```json +{ + "initial_inputs": { "source": "genesis-funds" }, + "input_sources": { + "genesis-funds": { + "type": "genesis_utxo_keys", + "params": { + "signing_keys_file": "funds.2.json" + } + } + }, + "builder": { + "type": "value", + "params": { + "inputs_per_tx": 5, + "outputs_per_tx": 5, + "fee": 2000000 + }, + "recycle": { "type": "on_pull" } + }, + "rate_limit": { + "type": "token_bucket", + "scope": "per_target", + "params": { "tps": 5 } + }, + "max_batch_size": 50, + "on_exhaustion": "block", + "workloads": { + "heavy-load": { + "targets": { + "edge-node": { "addr": "192.168.1.10", "port": 30001 } + } + } + }, + "nodeConfig": "node-config.json" +} +``` + +**`funds.2.json` snippet:** +```json +[ + {"signing_key": "utxo1.skey", "value": 1000000000}, + {"signing_key": "utxo2.skey", "value": 1000000000}, + {"signing_key": "utxo3.skey", "value": 1000000000} +] +``` + +### 3. Confirmation-Based Recycling (On-Confirm with Observer) +Uses an observer that follows the chain to track when submitted transactions are confirmed on-chain. Outputs are only recycled back to the input queue after the transaction reaches a configured confirmation depth, protecting against mempool eviction and short rollbacks. Rolled-back transactions are held in limbo and orphaned (original inputs recycled) if they do not reappear within 2×`confirmation_depth` blocks. + +Two observer types are supported: + +#### `nodetonode` — N2N ChainSync + BlockFetch + +Connects to a remote node over TCP. The observer follows the chain via ChainSync (headers) and fetches block bodies via BlockFetch to extract transaction IDs. + +```json +"observers": { + "chain-follower": { + "type": "nodetonode", + "params": { + "addr": "127.0.0.1", + "port": 30000, + "confirmation_depth": 2 + } + } +} +``` + +| Field | Type | Description | +|----------------------|--------|-------------| +| `addr` | string | IP address of the node | +| `port` | int | Node-to-node port | +| `confirmation_depth` | int | Blocks to wait before confirming (0 = immediate) | + +#### `nodetoclient` — N2C LocalChainSync + +Connects to the local node over a Unix domain socket. The observer follows the chain via LocalChainSync, which delivers full blocks directly — no separate BlockFetch needed. This is simpler, and forward-compatible with Leios (see `docs/Leios.md`). + +```json +"observers": { + "local-follower": { + "type": "nodetoclient", + "params": { + "socket_path": "/tmp/node.socket", + "confirmation_depth": 2 + } + } +} +``` + +| Field | Type | Description | +|----------------------|--------|-------------| +| `socket_path` | string | Path to the node's local Unix domain socket | +| `confirmation_depth` | int | Blocks to wait before confirming (0 = immediate) | + +#### Choosing between the two + +Both emit the same `BlockTx` events on the same broadcast channel type, so the downstream recycler and workloads are unaffected by the choice. The builder references the observer by name regardless of type: + +```json +"recycle": { "type": "on_confirm", "params": "local-follower" } +``` + +| Concern | `nodetonode` | `nodetoclient` | +|--------------------------|-------------------------------------|----------------------------------| +| Transport | TCP (any reachable node) | Unix socket (co-located node) | +| Leios forward-compatible | No — needs new IB/EB relay clients | Yes — node serves merged blocks | +| Protocols on the mux | ChainSync + BlockFetch + KeepAlive | ChainSync only | +| Requires local node | No | Yes | + +#### Full example (`nodetoclient`) + +```json +{ + "initial_inputs": { "source": "genesis-funds" }, + "input_sources": { + "genesis-funds": { + "type": "genesis_utxo_keys", + "params": { + "signing_keys_file": "funds.3.json" + } + } + }, + "observers": { + "local-follower": { + "type": "nodetoclient", + "params": { + "socket_path": "/tmp/node.socket", + "confirmation_depth": 2 + } + } + }, + "builder": { + "type": "value", + "params": { + "inputs_per_tx": 2, + "outputs_per_tx": 2, + "fee": 1000000 + }, + "recycle": { "type": "on_confirm", "params": "local-follower" } + }, + "rate_limit": { + "type": "token_bucket", + "scope": "shared", + "params": { "tps": 50 } + }, + "max_batch_size": 500, + "on_exhaustion": "error", + "workloads": { + "confirmed-load": { + "targets": { + "node-0": { "addr": "127.0.0.1", "port": 30000 } + } + } + }, + "nodeConfig": "node-config.json" +} +``` + +**`funds.3.json` snippet:** +```json +[ + {"signing_key": "utxo1.skey", "value": 1500000000000}, + {"signing_key": "utxo2.skey", "value": 1500000000000}, + {"signing_key": "utxo3.skey", "value": 1500000000000} +] +``` + +With `on_confirm`, the generator needs enough initial funds to cover the in-flight transactions between submission and confirmation. At 50 TPS with a 2-block confirmation depth (~40 seconds on a 20-second slot), roughly 2000 transactions will be pending at any time, so the initial fund pool should have at least that many UTxOs. + +## Internals + +### Package Structure + +``` +tx-centrifuge/ +├── tx-centrifuge.cabal # Package definition +├── app/ +│ └── Main.hs # Executable entry point +├── lib/ +│ ├── pull-fiction/ # Domain-independent load generation library +│ │ └── Cardano/Benchmarking/PullFiction/ +│ │ ├── Config/ +│ │ │ ├── Raw.hs # JSON parsing (no validation) +│ │ │ ├── Validated.hs # Validation + cascading defaults +│ │ │ └── Runtime.hs # Resolves config into named pools + limiters +│ │ ├── Clock.hs # Monotonic time source +│ │ ├── WorkloadRunner.hs # Rate-limited per-target workers +│ │ └── Internal/ +│ │ ├── Pipe.hs # Generic input + payload queue pair +│ │ ├── RateLimiter.hs # GCRA token bucket +│ │ └── Recycler.hs # Closed-loop input recycling (worker, strategy-free) +│ │ +│ └── tx-centrifuge/ # Cardano-specific library +│ └── Cardano/Benchmarking/TxCentrifuge/ +│ ├── Block.hs # Shared block types and tx extraction +│ ├── Fund.hs # UTxO/fund loading from JSON +│ ├── NodeToClient.hs # Multiplexed N2C connection (local socket) +│ ├── NodeToClient/ +│ │ ├── TxIdSync.hs # LocalChainSync tx confirmation (full blocks) +│ │ ├── TxSubmission.hs # LocalTxSubmission client +│ │ └── UTxOQuery.hs # LocalStateQuery UTxO discovery +│ ├── NodeToNode.hs # Multiplexed N2N connection (TCP) +│ ├── NodeToNode/ +│ │ ├── KeepAlive.hs # KeepAlive mini-protocol client +│ │ ├── TxIdSync.hs # ChainSync + BlockFetch tx confirmation +│ │ └── TxSubmission.hs # TxSubmission2 mini-protocol client +│ ├── TxAssembly.hs # Transaction building and signing +│ ├── Tracing.hs # Structured logging via trace-dispatcher +│ └── Tracing/ +│ └── Orphans.hs # LogFormatting/MetaTrace instances +│ +├── test/ # Test suites +│ ├── lib/ # Shared test harness (private library) +│ │ └── Test/PullFiction/ +│ │ └── Harness.hs +│ ├── pull-fiction/ # Pull-fiction unit tests +│ └── tx-centrifuge/ # Tx-centrifuge unit tests +│ +└── bench/ # Benchmarks + └── Bench.hs +``` + +### Data Flow + +``` +Raw JSON → Validated Config → Runtime (STM queues, rate limiters, builder asyncs) + │ + ┌──────────────────────────────┘ + ↓ + [Builder Async] per workload + reads TQueue(inputs) → buildTx → TBQueue(payloads, 8192 cap) + ↓ + [Worker Asyncs] per target + GCRA rate-limited fetch → TxSubmission2 pull protocol → cardano-node + ↓ + [Recycler] closed-loop + outputs → back to TQueue(inputs) +``` diff --git a/bench/tx-centrifuge/app/Main.hs b/bench/tx-centrifuge/app/Main.hs new file mode 100644 index 00000000000..8f19702742e --- /dev/null +++ b/bench/tx-centrifuge/app/Main.hs @@ -0,0 +1,911 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE NumericUnderscores #-} + +-------------------------------------------------------------------------------- + +module Main (main) where + +-------------------------------------------------------------------------------- + +---------- +-- base -- +---------- +import Control.Concurrent (threadDelay) +import Control.Exception (finally) +import Control.Monad (forever, when) +import Data.Bifunctor (first) +import Data.List.NonEmpty qualified as NE +import Data.Maybe (fromMaybe) +import Data.Monoid (Last(..)) +import Numeric.Natural (Natural) +import System.Environment (getArgs) +import System.Exit (die, exitSuccess) +import System.IO (hPutStrLn, stderr) +import Text.Printf (printf) +----------- +-- aeson -- +----------- +import Data.Aeson ((.:), (.:?)) +import Data.Aeson qualified as Aeson +import Data.Aeson.Types qualified as Aeson.Types +----------- +-- async -- +----------- +import Control.Concurrent.Async qualified as Async +---------------- +-- bytestring -- +---------------- +import Data.ByteString.Char8 qualified as BS8 +----------------- +-- cardano-api -- +----------------- +import Cardano.Api qualified as Api +------------------------- +-- cardano-ledger-core -- +------------------------- +import Cardano.Ledger.Coin qualified as L +------------------ +-- cardano-node -- +------------------ +import Cardano.Node.Configuration.POM + ( parseNodeConfigurationFP + , makeNodeConfiguration + , defaultPartialNodeConfiguration + , PartialNodeConfiguration(..) + , NodeConfiguration + , ncProtocolConfig + ) +import Cardano.Node.Handlers.Shutdown (ShutdownConfig(..)) +import Cardano.Node.Protocol.Cardano (mkSomeConsensusProtocolCardano) +import Cardano.Node.Protocol.Types (SomeConsensusProtocol(..)) +import Cardano.Node.Types + ( ConfigYamlFilePath(..) + , KESSource(..) + , NodeProtocolConfiguration(..) + , ProtocolFilepaths(..) + ) +---------------- +-- containers -- +---------------- +import Data.Map.Strict qualified as Map +------------- +-- network -- +------------- +import Network.Socket qualified as Socket +--------------------------------------------- +-- ouroboros-consensus:ouroboros-consensus -- +--------------------------------------------- +import Ouroboros.Consensus.Block.Abstract (CodecConfig) +import Ouroboros.Consensus.Config (configBlock, configCodec) +import Ouroboros.Consensus.Config.SupportsNode (getNetworkMagic) +import Ouroboros.Consensus.Node.ProtocolInfo (ProtocolInfo(..)) +--------------------------------- +-- ouroboros-network:framework -- +--------------------------------- +import Ouroboros.Network.IOManager (withIOManager) +--------- +-- stm -- +--------- +import Control.Concurrent.STM qualified as STM +---------- +-- text -- +---------- +import Data.Text qualified as Text +------------------ +-- transformers -- +------------------ +import Control.Monad.Trans.Except (runExceptT) +------------------ +-- pull-fiction -- +------------------ +import Cardano.Benchmarking.PullFiction.Config.Raw qualified as Raw +import Cardano.Benchmarking.PullFiction.Config.Runtime qualified as Runtime +import Cardano.Benchmarking.PullFiction.Config.Validated qualified as Validated +import Cardano.Benchmarking.PullFiction.WorkloadRunner (runWorkload) +------------------- +-- tx-centrifuge -- +------------------- +import Cardano.Benchmarking.TxCentrifuge.Block qualified as Block +import Cardano.Benchmarking.TxCentrifuge.NodeToClient qualified as N2C +import Cardano.Benchmarking.TxCentrifuge.NodeToClient.TxIdSync + qualified as TxIdSyncN2C +import Cardano.Benchmarking.TxCentrifuge.NodeToNode qualified as N2N +import Cardano.Benchmarking.TxCentrifuge.NodeToNode.KeepAlive + qualified as KeepAlive +import Cardano.Benchmarking.TxCentrifuge.NodeToNode.TxIdSync + qualified as TxIdSyncN2N +import Cardano.Benchmarking.TxCentrifuge.NodeToNode.TxSubmission + qualified as TxSubmission +import Cardano.Benchmarking.TxCentrifuge.Fund qualified as Fund +import Cardano.Benchmarking.TxCentrifuge.Tracing qualified as Tracing +import Cardano.Benchmarking.TxCentrifuge.TxAssembly qualified as TxAssembly + +-------------------------------------------------------------------------------- +-- Era +-------------------------------------------------------------------------------- + +-- | The Shelley-based era this generator builds and submits transactions in. +-- Every era-specific type in this module is written in terms of 'Era', and +-- 'era' below is its value-level witness. Moving to another era means changing +-- these two definitions (and wiring the era through the rest of the pipeline). +type Era = Api.ConwayEra + +-- | Value-level witness of 'Era', for cardano-api builders that take an +-- 'Api.ShelleyBasedEra' argument (such as 'TxAssembly.buildTx'). +era :: Api.ShelleyBasedEra Era +era = Api.ShelleyBasedEraConway + +-------------------------------------------------------------------------------- + +main :: IO () +main = do + + -- Loand and validate config. + ----------------------------- + + (isDryRun, validated, codecConfig, networkId, networkMagic, tracers) <- + loadConfig + + -- Dry run: config, protocol and on-chain fund discovery have been validated, + -- so exit before creating resources or generating any traffic. + when isDryRun $ do + hPutStrLn stderr "Dry run OK: config and funds validated, exiting." + exitSuccess + + -- Callbacks / handlers. + ------------------------ + + -- From 'String' (address) and 'Int' (port) to 'AddrInfo'. + let resolveAddr ip port = do + let hints = Socket.defaultHints + { Socket.addrSocketType = Socket.Stream + , Socket.addrFamily = Socket.AF_INET + } + addrs <- Socket.getAddrInfo + (Just hints) + (Just ip) + (Just (show port)) + case addrs of + [] -> die $ "Cannot resolve target: " ++ ip ++ ":" ++ show port + (a:_) -> pure a + + -- Builder factory passed to 'Runtime.resolve'. Returns a 'BuilderHandle'. + -- Receives builder's zero-based index and name and the opaque builder config. + let mkBuilder builderIndex builderName rawBuilder = do + -- Interpret the opaque builder config into a concrete builder, with its + -- destination signing key and address already resolved. + builder <- interpretBuilder networkId builderIndex rawBuilder + -- Announce the destination address so an operator knows which address + -- to fund and can inspect its UTxOs. + hPutStrLn stderr $ + "Builder " ++ builderName ++ ": destination address " + ++ Text.unpack (Api.serialiseAddress (destinationAddress builder)) + -- This builder owns its loop: it pulls a fixed 'inputsPerTx' batch, + -- builds a transaction, and either publishes it or, when the batch is + -- unbuildable (an all-dust batch whose input value does not cover the + -- fee), drops it and stays up. The engine hands over 'api', a sealed + -- window onto this builder's pipe and recycler. + pure $ Runtime.BuilderHandle $ \api -> forever $ do + inputFunds <- Runtime.baTakeInputs api (inputsPerTx builder) + let buildTxAns = TxAssembly.buildTx + era + (destinationAddress builder) + (destinationSigningKey builder) + inputFunds (outputsPerTx builder) + (L.Coin (fee builder)) + case buildTxAns of + -- A per-batch value failure: these particular inputs cannot cover + -- the fee plus one valid output each (the only 'buildTx' failure + -- that depends on the inputs). Abandon the batch via 'baDropInputs' + -- (the engine neither recycles nor enqueues it), then emit the + -- TxCentrifuge.Builder.InputsDropped trace. Action first, then the + -- trace, as everywhere else. + -- + -- Whole-batch, not per-input, on purpose: 'buildTx' sums ALL + -- inputs, so a batch fails only when they are COLLECTIVELY worth at + -- most the fee. A small input among good ones is summed in and + -- spent, never dropped. Filtering out every input with value <= fee + -- would instead discard dust that is productively swept into a tx + -- today. + Left (TxAssembly.InsufficientValue reason) -> do + Runtime.baDropInputs api inputFunds + Tracing.traceWith + (Tracing.trBuilder tracers) + (Tracing.BuilderInputsDropped builderName inputFunds reason) + -- The remaining failures do not depend on the batch, so every batch + -- would hit them and dropping would spin forever: fail loudly. + -- 'InvalidInput' is a bad builder argument (already guarded in + -- 'interpretBuilder', so defensive here). 'LedgerFailure' is an + -- opaque cardano-api construction error. + Left (TxAssembly.InvalidInput reason) -> + die $ "TxAssembly.buildTx: invalid builder parameters: " ++ reason + Left (TxAssembly.LedgerFailure reason) -> + die $ "TxAssembly.buildTx: ledger construction failed: " ++ reason + Right (tx, outputFunds) -> do + -- The TxID is needed for the "on_confirm" recycling strategy. + let txId = Api.getTxId (Api.getTxBody tx) + -- Trace the newly built transaction + -- (TxCentrifuge.Builder.NewTx), purely a construction event, no + -- pipe/queue info. + Tracing.traceWith + (Tracing.trBuilder tracers) + (Tracing.BuilderNewTx + builderName txId (destinationAddress builder) + inputFunds outputFunds + ) + Runtime.baAddPayload api txId tx inputFunds outputFunds + + -- Pipe-events factory passed to 'Runtime.resolve'. Returns a 'PipeHandle' + -- Given builder's zero-based index and name create the handlers for the four + -- pipe's queue mechanics (TxCentrifuge.Pipe.*): payloads added/removed (with + -- the resulting queue depth) and inputs added/removed + -- (TxCentrifuge.Pipe.Inputs{Enqueued,Dequeued}, with the inputs themselves + -- and the resulting queue depth). + let mkPipeHandle _pipeIndex builderName = + pure Runtime.PipeHandle + { Runtime.phOnInputsEnqueued = \inputs depth -> + Tracing.traceWith (Tracing.trPipe tracers) + (Tracing.PipeInputsEnqueued builderName depth inputs) + , Runtime.phOnInputsDequeued = \inputs depth -> + Tracing.traceWith (Tracing.trPipe tracers) + (Tracing.PipeInputsDequeued builderName depth inputs) + , Runtime.phOnPayloadEnqueued = \key depth -> + Tracing.traceWith (Tracing.trPipe tracers) + (Tracing.PipePayloadEnqueued builderName depth key) + , Runtime.phOnPayloadDequeued = \key depth -> + Tracing.traceWith (Tracing.trPipe tracers) + (Tracing.PipePayloadDequeued builderName depth key) + } + + -- Recovery factory used by 'mkRecyclerHandle'. When the workload's builder + -- configured a "recovery" (carrying the observer whose orphan events trigger + -- it and the input source that rebuilds the queued inputs), build the + -- recovery action the forwarder runs on an orphan: query the UTxOs currently + -- at the builder's destination address through the source's socket, whose + -- result reseeds the builder's input queue (the recycler applies it via its + -- reset, which drops the stale queued inputs and the stale queued payloads + -- first). The source is independent of the observer, which stays a shared + -- entity the recovery never modifies: the orphan signal can come from any + -- observer type or node while the recovery queries a (typically local) + -- socket, and builders with and without a recovery can name the same + -- observer. Only a "utxo_query" source can rebuild inputs (a static file + -- cannot reflect the chain after a rollback). The socket is probed once here + -- so a wrong "socket_path" dies at startup, not at the first rollback. At + -- runtime a failed query reports and retries after a delay until it succeeds: + -- the orphan event that triggered it is already consumed, so giving up would + -- swallow this rollback's recovery and leave the queue poisoned until the + -- next one. The query returns failures as 'Left' and never throws (see + -- 'UTxOQuery.queryUTxOsAtAddresses'), so the retry loop swallows no + -- exceptions and a genuine exception still ends the run as everywhere. + let mkRecover builderIndex builderName = + case Map.lookup builderName (Validated.workloads validated) of + Nothing -> pure Nothing + Just wl -> + case Raw.builderRecovery (Validated.builder wl) of + Nothing -> pure Nothing + Just recovery -> do + -- The source reference is validated, the lookup is total. + let sourceName = Raw.recoverySource recovery + rawSource = + Validated.inputSources validated Map.! sourceName + socketPath <- case interpretInputSource rawSource of + Left err -> die $ + "input_sources." ++ sourceName ++ ": " ++ err + Right (UTxOQuerySource path) -> pure path + Right (GenesisKeysSource _) -> die $ + "Builder " ++ builderName ++ ": recovery source " + ++ show sourceName ++ " is a static file and cannot" + ++ " rebuild inputs after a reset, use a \"utxo_query\"" + ++ " source" + builder <- interpretBuilder + networkId builderIndex (Validated.builder wl) + -- Startup probe: only connectivity matters, an empty result + -- is fine (the address fills up as this builder's + -- transactions confirm). + eProbe <- Fund.discoverFundsAtAddresses + networkId socketPath + [ ( destinationSigningKey builder + , destinationAddress builder ) ] + case eProbe of + Left err -> die $ + "Builder " ++ builderName ++ ": recovery socket (" + ++ socketPath ++ "): " ++ err + Right _ -> pure () + pure $ Just $ + let attempt = do + eFunds <- Fund.discoverFundsAtAddresses + networkId socketPath + [ ( destinationSigningKey builder + , destinationAddress builder ) ] + case eFunds of + Left err -> do + hPutStrLn stderr $ + "Builder " ++ builderName + ++ ": recovery query failed" + ++ " (retrying in 1s): " ++ err + threadDelay 1_000_000 + attempt + Right funds -> pure funds + in attempt + + -- Recycler-events factory passed to 'Runtime.resolve'. Returns a + -- 'RecyclerHandle'. Given the builder's zero-based index and name, creates + -- the handlers that trace when a payload enters the backlog + -- (TxCentrifuge.Recycler.AddToBacklog), when its inputs are added to the + -- pipe (TxCentrifuge.Recycler.AddToPipe), and the optional recovery action + -- (see 'mkRecover'). The pipe and recycler are both named by the workload + -- here (one of each per workload). + let mkRecyclerHandle recyclerIndex builderName = do + recover <- mkRecover recyclerIndex builderName + pure Runtime.RecyclerHandle + { Runtime.rhOnAddToBacklog = \key consumed outputs backlog -> + Tracing.traceWith (Tracing.trRecycler tracers) + (Tracing.RecyclerAddToBacklog + builderName backlog key consumed outputs) + , Runtime.rhOnAddToPipe = \inputs backlog -> + Tracing.traceWith (Tracing.trRecycler tracers) + (Tracing.RecyclerAddToPipe builderName builderName backlog inputs) + -- The trace keeps the dropped payloads by txId (their key), not + -- the full transactions. + , Runtime.rhOnReset = \droppedInputs droppedPayloads fresh backlog -> + Tracing.traceWith (Tracing.trRecycler tracers) + (Tracing.RecyclerReset + builderName builderName + backlog (map fst droppedPayloads) droppedInputs fresh) + , Runtime.rhRecover = recover + } + + -- Observer factory passed to 'Runtime.resolve'. Returns an 'ObserverHandle'. + -- For each observer in the config creates an N2N or N2C connection for + -- transaction confirmation tracking. + -- Takes the 'IOManager' as first argument (partial-applied below). + let mkObserver ioManager _observerIndex observerName rawObserver = do + -- From JSON/Aeson.Value to the cardano-node specific observer. + observer <- case interpretObserver rawObserver of + Left err -> die $ "Observer " ++ observerName ++ ": " ++ err + Right o -> pure o + -- Observer announce loop: dup the confirmation broadcast and log every + -- confirmed/orphaned tx (TxCentrifuge.Observer.Announce), decoupled from + -- the pipe and recycling. Runs alongside the connection in 'ohRun'. + -- TODO: this is all-chain — it logs every confirmed tx the observer sees + -- on the chain, not just this generator's transactions (the broadcast is + -- unfiltered). Filter to our own txIds once Main tracks its in-flight set. + let announceLoop broadcast = do + chan <- STM.atomically $ STM.dupTChan broadcast + forever $ do + eitherBlockTx <- STM.atomically $ STM.readTChan chan + let (isOrphan, txId) = case eitherBlockTx of + Left blockTx -> (True, Block.blockTxId blockTx) + Right blockTx -> (False, Block.blockTxId blockTx) + Tracing.traceWith (Tracing.trObserver tracers) + (Tracing.ObserverAnnounce observerName txId isOrphan) + case observer of + -- N2N: ChainSync (headers) + BlockFetch (blocks) + KeepAlive. + -------------------------------------------------------------- + NodeToNode addr port depth -> do + syncState <- TxIdSyncN2N.emptyState + TxIdSyncN2N.Config + { TxIdSyncN2N.confirmationDepth = depth } + keepAlive <- KeepAlive.keepAliveClient 10 + let clients = N2N.emptyClients + { N2N.clientChainSync = + Just $ TxIdSyncN2N.chainSyncClient syncState + , N2N.clientBlockFetch = + Just $ TxIdSyncN2N.blockFetchClient syncState + , N2N.clientKeepAlive = Just keepAlive + } + addrInfo <- resolveAddr addr port + pure Runtime.ObserverHandle + { Runtime.ohRun = + -- The announce loop runs alongside the connection and is + -- cancelled when the connection ends. + Async.withAsync + (announceLoop (TxIdSyncN2N.stateBroadcast syncState)) $ \announceAsync -> do + -- Link the announce loop so its failure aborts the + -- observer instead of being silently swallowed. + Async.link announceAsync + result <- N2N.connect + ioManager codecConfig networkMagic tracers + addrInfo clients + case result of + Left err -> + die $ "observer " ++ observerName ++ ": " ++ err + Right () -> pure () + , Runtime.ohSubscribe = do + chan <- STM.atomically $ + STM.dupTChan (TxIdSyncN2N.stateBroadcast syncState) + -- Reduce each broadcast BlockTx to its TxId (the recycle key). + -- TODO: own-traffic filter. This adapter is where a future + -- filter should drop foreign events (txIds this generator + -- never built) before any forwarder, recovery query or reset + -- sees them: an in-flight txId set filled at build time and + -- pruned at confirm/orphan. Whether it lives here or as a + -- generic facility in pull-fiction is an open decision. Until + -- then, keyed resets (on_confirm) are gated by the recycler's + -- backlog and the optimistic strategies reset on any settled + -- orphan. + pure $ do + eitherBlockTx <- STM.readTChan chan + pure $ case eitherBlockTx of + Left blockTx -> Left (Block.blockTxId blockTx) + Right blockTx -> Right (Block.blockTxId blockTx) + } + -- N2C: LocalChainSync (full blocks, no BlockFetch needed). + ----------------------------------------------------------- + NodeToClient socketPath depth -> do + syncState <- TxIdSyncN2C.emptyState + TxIdSyncN2C.Config + { TxIdSyncN2C.confirmationDepth = depth } + let clients = N2C.emptyClients + { N2C.clientChainSync = + Just $ TxIdSyncN2C.chainSyncClient syncState + } + pure Runtime.ObserverHandle + { Runtime.ohRun = + Async.withAsync + (announceLoop (TxIdSyncN2C.stateBroadcast syncState)) $ \announceAsync -> do + -- Link the announce loop so its failure aborts the + -- observer instead of being silently swallowed. + Async.link announceAsync + result <- N2C.connect + ioManager codecConfig networkMagic tracers + socketPath clients + case result of + Left err -> + die $ "observer " ++ observerName ++ ": " ++ err + Right () -> pure () + , Runtime.ohSubscribe = do + chan <- STM.atomically $ + STM.dupTChan (TxIdSyncN2C.stateBroadcast syncState) + -- Reduce each broadcast BlockTx to its TxId (the recycle key). + -- TODO: own-traffic filter, same spot as the N2N adapter + -- above (see the note there). + pure $ do + eitherBlockTx <- STM.readTChan chan + pure $ case eitherBlockTx of + Left blockTx -> Left (Block.blockTxId blockTx) + Right blockTx -> Right (Block.blockTxId blockTx) + } + + -- The 'TargetWorker' callback (the last caller-supplied handler): run once + -- per 'Target' by 'runWorkload'. Connects to the target node and drives the + -- TxSubmission2 client with the two fetch actions. Takes the 'IOManager' + -- first (partial-applied inside 'withIOManager' below), the same shape as + -- 'mkObserver'. + let targetWorker ioManager target fetchTx tryFetchTx = do + addrInfo <- resolveAddr + (Runtime.targetAddr target) + (Runtime.targetPort target) + keepAliveClient <- KeepAlive.keepAliveClient 10 + result <- N2N.connect ioManager codecConfig networkMagic tracers addrInfo + N2N.emptyClients + { N2N.clientKeepAlive = Just keepAliveClient + , N2N.clientTxSubmission = Just $ + TxSubmission.txSubmissionClient + (Tracing.trTxSubmission tracers) + (Runtime.targetName target) + (Runtime.maxBatchSize target) + fetchTx tryFetchTx + } + case result of + Left err -> die $ Runtime.targetName target ++ ": " ++ err + Right () -> pure () + + -- Start workloads. + ------------------- + + -- IOManager: no-op on POSIX, required on Windows for IOCP. All network I/O + -- and cleanup must live inside this block as the handle is invalidated when + -- 'withIOManager' returns. + withIOManager $ \ioManager -> do + -- Resolve runtime: creates observers (via mkObserver), pipes, rate + -- limiters, and spawns builders. All asyncs are linked and tracked. + runtime <- Runtime.resolve + mkBuilder + mkPipeHandle + mkRecyclerHandle + (mkObserver ioManager) + validated + -- Startup delay. + -- Sleeps after the builders are already spawned and running so they keep + -- filling the payload queues for the whole delay, while the workers below + -- open their connections only after it elapses. + let startupDelaySeconds = Validated.startupDelaySeconds validated + when (startupDelaySeconds > 0) $ do + hPutStrLn stderr $ "Startup delay: waiting " ++ show startupDelaySeconds + ++ " second(s) (builders pre-filling queues)..." + threadDelay (fromIntegral startupDelaySeconds * 1_000_000) + hPutStrLn stderr "Startup delay complete, connecting to targets." + -- For each 'Workload'. + workers <- concat <$> mapM + (\workload -> runWorkload workload (targetWorker ioManager)) + (Map.elems $ Runtime.workloads runtime) + -- runWorkload returns unlinked asyncs; link them here so failures + -- propagate to the main thread immediately. + mapM_ Async.link workers + -- All asyncs (builders and workers) are linked to the main thread and run + -- forever. ANY completion, whether by exception or normal return, is fatal: + -- either the pipeline starved ('QueueStarved'), a connection dropped, or a + -- builder failed. + -- + -- 'waitAnyCatch' returns as soon as the first async finishes (without + -- re-throwing, so we keep control). 'finally cancelAll' then cancels every + -- remaining async before the program exits. + -- + -- 'Async.link' is still needed: if the main thread is blocked in + -- 'waitAnyCatch' waiting on async A but async B dies, 'link' delivers the + -- exception asynchronously, unblocking 'waitAnyCatch' immediately instead + -- of waiting for A to finish first. + let allAsyncs = Runtime.asyncs runtime ++ workers + cancelAll = mapM_ Async.cancel allAsyncs + (_, result) <- flip finally cancelAll $ + Async.waitAnyCatch allAsyncs + case result of + Left ex -> + die $ show ex + Right () -> + die "async terminated unexpectedly" + +-------------------------------------------------------------------------------- +-- Input source interpretation. +-------------------------------------------------------------------------------- + +-- | Interpreted input source: how to obtain UTxO funds. Referenced by +-- @initial_inputs@ (the startup load) and by builder recoveries (rebuilding the +-- queued inputs after a reset). +-- +-- This type is node-specific (it references signing keys and sockets), so it +-- lives here rather than in the @pull-fiction@ sub-library, which stores the +-- source params as an opaque 'Aeson.Value' (see 'Raw.InputSource'). +data FundSource + -- | Query the UTxOs at addresses through a NodeToClient socket. + = UTxOQuerySource !FilePath + -- | Load funds from a genesis signing-keys file. + | GenesisKeysSource !FilePath + +-- | Interpret a 'Raw.InputSource' (opaque type + params) into a concrete +-- 'FundSource'. +interpretInputSource :: Raw.InputSource -> Either String FundSource +interpretInputSource raw = case Raw.inputSourceType raw of + "utxo_query" -> + case Aeson.Types.parseEither parseQuery (Raw.inputSourceParams raw) of + Left err -> Left $ "InputSource params error: " ++ err + Right s -> Right s + "genesis_utxo_keys" -> + case Aeson.Types.parseEither parseGenesis (Raw.inputSourceParams raw) of + Left err -> Left $ "InputSource params error: " ++ err + Right s -> Right s + other -> Left $ + "InputSource: unknown \"type\" " ++ show other + ++ ", expected \"utxo_query\" or \"genesis_utxo_keys\"" + where + parseQuery = Aeson.withObject "UTxOQuery InputSourceParams" $ \o -> + UTxOQuerySource <$> o .: "socket_path" + parseGenesis = Aeson.withObject "GenesisKeys InputSourceParams" $ \o -> + GenesisKeysSource <$> o .: "signing_keys_file" + +-- | Interpret the opaque use-site @params@ of @initial_inputs@ for a +-- @utxo_query@ source: the signing key files. Each key's derived address is +-- queried, and every UTxO found there is tagged with that key so the spending +-- transaction can be signed. +parseInitialKeys :: Aeson.Value -> Aeson.Types.Parser [FilePath] +parseInitialKeys = Aeson.withObject "initial_inputs params" $ \o -> + o .: "signing_keys" + +-------------------------------------------------------------------------------- +-- Builder interpretation. +-------------------------------------------------------------------------------- + +-- | Interpreted "value" builder configuration with defaults applied. +data ValueBuilder + = ValueBuilder + { inputsPerTx :: !Natural + , outputsPerTx :: !Natural + , fee :: !Integer + , destinationSigningKey :: !(Api.SigningKey Api.PaymentKey) + , destinationAddress :: !(Api.AddressInEra Era) + } + +-- | Interpret a 'Raw.Builder' (opaque type + params) into a concrete +-- 'ValueBuilder'. Applies defaults (@inputs_per_tx@ = 1, @outputs_per_tx@ = 1), +-- validates invariants, and resolves the destination signing key and address. +-- +-- Each builder pays to (and recycles under) a single signing key. It comes from +-- the 'destination_signing_key' builder param when set, otherwise we fall back +-- to a per-index built-in key. The destination address is derived from it. +interpretBuilder :: Api.NetworkId -> Int -> Raw.Builder -> IO ValueBuilder +interpretBuilder networkId builderIndex raw = case Raw.builderType raw of + "value" -> + case Aeson.Types.parseEither parseValueParams (Raw.builderParams raw) of + Left err -> die $ "Builder params error: " ++ err + Right (maybeInputs, maybeOutputs, rawFee, maybeDestPath) -> do + let nInputs = fromMaybe 1 maybeInputs + nOutputs = fromMaybe 1 maybeOutputs + when (nInputs == 0) $ die "Builder: inputs_per_tx must be >= 1" + when (nOutputs == 0) $ die "Builder: outputs_per_tx must be >= 1" + when (rawFee < 0) $ die "Builder: fee must be >= 0" + (destKey, destAddr) <- case maybeDestPath of + Nothing -> pure (createSigningKeyAndAddress networkId builderIndex) + Just path -> do + eitherSkey <- Fund.readSigningKey path + case eitherSkey of + Left err -> + die $ "destination_signing_key (" ++ path ++ "): " ++ err + Right skey -> pure (skey, Fund.deriveAddress networkId skey) + pure ValueBuilder + { inputsPerTx = nInputs + , outputsPerTx = nOutputs + , fee = rawFee + , destinationSigningKey = destKey + , destinationAddress = destAddr + } + other -> die $ + "Builder: unknown type " ++ show other ++ ", expected \"value\"" + where + parseValueParams = Aeson.withObject "ValueParams" $ \o -> + (,,,) <$> o .:? "inputs_per_tx" + <*> o .:? "outputs_per_tx" + <*> o .: "fee" + <*> o .:? "destination_signing_key" + +-------------------------------------------------------------------------------- +-- Observer interpretation. +-------------------------------------------------------------------------------- + +-- | Interpreted observer. +data Observer + -- | Chain follow via N2N ChainSync (headers) + BlockFetch (blocks). + = NodeToNode !String !Int !Natural + -- | Chain follow via N2C LocalChainSync (full blocks, no BlockFetch needed). + | NodeToClient !FilePath !Natural + +-- | Interpret 'Raw.Observer' (opaque type + params) into a concrete 'Observer'. +interpretObserver :: Raw.Observer -> Either String Observer +interpretObserver raw = case Raw.observerType raw of + "nodetonode" -> + case Aeson.Types.parseEither parseN2N (Raw.observerParams raw) of + Left err -> Left $ "Observer params error: " ++ err + Right o -> Right o + "nodetoclient" -> + case Aeson.Types.parseEither parseN2C (Raw.observerParams raw) of + Left err -> Left $ "Observer params error: " ++ err + Right o -> Right o + other -> Left $ + "Observer: unknown \"type\" " ++ show other + ++ ", expected \"nodetonode\" or \"nodetoclient\"" + where + parseN2N = Aeson.withObject "N2N ObserverParams" $ \o -> + NodeToNode <$> o .: "addr" + <*> o .: "port" + <*> o .: "confirmation_depth" + parseN2C = Aeson.withObject "N2C ObserverParams" $ \o -> + NodeToClient <$> o .: "socket_path" + <*> o .: "confirmation_depth" + +-------------------------------------------------------------------------------- +-- Signing key loading +-------------------------------------------------------------------------------- + +-- | Built-in fallback signing key and address for a builder index, used when a +-- builder has no 'destination_signing_key'. Builds the key from a hex string, +-- applying an integer suffix to the last 3 hex characters, and derives its +-- address via 'deriveAddress'. +createSigningKeyAndAddress + :: Api.NetworkId + -> Int + -> (Api.SigningKey Api.PaymentKey, Api.AddressInEra Era) +createSigningKeyAndAddress networkId n + | n < 0 || n > 999 = + error $ "createSigningKeyAndAddress: out of range (0-999): " ++ show n + | otherwise = + let -- Hex string (32 bytes = 64 hex chars). + -- We use 61 chars + 3 chars suffix = 64 chars total. + -- If the input string is a CBOR-encoded hex string (e.g. from an + -- .skey file), strip the first 4 characters ("5820") which represent + -- the CBOR type and length prefix for 32 bytes of raw data. + prefix = "bed03030fd08a600647d99fa7cd94dae3ddab99b199c3f08f81949db3e422" + suffix = printf "%03d" n + hex = prefix ++ suffix + eitherSkey = Api.deserialiseFromRawBytesHex + @(Api.SigningKey Api.PaymentKey) + (BS8.pack hex) + in case eitherSkey of + Left err -> error $ + "createSigningKeyAndAddress: Failed to deserialise: " + ++ show err + Right signingKey -> + (signingKey, Fund.deriveAddress networkId signingKey) + +-------------------------------------------------------------------------------- +-- Cardano parameters +-------------------------------------------------------------------------------- + +{-- TODO: Construct a minimal protocol parameters, see TxAssembly.hs last line. +data ProtocolParameters = ProtocolParameters + { epochLength :: Integer + , minFeeA :: Integer + , minFeeB :: Integer + } + +instance Aeson.FromJSON ProtocolParameters where + parseJSON = Aeson.withObject "ProtocolParameters" $ \o -> do + pp <- o .: "params" + ProtocolParameters <$> pp .: "epoch_length" <*> pp .: "min_fee_a" <*> pp .: "min_fee_b" +--} + +-------------------------------------------------------------------------------- +-- Initialization +-------------------------------------------------------------------------------- + +-- | Parse CLI args, load all configuration files, create protocol, generate a +-- signing key, load initial funds, and validate config. +-- +-- Returns a 'Validated.Config' (validated but not yet resolved into a +-- 'Runtime.Runtime'). The caller is responsible for calling 'Runtime.resolve' +-- to create STM resources. +loadConfig + :: IO ( -- | Whether this is a dry run: validate, then exit before traffic. + Bool + -- | Validated configuration (no STM resources yet). + , Validated.Config Fund.Fund + -- | Codec config for serialising blocks on the wire. + , CodecConfig Block.CardanoBlock + , Api.NetworkId + -- | Network magic for the handshake with cardano-node. + , Api.NetworkMagic + -- | Logging / metrics tracers. + , Tracing.Tracers + ) +loadConfig = do + args <- getArgs + (isDryRun, configFile) <- case args of + [cfg] -> pure (False, cfg) + ["--dry-run", cfg] -> pure (True, cfg) + _ -> die "Usage: tx-centrifuge [--dry-run] " + + hPutStrLn stderr "=== Tx Centrifuge ===" + hPutStrLn stderr "" + + -- Decode the full JSON object once; extract node-specific paths here (like + -- setupTracers reads trace config from the same file independently) and pass + -- the rest to the Raw → Validated → Runtime pipeline. + hPutStrLn stderr $ "Loading config from: " ++ configFile + rawValue <- Aeson.eitherDecodeFileStrict' configFile + >>= either (\e -> die $ "JSON: " ++ e) pure + let parseField field = + case Aeson.Types.parseEither (Aeson.withObject "Config" (.: field)) rawValue of + Left err -> die $ "Config: " ++ err + Right v -> pure v + nodeConfigPath <- parseField "nodeConfig" + raw <- case Aeson.fromJSON rawValue of + Aeson.Error err -> die $ "JSON: " ++ err + Aeson.Success cfg -> pure cfg + + -- Load node configuration and create the consensus protocol first: the + -- network id it yields is needed to load funds (both to derive query + -- addresses and to open the LocalStateQuery connection). + hPutStrLn stderr $ "Loading node config from: " ++ nodeConfigPath + nodeConfig <- mkNodeConfig nodeConfigPath >>= either die pure + protocol <- mkConsensusProtocol nodeConfig >>= either die pure + let codecConfig = protocolToCodecConfig protocol + networkId = protocolToNetworkId protocol + networkMagic = protocolToNetworkMagic protocol + + -- Load initial funds. Look the initial_inputs source up in the raw config + -- (validate also checks the reference, but funds are loaded first, so a + -- missing name dies here), interpret it into the node-level FundSource ADT, + -- then obtain actual UTxO funds before validation: either from a genesis + -- signing-keys file, or by querying the node on chain. Each variant announces + -- itself and returns its loader's result. Handling that result (fail on error + -- or empty, report the count, build the non-empty list) is shared below. + funds <- do + let sourceName = Raw.initialInputsSource (Raw.initialInputs raw) + maybeParams = Raw.initialInputsParams (Raw.initialInputs raw) + rawSource <- + case Map.lookup sourceName =<< Raw.maybeInputSources raw of + Nothing -> die $ + "initial_inputs: undefined input source " ++ show sourceName + Just src -> pure src + fundSource <- case interpretInputSource rawSource of + Left err -> die $ "input_sources." ++ sourceName ++ ": " ++ err + Right src -> pure src + result <- case fundSource of + GenesisKeysSource path -> do + -- The source is self-contained, reject use-site params instead of + -- silently ignoring them. + case maybeParams of + Just _ -> die $ + "initial_inputs: a \"genesis_utxo_keys\" source takes no" + ++ " \"params\"" + Nothing -> pure () + hPutStrLn stderr $ "Loading funds from: " ++ path + Fund.loadFunds networkId path + UTxOQuerySource socketPath -> do + keyPaths <- case maybeParams of + Nothing -> die $ + "initial_inputs: a \"utxo_query\" source needs \"params\" with" + ++ " the \"signing_keys\" to query under" + Just params -> + case Aeson.Types.parseEither parseInitialKeys params of + Left err -> die $ "initial_inputs params: " ++ err + Right paths -> pure paths + hPutStrLn stderr $ "Querying UTxOs via N2C socket: " ++ socketPath + Fund.discoverFunds networkId socketPath keyPaths + case result of + Left err -> die $ "initial_inputs: " ++ err + Right [] -> die "initial_inputs: no funds loaded" + Right (f:fs) -> do + let allFunds = f NE.:| fs + hPutStrLn stderr $ " Loaded " ++ show (NE.length allFunds) ++ " funds" + pure allFunds + + -- Validate config. + -- Pipeline: Raw → Validated (with pre-loaded funds). + validated <- either die pure $ Validated.validate raw funds + + -- Tracers. + tracers <- Tracing.setupTracers configFile + + pure ( isDryRun, validated, codecConfig, networkId, networkMagic, tracers ) + +-------------------------------------------------------------------------------- +-- Protocol helpers (inlined from NodeConfig.hs and OuroborosImports.hs) +-------------------------------------------------------------------------------- + +mkNodeConfig :: FilePath -> IO (Either String NodeConfiguration) +mkNodeConfig configFp_ = do + configYamlPc <- parseNodeConfigurationFP . Just $ configFp + pure $ first show $ makeNodeConfiguration (configYamlPc <> filesPc) + where + configFp = ConfigYamlFilePath configFp_ + filesPc :: PartialNodeConfiguration + filesPc = defaultPartialNodeConfiguration + { pncProtocolFiles = Last . Just $ + ProtocolFilepaths + { byronCertFile = Just "" + , byronKeyFile = Just "" + , shelleyKESSource = Just (KESKeyFilePath "") + , shelleyVRFFile = Just "" + , shelleyCertFile = Just "" + , shelleyBulkCredsFile = Just "" + } + , pncShutdownConfig = Last $ Just $ ShutdownConfig Nothing Nothing + , pncConfigFile = Last $ Just configFp + } + +mkConsensusProtocol + :: NodeConfiguration -> IO (Either String SomeConsensusProtocol) +mkConsensusProtocol nodeConfig = + case ncProtocolConfig nodeConfig of + NodeProtocolConfigurationCardano + byronCfg shelleyCfg alonzoCfg conwayCfg + dijkstraCfg hardforkCfg checkpointsCfg -> + first show <$> + runExceptT (mkSomeConsensusProtocolCardano + byronCfg shelleyCfg alonzoCfg conwayCfg + dijkstraCfg hardforkCfg checkpointsCfg Nothing) + +protocolToCodecConfig :: SomeConsensusProtocol -> CodecConfig Block.CardanoBlock +protocolToCodecConfig (SomeConsensusProtocol Api.CardanoBlockType info) = + configCodec $ pInfoConfig $ fst $ Api.protocolInfo @IO info +protocolToCodecConfig _ = + error "protocolToCodecConfig: non-Cardano protocol" + +-- | Derive NetworkId from the consensus config. Mainnet uses a +-- well-known magic number; everything else is a testnet. +protocolToNetworkId :: SomeConsensusProtocol -> Api.NetworkId +protocolToNetworkId proto = case protocolToNetworkMagic proto of + Api.NetworkMagic 764824073 -> Api.Mainnet + nm -> Api.Testnet nm + +protocolToNetworkMagic :: SomeConsensusProtocol -> Api.NetworkMagic +protocolToNetworkMagic + (SomeConsensusProtocol Api.CardanoBlockType info) = + getNetworkMagic $ configBlock $ pInfoConfig $ + fst $ Api.protocolInfo @IO info +protocolToNetworkMagic _ = + error "protocolToNetworkMagic: non-Cardano protocol" diff --git a/bench/tx-centrifuge/bench/Bench.hs b/bench/tx-centrifuge/bench/Bench.hs new file mode 100644 index 00000000000..756aab580b1 --- /dev/null +++ b/bench/tx-centrifuge/bench/Bench.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE NumericUnderscores #-} + +-------------------------------------------------------------------------------- + +module Main where + +-------------------------------------------------------------------------------- + +--------------- +-- criterion -- +--------------- +import Criterion.Main qualified as Criterion +------------- +-- deepseq -- +------------- +import Control.DeepSeq (NFData (..), deepseq) +--------------------- +-- tx-centrifuge -- +--------------------- +import Paths_tx_centrifuge qualified as Paths +import Test.PullFiction.Harness qualified as Harness + +-------------------------------------------------------------------------------- + +-- | Local wrapper so Criterion can force benchmark results without requiring an +-- NFData instance in the test-harness library. +newtype BenchResult = BenchResult Harness.TestResult + +instance NFData BenchResult where + rnf (BenchResult result) = + Harness.elapsedSeconds result `seq` + Harness.targetCounts result `deepseq` () + +-------------------------------------------------------------------------------- + +main :: IO () +main = do + sharedPath <- Paths.getDataFileName "data/config-shared-100k.json" + perTargetPath <- Paths.getDataFileName "data/config-per-target-200.json" + Criterion.defaultMain + [ Criterion.bgroup "generator-throughput" + [ Criterion.bench + "shared-limiter-100k-tps-50-targets" + $ Criterion.nfIO + $ BenchResult <$> Harness.runTpsTest sharedPath 5.0 + , Criterion.bench + "per-target-limiter-200-tps-50-targets" + $ Criterion.nfIO + $ BenchResult <$> Harness.runTpsTest perTargetPath 5.0 + ] + ] diff --git a/bench/tx-centrifuge/data/config-multi-group.json b/bench/tx-centrifuge/data/config-multi-group.json new file mode 100644 index 00000000000..c370918afe0 --- /dev/null +++ b/bench/tx-centrifuge/data/config-multi-group.json @@ -0,0 +1,821 @@ +{ + "initial_inputs": { "source": "test-funds" }, + "input_sources": { + "test-funds": { + "type": "genesis_utxo_keys", + "params": { + "signing_keys_file": "/dev/null" + } + } + }, + "builder": { + "type": "value", + "params": { + "fee": 200000 + }, + "recycle": { "type": "on_pull" } + }, + + "workloads": { + "group-01": { + "rate_limit": { + "type": "token_bucket", + "scope": "per_target", + "params": { + "tps": 1 + } + }, + "max_batch_size": 500, + "targets": { + "group-01": { + "addr": "127.0.0.1", + "port": 3001 + } + } + }, + "group-02": { + "rate_limit": { + "type": "token_bucket", + "scope": "per_target", + "params": { + "tps": 1 + } + }, + "max_batch_size": 500, + "targets": { + "group-02": { + "addr": "127.0.0.1", + "port": 3001 + } + } + }, + "group-03": { + "rate_limit": { + "type": "token_bucket", + "scope": "per_target", + "params": { + "tps": 1 + } + }, + "max_batch_size": 500, + "targets": { + "group-03": { + "addr": "127.0.0.1", + "port": 3001 + } + } + }, + "group-04": { + "rate_limit": { + "type": "token_bucket", + "scope": "per_target", + "params": { + "tps": 1 + } + }, + "max_batch_size": 500, + "targets": { + "group-04": { + "addr": "127.0.0.1", + "port": 3001 + } + } + }, + "group-05": { + "rate_limit": { + "type": "token_bucket", + "scope": "per_target", + "params": { + "tps": 1 + } + }, + "max_batch_size": 500, + "targets": { + "group-05": { + "addr": "127.0.0.1", + "port": 3001 + } + } + }, + "group-06": { + "rate_limit": { + "type": "token_bucket", + "scope": "per_target", + "params": { + "tps": 1 + } + }, + "max_batch_size": 500, + "targets": { + "group-06": { + "addr": "127.0.0.1", + "port": 3001 + } + } + }, + "group-07": { + "rate_limit": { + "type": "token_bucket", + "scope": "per_target", + "params": { + "tps": 1 + } + }, + "max_batch_size": 500, + "targets": { + "group-07": { + "addr": "127.0.0.1", + "port": 3001 + } + } + }, + "group-08": { + "rate_limit": { + "type": "token_bucket", + "scope": "per_target", + "params": { + "tps": 1 + } + }, + "max_batch_size": 500, + "targets": { + "group-08": { + "addr": "127.0.0.1", + "port": 3001 + } + } + }, + "group-09": { + "rate_limit": { + "type": "token_bucket", + "scope": "per_target", + "params": { + "tps": 1 + } + }, + "max_batch_size": 500, + "targets": { + "group-09": { + "addr": "127.0.0.1", + "port": 3001 + } + } + }, + "group-10": { + "rate_limit": { + "type": "token_bucket", + "scope": "per_target", + "params": { + "tps": 1 + } + }, + "max_batch_size": 500, + "targets": { + "group-10": { + "addr": "127.0.0.1", + "port": 3001 + } + } + }, + "group-11": { + "rate_limit": { + "type": "token_bucket", + "scope": "per_target", + "params": { + "tps": 1 + } + }, + "max_batch_size": 500, + "targets": { + "group-11": { + "addr": "127.0.0.1", + "port": 3001 + } + } + }, + "group-12": { + "rate_limit": { + "type": "token_bucket", + "scope": "per_target", + "params": { + "tps": 1 + } + }, + "max_batch_size": 500, + "targets": { + "group-12": { + "addr": "127.0.0.1", + "port": 3001 + } + } + }, + "group-13": { + "rate_limit": { + "type": "token_bucket", + "scope": "per_target", + "params": { + "tps": 1 + } + }, + "max_batch_size": 500, + "targets": { + "group-13": { + "addr": "127.0.0.1", + "port": 3001 + } + } + }, + "group-14": { + "rate_limit": { + "type": "token_bucket", + "scope": "per_target", + "params": { + "tps": 1 + } + }, + "max_batch_size": 500, + "targets": { + "group-14": { + "addr": "127.0.0.1", + "port": 3001 + } + } + }, + "group-15": { + "rate_limit": { + "type": "token_bucket", + "scope": "per_target", + "params": { + "tps": 1 + } + }, + "max_batch_size": 500, + "targets": { + "group-15": { + "addr": "127.0.0.1", + "port": 3001 + } + } + }, + "group-16": { + "rate_limit": { + "type": "token_bucket", + "scope": "per_target", + "params": { + "tps": 1 + } + }, + "max_batch_size": 500, + "targets": { + "group-16": { + "addr": "127.0.0.1", + "port": 3001 + } + } + }, + "group-17": { + "rate_limit": { + "type": "token_bucket", + "scope": "per_target", + "params": { + "tps": 1 + } + }, + "max_batch_size": 500, + "targets": { + "group-17": { + "addr": "127.0.0.1", + "port": 3001 + } + } + }, + "group-18": { + "rate_limit": { + "type": "token_bucket", + "scope": "per_target", + "params": { + "tps": 1 + } + }, + "max_batch_size": 500, + "targets": { + "group-18": { + "addr": "127.0.0.1", + "port": 3001 + } + } + }, + "group-19": { + "rate_limit": { + "type": "token_bucket", + "scope": "per_target", + "params": { + "tps": 1 + } + }, + "max_batch_size": 500, + "targets": { + "group-19": { + "addr": "127.0.0.1", + "port": 3001 + } + } + }, + "group-20": { + "rate_limit": { + "type": "token_bucket", + "scope": "per_target", + "params": { + "tps": 1 + } + }, + "max_batch_size": 500, + "targets": { + "group-20": { + "addr": "127.0.0.1", + "port": 3001 + } + } + }, + "group-21": { + "rate_limit": { + "type": "token_bucket", + "scope": "per_target", + "params": { + "tps": 1 + } + }, + "max_batch_size": 500, + "targets": { + "group-21": { + "addr": "127.0.0.1", + "port": 3001 + } + } + }, + "group-22": { + "rate_limit": { + "type": "token_bucket", + "scope": "per_target", + "params": { + "tps": 1 + } + }, + "max_batch_size": 500, + "targets": { + "group-22": { + "addr": "127.0.0.1", + "port": 3001 + } + } + }, + "group-23": { + "rate_limit": { + "type": "token_bucket", + "scope": "per_target", + "params": { + "tps": 1 + } + }, + "max_batch_size": 500, + "targets": { + "group-23": { + "addr": "127.0.0.1", + "port": 3001 + } + } + }, + "group-24": { + "rate_limit": { + "type": "token_bucket", + "scope": "per_target", + "params": { + "tps": 1 + } + }, + "max_batch_size": 500, + "targets": { + "group-24": { + "addr": "127.0.0.1", + "port": 3001 + } + } + }, + "group-25": { + "rate_limit": { + "type": "token_bucket", + "scope": "per_target", + "params": { + "tps": 1 + } + }, + "max_batch_size": 500, + "targets": { + "group-25": { + "addr": "127.0.0.1", + "port": 3001 + } + } + }, + "group-26": { + "rate_limit": { + "type": "token_bucket", + "scope": "per_target", + "params": { + "tps": 1 + } + }, + "max_batch_size": 500, + "targets": { + "group-26": { + "addr": "127.0.0.1", + "port": 3001 + } + } + }, + "group-27": { + "rate_limit": { + "type": "token_bucket", + "scope": "per_target", + "params": { + "tps": 1 + } + }, + "max_batch_size": 500, + "targets": { + "group-27": { + "addr": "127.0.0.1", + "port": 3001 + } + } + }, + "group-28": { + "rate_limit": { + "type": "token_bucket", + "scope": "per_target", + "params": { + "tps": 1 + } + }, + "max_batch_size": 500, + "targets": { + "group-28": { + "addr": "127.0.0.1", + "port": 3001 + } + } + }, + "group-29": { + "rate_limit": { + "type": "token_bucket", + "scope": "per_target", + "params": { + "tps": 1 + } + }, + "max_batch_size": 500, + "targets": { + "group-29": { + "addr": "127.0.0.1", + "port": 3001 + } + } + }, + "group-30": { + "rate_limit": { + "type": "token_bucket", + "scope": "per_target", + "params": { + "tps": 1 + } + }, + "max_batch_size": 500, + "targets": { + "group-30": { + "addr": "127.0.0.1", + "port": 3001 + } + } + }, + "group-31": { + "rate_limit": { + "type": "token_bucket", + "scope": "per_target", + "params": { + "tps": 1 + } + }, + "max_batch_size": 500, + "targets": { + "group-31": { + "addr": "127.0.0.1", + "port": 3001 + } + } + }, + "group-32": { + "rate_limit": { + "type": "token_bucket", + "scope": "per_target", + "params": { + "tps": 1 + } + }, + "max_batch_size": 500, + "targets": { + "group-32": { + "addr": "127.0.0.1", + "port": 3001 + } + } + }, + "group-33": { + "rate_limit": { + "type": "token_bucket", + "scope": "per_target", + "params": { + "tps": 1 + } + }, + "max_batch_size": 500, + "targets": { + "group-33": { + "addr": "127.0.0.1", + "port": 3001 + } + } + }, + "group-34": { + "rate_limit": { + "type": "token_bucket", + "scope": "per_target", + "params": { + "tps": 1 + } + }, + "max_batch_size": 500, + "targets": { + "group-34": { + "addr": "127.0.0.1", + "port": 3001 + } + } + }, + "group-35": { + "rate_limit": { + "type": "token_bucket", + "scope": "per_target", + "params": { + "tps": 1 + } + }, + "max_batch_size": 500, + "targets": { + "group-35": { + "addr": "127.0.0.1", + "port": 3001 + } + } + }, + "group-36": { + "rate_limit": { + "type": "token_bucket", + "scope": "per_target", + "params": { + "tps": 1 + } + }, + "max_batch_size": 500, + "targets": { + "group-36": { + "addr": "127.0.0.1", + "port": 3001 + } + } + }, + "group-37": { + "rate_limit": { + "type": "token_bucket", + "scope": "per_target", + "params": { + "tps": 1 + } + }, + "max_batch_size": 500, + "targets": { + "group-37": { + "addr": "127.0.0.1", + "port": 3001 + } + } + }, + "group-38": { + "rate_limit": { + "type": "token_bucket", + "scope": "per_target", + "params": { + "tps": 1 + } + }, + "max_batch_size": 500, + "targets": { + "group-38": { + "addr": "127.0.0.1", + "port": 3001 + } + } + }, + "group-39": { + "rate_limit": { + "type": "token_bucket", + "scope": "per_target", + "params": { + "tps": 1 + } + }, + "max_batch_size": 500, + "targets": { + "group-39": { + "addr": "127.0.0.1", + "port": 3001 + } + } + }, + "group-40": { + "rate_limit": { + "type": "token_bucket", + "scope": "per_target", + "params": { + "tps": 1 + } + }, + "max_batch_size": 500, + "targets": { + "group-40": { + "addr": "127.0.0.1", + "port": 3001 + } + } + }, + "group-41": { + "rate_limit": { + "type": "token_bucket", + "scope": "per_target", + "params": { + "tps": 1 + } + }, + "max_batch_size": 500, + "targets": { + "group-41": { + "addr": "127.0.0.1", + "port": 3001 + } + } + }, + "group-42": { + "rate_limit": { + "type": "token_bucket", + "scope": "per_target", + "params": { + "tps": 1 + } + }, + "max_batch_size": 500, + "targets": { + "group-42": { + "addr": "127.0.0.1", + "port": 3001 + } + } + }, + "group-43": { + "rate_limit": { + "type": "token_bucket", + "scope": "per_target", + "params": { + "tps": 1 + } + }, + "max_batch_size": 500, + "targets": { + "group-43": { + "addr": "127.0.0.1", + "port": 3001 + } + } + }, + "group-44": { + "rate_limit": { + "type": "token_bucket", + "scope": "per_target", + "params": { + "tps": 1 + } + }, + "max_batch_size": 500, + "targets": { + "group-44": { + "addr": "127.0.0.1", + "port": 3001 + } + } + }, + "group-45": { + "rate_limit": { + "type": "token_bucket", + "scope": "per_target", + "params": { + "tps": 1 + } + }, + "max_batch_size": 500, + "targets": { + "group-45": { + "addr": "127.0.0.1", + "port": 3001 + } + } + }, + "group-46": { + "rate_limit": { + "type": "token_bucket", + "scope": "per_target", + "params": { + "tps": 1 + } + }, + "max_batch_size": 500, + "targets": { + "group-46": { + "addr": "127.0.0.1", + "port": 3001 + } + } + }, + "group-47": { + "rate_limit": { + "type": "token_bucket", + "scope": "per_target", + "params": { + "tps": 1 + } + }, + "max_batch_size": 500, + "targets": { + "group-47": { + "addr": "127.0.0.1", + "port": 3001 + } + } + }, + "group-48": { + "rate_limit": { + "type": "token_bucket", + "scope": "per_target", + "params": { + "tps": 1 + } + }, + "max_batch_size": 500, + "targets": { + "group-48": { + "addr": "127.0.0.1", + "port": 3001 + } + } + }, + "group-49": { + "rate_limit": { + "type": "token_bucket", + "scope": "per_target", + "params": { + "tps": 1 + } + }, + "max_batch_size": 500, + "targets": { + "group-49": { + "addr": "127.0.0.1", + "port": 3001 + } + } + }, + "group-50": { + "rate_limit": { + "type": "token_bucket", + "scope": "per_target", + "params": { + "tps": 1 + } + }, + "max_batch_size": 500, + "targets": { + "group-50": { + "addr": "127.0.0.1", + "port": 3001 + } + } + } + } +} diff --git a/bench/tx-centrifuge/data/config-per-target-0_2.json b/bench/tx-centrifuge/data/config-per-target-0_2.json new file mode 100644 index 00000000000..0357cb023a4 --- /dev/null +++ b/bench/tx-centrifuge/data/config-per-target-0_2.json @@ -0,0 +1,233 @@ +{ + "initial_inputs": { "source": "test-funds" }, + "input_sources": { + "test-funds": { + "type": "genesis_utxo_keys", + "params": { + "signing_keys_file": "/dev/null" + } + } + }, + "builder": { + "type": "value", + "params": { + "fee": 200000 + }, + "recycle": { "type": "on_pull" } + }, + + "workloads": { + "default": { + "rate_limit": { + "type": "token_bucket", + "scope": "per_target", + "params": { + "tps": 0.2 + } + }, + "max_batch_size": 500, + "targets": { + "node-01": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-02": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-03": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-04": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-05": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-06": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-07": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-08": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-09": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-10": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-11": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-12": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-13": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-14": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-15": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-16": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-17": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-18": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-19": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-20": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-21": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-22": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-23": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-24": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-25": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-26": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-27": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-28": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-29": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-30": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-31": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-32": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-33": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-34": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-35": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-36": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-37": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-38": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-39": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-40": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-41": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-42": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-43": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-44": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-45": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-46": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-47": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-48": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-49": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-50": { + "addr": "127.0.0.1", + "port": 3001 + } + } + } + } +} diff --git a/bench/tx-centrifuge/data/config-per-target-200.json b/bench/tx-centrifuge/data/config-per-target-200.json new file mode 100644 index 00000000000..5328efcc5c2 --- /dev/null +++ b/bench/tx-centrifuge/data/config-per-target-200.json @@ -0,0 +1,233 @@ +{ + "initial_inputs": { "source": "test-funds" }, + "input_sources": { + "test-funds": { + "type": "genesis_utxo_keys", + "params": { + "signing_keys_file": "/dev/null" + } + } + }, + "builder": { + "type": "value", + "params": { + "fee": 200000 + }, + "recycle": { "type": "on_pull" } + }, + + "workloads": { + "default": { + "rate_limit": { + "type": "token_bucket", + "scope": "per_target", + "params": { + "tps": 4000 + } + }, + "max_batch_size": 500, + "targets": { + "node-01": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-02": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-03": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-04": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-05": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-06": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-07": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-08": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-09": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-10": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-11": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-12": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-13": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-14": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-15": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-16": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-17": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-18": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-19": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-20": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-21": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-22": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-23": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-24": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-25": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-26": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-27": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-28": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-29": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-30": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-31": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-32": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-33": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-34": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-35": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-36": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-37": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-38": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-39": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-40": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-41": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-42": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-43": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-44": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-45": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-46": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-47": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-48": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-49": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-50": { + "addr": "127.0.0.1", + "port": 3001 + } + } + } + } +} diff --git a/bench/tx-centrifuge/data/config-per-target-2k.json b/bench/tx-centrifuge/data/config-per-target-2k.json new file mode 100644 index 00000000000..8c67e687c1f --- /dev/null +++ b/bench/tx-centrifuge/data/config-per-target-2k.json @@ -0,0 +1,233 @@ +{ + "initial_inputs": { "source": "test-funds" }, + "input_sources": { + "test-funds": { + "type": "genesis_utxo_keys", + "params": { + "signing_keys_file": "/dev/null" + } + } + }, + "builder": { + "type": "value", + "params": { + "fee": 200000 + }, + "recycle": { "type": "on_pull" } + }, + + "workloads": { + "default": { + "rate_limit": { + "type": "token_bucket", + "scope": "per_target", + "params": { + "tps": 2000 + } + }, + "max_batch_size": 500, + "targets": { + "node-01": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-02": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-03": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-04": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-05": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-06": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-07": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-08": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-09": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-10": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-11": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-12": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-13": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-14": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-15": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-16": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-17": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-18": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-19": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-20": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-21": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-22": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-23": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-24": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-25": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-26": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-27": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-28": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-29": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-30": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-31": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-32": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-33": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-34": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-35": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-36": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-37": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-38": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-39": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-40": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-41": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-42": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-43": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-44": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-45": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-46": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-47": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-48": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-49": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-50": { + "addr": "127.0.0.1", + "port": 3001 + } + } + } + } +} diff --git a/bench/tx-centrifuge/data/config-shared-10.json b/bench/tx-centrifuge/data/config-shared-10.json new file mode 100644 index 00000000000..8d60d88fe13 --- /dev/null +++ b/bench/tx-centrifuge/data/config-shared-10.json @@ -0,0 +1,233 @@ +{ + "initial_inputs": { "source": "test-funds" }, + "input_sources": { + "test-funds": { + "type": "genesis_utxo_keys", + "params": { + "signing_keys_file": "/dev/null" + } + } + }, + "builder": { + "type": "value", + "params": { + "fee": 200000 + }, + "recycle": { "type": "on_pull" } + }, + + "workloads": { + "default": { + "rate_limit": { + "type": "token_bucket", + "scope": "shared", + "params": { + "tps": 10 + } + }, + "max_batch_size": 500, + "targets": { + "node-01": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-02": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-03": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-04": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-05": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-06": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-07": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-08": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-09": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-10": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-11": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-12": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-13": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-14": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-15": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-16": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-17": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-18": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-19": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-20": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-21": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-22": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-23": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-24": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-25": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-26": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-27": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-28": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-29": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-30": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-31": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-32": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-33": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-34": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-35": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-36": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-37": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-38": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-39": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-40": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-41": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-42": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-43": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-44": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-45": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-46": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-47": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-48": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-49": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-50": { + "addr": "127.0.0.1", + "port": 3001 + } + } + } + } +} diff --git a/bench/tx-centrifuge/data/config-shared-100k.json b/bench/tx-centrifuge/data/config-shared-100k.json new file mode 100644 index 00000000000..ded33e95b45 --- /dev/null +++ b/bench/tx-centrifuge/data/config-shared-100k.json @@ -0,0 +1,233 @@ +{ + "initial_inputs": { "source": "test-funds" }, + "input_sources": { + "test-funds": { + "type": "genesis_utxo_keys", + "params": { + "signing_keys_file": "/dev/null" + } + } + }, + "builder": { + "type": "value", + "params": { + "fee": 200000 + }, + "recycle": { "type": "on_pull" } + }, + + "workloads": { + "default": { + "rate_limit": { + "type": "token_bucket", + "scope": "shared", + "params": { + "tps": 100000 + } + }, + "max_batch_size": 500, + "targets": { + "node-01": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-02": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-03": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-04": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-05": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-06": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-07": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-08": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-09": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-10": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-11": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-12": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-13": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-14": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-15": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-16": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-17": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-18": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-19": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-20": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-21": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-22": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-23": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-24": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-25": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-26": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-27": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-28": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-29": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-30": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-31": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-32": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-33": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-34": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-35": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-36": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-37": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-38": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-39": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-40": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-41": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-42": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-43": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-44": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-45": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-46": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-47": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-48": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-49": { + "addr": "127.0.0.1", + "port": 3001 + }, + "node-50": { + "addr": "127.0.0.1", + "port": 3001 + } + } + } + } +} diff --git a/bench/tx-centrifuge/data/protocol-parameters.ci-test.json b/bench/tx-centrifuge/data/protocol-parameters.ci-test.json new file mode 100644 index 00000000000..832d72f2f1e --- /dev/null +++ b/bench/tx-centrifuge/data/protocol-parameters.ci-test.json @@ -0,0 +1,461 @@ +{ + "collateralPercentage": 150, + "costModels": { + "PlutusV1": [ + 197209, + 0, + 1, + 1, + 396231, + 621, + 0, + 1, + 150000, + 1000, + 0, + 1, + 150000, + 32, + 2477736, + 29175, + 4, + 29773, + 100, + 29773, + 100, + 29773, + 100, + 29773, + 100, + 29773, + 100, + 29773, + 100, + 100, + 100, + 29773, + 100, + 150000, + 32, + 150000, + 32, + 150000, + 32, + 150000, + 1000, + 0, + 1, + 150000, + 32, + 150000, + 1000, + 0, + 8, + 148000, + 425507, + 118, + 0, + 1, + 1, + 150000, + 1000, + 0, + 8, + 150000, + 112536, + 247, + 1, + 150000, + 10000, + 1, + 136542, + 1326, + 1, + 1000, + 150000, + 1000, + 1, + 150000, + 32, + 150000, + 32, + 150000, + 32, + 1, + 1, + 150000, + 1, + 150000, + 4, + 103599, + 248, + 1, + 103599, + 248, + 1, + 145276, + 1366, + 1, + 179690, + 497, + 1, + 150000, + 32, + 150000, + 32, + 150000, + 32, + 150000, + 32, + 150000, + 32, + 150000, + 32, + 148000, + 425507, + 118, + 0, + 1, + 1, + 61516, + 11218, + 0, + 1, + 150000, + 32, + 148000, + 425507, + 118, + 0, + 1, + 1, + 148000, + 425507, + 118, + 0, + 1, + 1, + 2477736, + 29175, + 4, + 0, + 82363, + 4, + 150000, + 5000, + 0, + 1, + 150000, + 32, + 197209, + 0, + 1, + 1, + 150000, + 32, + 150000, + 32, + 150000, + 32, + 150000, + 32, + 150000, + 32, + 150000, + 32, + 150000, + 32, + 3345831, + 1, + 1 + ], + "PlutusV3": [ + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0 + ] + }, + "decentralization": null, + "executionUnitPrices": { + "priceMemory": 5.77e-2, + "priceSteps": 7.21e-5 + }, + "extraPraosEntropy": null, + "maxBlockBodySize": 65536, + "maxBlockExecutionUnits": { + "memory": 50000000, + "steps": 40000000000 + }, + "maxBlockHeaderSize": 1100, + "maxCollateralInputs": 3, + "maxTxExecutionUnits": { + "memory": 10000000, + "steps": 10000000000 + }, + "maxTxSize": 16384, + "maxValueSize": 5000, + "minPoolCost": 340000000, + "minUTxOValue": null, + "monetaryExpansion": 3.0e-3, + "poolPledgeInfluence": 0.3, + "poolRetireMaxEpoch": 18, + "protocolVersion": { + "major": 6, + "minor": 0 + }, + "stakeAddressDeposit": 2000000, + "stakePoolDeposit": 500000000, + "stakePoolTargetNum": 500, + "treasuryCut": 0.2, + "txFeeFixed": 155381, + "txFeePerByte": 44, + "utxoCostPerByte": 4310 +} \ No newline at end of file diff --git a/bench/tx-centrifuge/lib/pull-fiction/Cardano/Benchmarking/PullFiction/Clock.hs b/bench/tx-centrifuge/lib/pull-fiction/Cardano/Benchmarking/PullFiction/Clock.hs new file mode 100644 index 00000000000..67912f5aebb --- /dev/null +++ b/bench/tx-centrifuge/lib/pull-fiction/Cardano/Benchmarking/PullFiction/Clock.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ImportQualifiedPost #-} + +-------------------------------------------------------------------------------- + +-- | Single source of truth for monotonic time across the pull-fiction library. +-- +-- Every module in the package must obtain timestamps through this module rather +-- than importing @System.Clock@ directly. This guarantees that all call sites +-- use the same clock ('Clock.MonotonicRaw') and prevents hard-to-diagnose bugs +-- caused by accidentally mixing different clocks (e.g. 'Clock.Monotonic' vs +-- 'Clock.MonotonicRaw'), which can produce negative deltas or phantom drift on +-- systems where NTP adjusts the non-raw monotonic source. +-- +-- 'TimeSpec' is a @newtype@ over 'Clock.TimeSpec' so that code importing +-- @System.Clock@ directly cannot accidentally pass its timestamps to functions +-- expecting this module's 'TimeSpec', and vice versa. + +module Cardano.Benchmarking.PullFiction.Clock + ( -- * Types. + TimeSpec + -- * Reading the clock. + , getTime + -- * Conversions. + , toNanoSecs + , fromNanoSecs + ) where + +-------------------------------------------------------------------------------- + +----------- +-- clock -- +----------- +import System.Clock qualified as Clock + +-------------------------------------------------------------------------------- + +-- | Opaque monotonic timestamp. +-- +-- A @newtype@ wrapper that ensures only timestamps obtained via 'getTime' +-- (which always reads 'Clock.MonotonicRaw') are used in the core library. +-- +-- Internally a 'Clock.TimeSpec' stores two fields: @sec@ (seconds) and +-- @nsec@ (nanoseconds within the current second, 0–999 999 999). The derived +-- 'Num' instance normalizes after every operation: carries and borrows +-- between @sec@ and @nsec@ are handled automatically, so @timeA - timeB@ +-- always produces a correctly normalized result even when the nanoseconds +-- component underflows. +newtype TimeSpec = TimeSpec Clock.TimeSpec + deriving (Eq, Ord, Show, Num) + +-- | Read the monotonic raw clock. All timing in the package goes through this +-- function so a single clock source is used everywhere. +getTime :: IO TimeSpec +getTime = TimeSpec <$> Clock.getTime Clock.MonotonicRaw + +-- | Convert a 'TimeSpec' to __total__ nanoseconds. +-- +-- Returns @sec * 1 000 000 000 + nsec@, not just the @nsec@ field. +-- For example, @TimeSpec 2 500000000@ (2.5 s) yields @2 500 000 000@. +toNanoSecs :: TimeSpec -> Integer +toNanoSecs (TimeSpec ts) = Clock.toNanoSecs ts + +-- | Convert total nanoseconds to a 'TimeSpec'. +-- +-- Splits via @divMod@ into @sec@ and @nsec@ so the result is always +-- normalized (e.g. @fromNanoSecs 2500000000@ gives @TimeSpec 2 500000000@). +fromNanoSecs :: Integer -> TimeSpec +fromNanoSecs = TimeSpec . Clock.fromNanoSecs diff --git a/bench/tx-centrifuge/lib/pull-fiction/Cardano/Benchmarking/PullFiction/Config/Raw.hs b/bench/tx-centrifuge/lib/pull-fiction/Cardano/Benchmarking/PullFiction/Config/Raw.hs new file mode 100644 index 00000000000..92dc16ee24f --- /dev/null +++ b/bench/tx-centrifuge/lib/pull-fiction/Cardano/Benchmarking/PullFiction/Config/Raw.hs @@ -0,0 +1,465 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE OverloadedStrings #-} + +-------------------------------------------------------------------------------- + +-- | Raw load-generator configuration parsed from JSON. +-- +-- A plain Aeson parser with no extra logic. Each 'FromJSON' instance is a +-- direct transformation from JSON values to Haskell base types ('String', +-- 'Natural', 'Double', 'Int', etc.); optional fields are 'Maybe' and named +-- collections are @'Map' 'String'@. No defaults are applied, no business rules +-- are checked, and no cross-field relationships are enforced. +-- All of that is the responsibility of +-- "Cardano.Benchmarking.PullFiction.Config.Validated". +-- +-- All data constructors and fields are exported so that test code can build +-- configuration values directly without going through JSON. +-- +-- __Import qualified.__ Field names clash with +-- "Cardano.Benchmarking.PullFiction.Config.Validated" and +-- "Cardano.Benchmarking.PullFiction.Config.Runtime". +module Cardano.Benchmarking.PullFiction.Config.Raw + ( + -- * Config. + Config (..) + + -- * Inputs. + , InitialInputs (..) + , InputSource (..) + + -- * Observer. + , Observer (..) + + -- * Builder. + , Builder (..) + , Recovery (..) + + -- * Recycle strategy. + , RecycleStrategy (..) + + -- * RateLimit. + , RateLimit (..) + -- ** TopLevelScope. + , TopLevelScope (..) + -- ** WorkloadScope. + , WorkloadScope (..) + + -- * OnExhaustion. + , OnExhaustion (..) + + -- * Workload. + , Workload (..) + + -- * Target. + , Target (..) + + ) where + +-------------------------------------------------------------------------------- + +---------- +-- base -- +---------- +import Control.Monad (when) +import Numeric.Natural (Natural) +----------- +-- aeson -- +----------- +import Data.Aeson qualified as Aeson +import Data.Aeson ((.:), (.:?)) +import Data.Aeson.Key qualified as Key +import Data.Aeson.KeyMap qualified as KeyMap +import Data.Aeson.Types qualified as Aeson.Types +---------------- +-- containers -- +---------------- +import Data.Map.Strict (Map) + +-------------------------------------------------------------------------------- + +-- | Fail if the JSON object contains fields not in the given list. +-- Catches typos in configuration files early. +noUnknownFields :: String -> Aeson.Object -> [String] -> Aeson.Types.Parser () +noUnknownFields name obj known = + let unknown = filter (`notElem` map Key.fromString known) (KeyMap.keys obj) + in when (not (null unknown)) $ + fail $ name ++ ": unrecognized field(s): " + ++ unwords (map (show . Key.toString) unknown) + +-------------------------------------------------------------------------------- + +-- | Top-level configuration as parsed from JSON. +-- +-- No invariants are enforced. Use 'validate' from +-- "Cardano.Benchmarking.PullFiction.Config.Validated" to apply business +-- rules and cascading defaults. +data Config = Config + { -- | Which 'InputSource' loads the initial inputs, plus optional opaque + -- use-site params. Interpretation of the params is the caller's + -- responsibility (e.g. @Main.hs@). + initialInputs :: !InitialInputs + -- | Optional @\"input_sources\"@ map (keyed by name). + -- Because Aeson decodes JSON objects into a 'Map', duplicate source names + -- are silently discarded (last value wins). + , maybeInputSources :: !(Maybe (Map String InputSource)) + -- | Optional @\"observers\"@ map (keyed by name). + -- Because Aeson decodes JSON objects into a 'Map', duplicate observer names + -- are silently discarded (last value wins). + , maybeObservers :: !(Maybe (Map String Observer)) + -- | Optional top level @\"builder\"@. + , maybeTopLevelBuilder :: !(Maybe Builder) + -- | Optional top-level @\"rate_limit\"@. + , maybeTopLevelRateLimit :: !(Maybe (Maybe TopLevelScope, RateLimit)) + -- | Optional top-level @\"max_batch_size\"@. + , maybeTopLevelMaxBatchSize :: !(Maybe Natural) + -- | Optional top-level @\"on_exhaustion\"@. + , maybeTopLevelOnExhaustion :: !(Maybe OnExhaustion) + -- | Optional top-level @\"startup_delay_seconds\"@. + , maybeStartupDelaySeconds :: !(Maybe Natural) + -- | Optional generator workloads keyed by name. + -- Because Aeson decodes JSON objects into a 'Map', duplicate workload names + -- are silently discarded (last value wins). + , maybeWorkloads :: !(Maybe (Map String Workload)) + } + deriving (Show, Eq) + +instance Aeson.FromJSON Config where + -- No noUnknownFields: the top-level JSON carries additional fields + -- parsed by the caller (tracing, nodeConfig, protocol_parameters, etc.). + parseJSON = Aeson.withObject "Config" $ \o -> + Config + <$> o .: "initial_inputs" + <*> o .:? "input_sources" + <*> o .:? "observers" + <*> o .:? "builder" + <*> Aeson.Types.explicitParseFieldMaybe parseTopLevelRateLimit o + "rate_limit" + <*> o .:? "max_batch_size" + <*> o .:? "on_exhaustion" + <*> o .:? "startup_delay_seconds" + <*> o .:? "workloads" + +-------------------------------------------------------------------------------- + +-- | The @initial_inputs@ reference: which 'InputSource' loads the initial +-- inputs, plus optional use-site params. The params are opaque like +-- 'builderParams', their shape depends on the source's type and interpretation +-- is the caller's responsibility. +data InitialInputs = InitialInputs + { -- | Name of the 'InputSource' to load from. + initialInputsSource :: !String + -- | Optional opaque params for the load (e.g. which signing keys). + , initialInputsParams :: !(Maybe Aeson.Value) + } + deriving (Show, Eq) + +instance Aeson.FromJSON InitialInputs where + parseJSON = Aeson.withObject "InitialInputs" $ \o -> do + noUnknownFields "InitialInputs" o ["source", "params"] + InitialInputs + <$> o .: "source" + <*> o .:? "params" + +-- | Opaque input source configuration: a way to obtain inputs, referenced by +-- @initial_inputs@ (the startup load) and by builder recoveries (rebuilding +-- the queued inputs after a reset). +-- +-- Carries a @\"type\"@ discriminator and an opaque @\"params\"@ object. +-- Interpretation of the params is the caller's responsibility (see @Main.hs@), +-- like 'Observer' and 'Builder'. +data InputSource = InputSource + { -- | Source variant (e.g. @\"utxo_query\"@ @\"genesis_utxo_keys\"@). + -- Non-empty. + inputSourceType :: !String + -- | Opaque params object for the variant. + , inputSourceParams :: !Aeson.Value + } + deriving (Show, Eq) + +instance Aeson.FromJSON InputSource where + parseJSON = Aeson.withObject "InputSource" $ \o -> do + noUnknownFields "InputSource" o ["type", "params"] + ty <- o .: "type" :: Aeson.Types.Parser String + when (null ty) $ fail "InputSource: \"type\" must be non-empty" + InputSource ty <$> o .: "params" + +-------------------------------------------------------------------------------- + +-- | Opaque observer configuration. +-- +-- Carries a @\"type\"@ discriminator and an opaque @\"params\"@ object. +-- Interpretation of the params is the caller's responsibility (see @Main.hs@), +-- like 'initialInputs' and 'Builder'. +data Observer = Observer + { -- | Observer variant (e.g. @\"nodetonode\"@ @\"nodetoclient\"@). Non-empty. + observerType :: !String + -- | Opaque params object for the variant. + , observerParams :: !Aeson.Value + } + deriving (Show, Eq) + +instance Aeson.FromJSON Observer where + parseJSON = Aeson.withObject "Observer" $ \o -> do + noUnknownFields "Observer" o ["type", "params"] + ty <- o .: "type" :: Aeson.Types.Parser String + when (null ty) $ fail "Observer: \"type\" must be non-empty" + Observer ty <$> o .: "params" + +-------------------------------------------------------------------------------- + +-- | Opaque builder configuration. +-- +-- Carries a @\"type\"@ discriminator and an opaque @\"params\"@ object. +-- Interpretation of the params is the caller's responsibility (see @Main.hs@), +-- like 'observer' and 'initialInputs'. +data Builder = Builder + { -- | Builder variant name (e.g. @\"value\"@). Non-empty. + builderType :: !String + -- | Opaque params object for the variant. + , builderParams :: !Aeson.Value + -- | Optional recycle strategy. 'Nothing' means no recycling. + , builderRecycle :: !(Maybe RecycleStrategy) + -- | Optional rollback recovery. 'Nothing' means no recovery. + , builderRecovery :: !(Maybe Recovery) + } + deriving (Show, Eq) + +instance Aeson.FromJSON Builder where + parseJSON = Aeson.withObject "Builder" $ \o -> do + noUnknownFields "Builder" o ["type", "params", "recycle", "recovery"] + ty <- o .: "type" :: Aeson.Types.Parser String + when (null ty) $ fail "Builder: \"type\" must be non-empty" + Builder ty <$> o .: "params" + <*> o .:? "recycle" + <*> o .:? "recovery" + +-------------------------------------------------------------------------------- + +-- | A builder's rollback recovery: when one of its payloads is orphaned, +-- discard the workload's queued inputs and reseed them from the named +-- 'InputSource'. Observers are independent entities: several builders may name +-- the same observer, each choosing its own recovery. +data Recovery = Recovery + { -- | Observer whose orphan events trigger the recovery. Optional for + -- @on_confirm@ (defaults to the confirm observer), required for @on_build@ + -- and @on_pull@. + recoveryObserver :: !(Maybe String) + -- | Name of the 'InputSource' that rebuilds the queued inputs. + , recoverySource :: !String + } + deriving (Show, Eq) + +instance Aeson.FromJSON Recovery where + parseJSON = Aeson.withObject "Recovery" $ \o -> do + noUnknownFields "Recovery" o ["observer", "source"] + Recovery + <$> o .:? "observer" + <*> o .: "source" + +-------------------------------------------------------------------------------- + +-- | When to recycle transaction outputs back to the input queue. +data RecycleStrategy + -- | Recycle immediately after building, before entering the payload queue. + = RecycleOnBuild + -- | Recycle when a worker dequeues the payload from the queue. + | RecycleOnDequeue + -- | Recycle when an observer confirms the payload. Carries the observer + -- name. + | RecycleOnConfirm !String + deriving (Show, Eq) + +instance Aeson.FromJSON RecycleStrategy where + parseJSON = Aeson.withObject "RecycleStrategy" $ \o -> do + noUnknownFields "RecycleStrategy" o ["type", "params"] + ty <- o .: "type" :: Aeson.Types.Parser String + mParams <- o .:? "params" :: Aeson.Types.Parser (Maybe Aeson.Value) + case (ty, mParams) of + -- on_build and on_pull take no params, fail instead of silently + -- ignoring them. + ("on_build", Nothing) -> pure RecycleOnBuild + ("on_build", Just _) -> + fail "RecycleStrategy on_build: takes no \"params\"" + -- TODO: rename the JSON value "on_pull" to "on_dequeue", the strategy + -- recycles when the payload is DEQUEUED from the pipe, not on a + -- TxSubmission "pull". + -- Kept as "on_pull" for backward compatibility with existing configs. + ("on_pull", Nothing) -> pure RecycleOnDequeue + ("on_pull", Just _) -> + fail "RecycleStrategy on_pull: takes no \"params\"" + -- on_confirm params: the observer name. + ("on_confirm", Just v) -> RecycleOnConfirm <$> Aeson.Types.parseJSON v + ("on_confirm", Nothing) -> + fail "RecycleStrategy on_confirm: missing \"params\"" + _ -> fail $ "RecycleStrategy: unknown \"type\" " ++ show ty + ++ ", expected \"on_build\", \"on_pull\", or \"on_confirm\"" + +-------------------------------------------------------------------------------- + +-- | Scope of a top-level rate limiter. +-- +-- There is no @Distributed@ scope. A \"distributed\" mode would be equivalent +-- to 'TopPerWorkload' or 'TopPerTarget' but with the TPS divided internally by +-- the number of sub-entities. We avoid that: the config should state the +-- per-entity TPS directly so the value is explicit and auditable. +data TopLevelScope + -- | One rate limiter shared by all targets across all workloads. + = TopShared + -- | Each workload gets its own rate limiter at the full configured TPS. + | TopPerWorkload + -- | Each target gets its own rate limiter at the full configured TPS. + | TopPerTarget + deriving (Show, Eq) + +-- | Scope of a workload-level rate limiter. +-- +-- 'TopPerWorkload' is not valid here (we are already at the workload level). +data WorkloadScope + -- | One rate limiter shared by all targets in the workload. + = WorkloadShared + -- | Each target gets its own rate limiter at the full configured TPS. + | WorkloadPerTarget + deriving (Show, Eq) + +-- | Rate limit configuration. +-- +-- Scope is not part of the rate limit itself; it is carried alongside the +-- 'RateLimit' in the enclosing tuple (e.g. @(TopLevelScope, RateLimit)@). +-- +-- The JSON representation uses @\"type\"@ + @\"params\"@ at the same level; +-- the parser flattens the nested @\"params\"@ object into the constructor. +data RateLimit + = TokenBucket + { -- | Target tokens per second. + tps :: !Double + } + deriving (Show, Eq) + +-- | Parse a rate limit from JSON using a context-specific scope parser. +-- +-- Scope is optional (defaults to @\"shared\"@ at validation time) and parsed +-- first; it is not part of 'RateLimit'. +-- +-- At the top level, use 'parseTopLevelRateLimit' (accepts @\"shared\"@, +-- @\"per_workload\"@, @\"per_target\"@). +-- At the workload level, use 'parseWorkloadRateLimit' (accepts @\"shared\"@, +-- @\"per_target\"@). +parseRateLimit + :: (String -> Aeson.Types.Parser scope) + -> Aeson.Value + -> Aeson.Types.Parser (Maybe scope, RateLimit) +parseRateLimit scopeParser = Aeson.withObject "RateLimit" $ \o -> do + noUnknownFields "RateLimit" o ["type", "params", "scope"] + maybeScopeStr <- o .:? "scope" + maybeScope <- case maybeScopeStr of + Nothing -> pure Nothing + Just s -> Just <$> scopeParser s + ty <- o .: "type" :: Aeson.Types.Parser String + case ty of + "token_bucket" -> do + op <- o .: "params" + noUnknownFields "RateLimit.params" op ["tps"] + rl <- TokenBucket <$> op .: "tps" + pure (maybeScope, rl) + _ -> fail $ + "RateLimit: unknown \"type\" " ++ show ty ++ ", expected \"token_bucket\"" + +parseTopLevelRateLimit :: Aeson.Value + -> Aeson.Types.Parser (Maybe TopLevelScope, RateLimit) +parseTopLevelRateLimit = parseRateLimit parseTopLevelScope + +parseWorkloadRateLimit :: Aeson.Value + -> Aeson.Types.Parser (Maybe WorkloadScope, RateLimit) +parseWorkloadRateLimit = parseRateLimit parseWorkloadScope + +parseTopLevelScope :: String -> Aeson.Types.Parser TopLevelScope +parseTopLevelScope "shared" = pure TopShared +parseTopLevelScope "per_workload" = pure TopPerWorkload +parseTopLevelScope "per_target" = pure TopPerTarget +parseTopLevelScope s = fail $ "RateLimit: unknown scope " ++ show s + +parseWorkloadScope :: String -> Aeson.Types.Parser WorkloadScope +parseWorkloadScope "shared" = pure WorkloadShared +parseWorkloadScope "per_target" = pure WorkloadPerTarget +parseWorkloadScope s = fail $ + "RateLimit: unknown scope " ++ show s + ++ "; at workload level, only \"shared\" and \"per_target\" are valid" + +-------------------------------------------------------------------------------- + +-- | What to do when the payload queue, the output of the builder stage, is +-- exhausted. +data OnExhaustion + -- | Block / wait. + = Block + -- | Fail immediately with an error. + | Error + deriving (Show, Eq) + +instance Aeson.FromJSON OnExhaustion where + parseJSON = Aeson.withText "OnExhaustion" $ \t -> case t of + "block" -> pure Block + "error" -> pure Error + _ -> fail $ + "OnExhaustion: expected \"block\" or \"error\", got " ++ show t + +-------------------------------------------------------------------------------- + +-- | Configuration for a single workload as parsed from JSON. +-- +-- The workload name is the 'Map' key in the parent 'Config'; it is not stored +-- inside the record. +data Workload = Workload + { -- | Optional builder for this workload. + maybeBuilder :: !(Maybe Builder) + -- | Optional rate limit for this workload. + , maybeRateLimit :: !(Maybe (Maybe WorkloadScope, RateLimit)) + -- | Optional max tokens per request. + , maybeMaxBatchSize :: !(Maybe Natural) + -- | Optional on-exhaustion behaviour. + , maybeOnExhaustion :: !(Maybe OnExhaustion) + -- | Targets keyed by name. + -- Because Aeson decodes JSON objects into a 'Map', duplicate target names + -- are silently discarded (last value wins). + , targets :: !(Map String Target) + } + deriving (Show, Eq) + +instance Aeson.FromJSON Workload where + parseJSON = Aeson.withObject "Workload" $ \o -> do + noUnknownFields "Workload" o + ["builder", "rate_limit", "max_batch_size", "on_exhaustion", "targets"] + Workload + <$> o .:? "builder" + <*> Aeson.Types.explicitParseFieldMaybe parseWorkloadRateLimit o + "rate_limit" + <*> o .:? "max_batch_size" + <*> o .:? "on_exhaustion" + <*> o .: "targets" + +-------------------------------------------------------------------------------- + +-- | A target endpoint to connect to. +-- +-- The target name is the 'Map' key in the parent 'Workload'; it is not stored +-- inside the record. +data Target = Target + { -- | Optional per-target @\"max_batch_size\"@ override. + maybeTargetMaxBatchSize :: !(Maybe Natural) + -- | Optional per-target @\"on_exhaustion\"@ override. + , maybeTargetOnExhaustion :: !(Maybe OnExhaustion) + , addr :: !String + , port :: !Int + } + deriving (Show, Eq) + +instance Aeson.FromJSON Target where + parseJSON = Aeson.withObject "Target" $ \o -> do + noUnknownFields "Target" o + ["max_batch_size", "on_exhaustion", "addr", "port"] + Target + <$> o .:? "max_batch_size" + <*> o .:? "on_exhaustion" + <*> o .: "addr" + <*> o .: "port" diff --git a/bench/tx-centrifuge/lib/pull-fiction/Cardano/Benchmarking/PullFiction/Config/Runtime.hs b/bench/tx-centrifuge/lib/pull-fiction/Cardano/Benchmarking/PullFiction/Config/Runtime.hs new file mode 100644 index 00000000000..12834baee84 --- /dev/null +++ b/bench/tx-centrifuge/lib/pull-fiction/Cardano/Benchmarking/PullFiction/Config/Runtime.hs @@ -0,0 +1,847 @@ +{-# LANGUAGE ImportQualifiedPost #-} + +-------------------------------------------------------------------------------- + +-- | Resolves a 'Validated.Config' into a 'Runtime': live STM resources (queues, +-- rate limiters) grouped into name-keyed pools, with the threads running them. +-- See 'Runtime' for the pools and 'resolve' for resolution. +module Cardano.Benchmarking.PullFiction.Config.Runtime + ( -- * Runtime. + Runtime + , config, builders, pipes, recyclers, observers, forwarders, workloads, asyncs + -- * Handles. + -- ** Behaviour handles (what the resource does). + , BuilderApi (..) + , BuilderHandle (..) + , ObserverHandle (..) + -- ** Event handlers (fired here, used for tracing). + , PipeHandle (..) + , RecyclerHandle (..) + -- * Builder. + , Builder + , builderName, builderPipe, builderRecycler, builderAsync + -- * Recycler. + , Recycler + , recyclerName, recyclerInternal, recyclerAsync + -- * Observer. + , Observer + , observerName, observerHandle, observerAsync + -- * Forwarder. + , Forwarder + , forwarderName, forwarderObserver, forwarderRecycler, forwarderAsync + -- * Workload. + , Workload + , workloadName, targets + -- * OnExhaustion. + , Raw.OnExhaustion (..) + -- * Target. + , Target + , targetName + , targetFetcher + , rateLimiter + , maxBatchSize, onExhaustion + , targetAddr, targetPort + -- * Resolution. + , resolve + ) where + +-------------------------------------------------------------------------------- + +---------- +-- base -- +---------- +import Control.Concurrent (myThreadId) +import Control.Monad (forever) +import Data.Foldable (foldlM, toList) +import GHC.Conc (labelThread) +import Numeric.Natural (Natural) +----------- +-- async -- +----------- +import Control.Concurrent.Async qualified as Async +---------------- +-- containers -- +---------------- +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +--------- +-- stm -- +--------- +import Control.Concurrent.STM qualified as STM +------------------ +-- pull-fiction -- +------------------ +import Cardano.Benchmarking.PullFiction.Config.Raw qualified as Raw +import Cardano.Benchmarking.PullFiction.Config.Validated qualified as Validated +import Cardano.Benchmarking.PullFiction.Internal.Pipe qualified as Pipe +import Cardano.Benchmarking.PullFiction.Internal.RateLimiter qualified as RL +import Cardano.Benchmarking.PullFiction.Internal.Recycler qualified as Recycler + +-------------------------------------------------------------------------------- + +-- | Fully resolved top-level configuration. +-- +-- Everything is a name-keyed pool. Today the name is the workload name for +-- 'builders', 'pipes', 'recyclers' and 'workloads' (one of each per workload), +-- the config key for 'observers', and the wiring path for 'forwarders' (see +-- 'Forwarder'), but the pools are the natural home once the config allows +-- sharing or interconnection. +-- +-- Each pool entry also carries its own name as a field (repeating its 'Map' +-- key, for labels and traces) and the async(s) running it, so 'asyncs' just +-- gathers all of them. The exception is 'pipes': a pipe is named by its 'Map' +-- key like every entry, but the entry itself is pure structure, a queue pair +-- ('Pipe.Pipe') carrying neither a name field nor an async. +data Runtime key input payload = Runtime + { -- | The original validated configuration. + config :: !(Validated.Config input) + -- | Resolved builders (build loops), keyed by name. + , builders :: !(Map String Builder) + -- | Resolved pipes (queue pairs), keyed by name. Pure structure: the only + -- pool whose entries do not repeat their name as a field (it lives only + -- in the 'Map' key) and run no async, just the queue pair. + , pipes :: !(Map String (Pipe.Pipe key input payload)) + -- | Resolved recyclers, keyed by name. + , recyclers :: !(Map String (Recycler key input payload)) + -- | Resolved observers, keyed by name. + , observers :: !(Map String (Observer key)) + -- | Resolved forwarders (observer to recycler bridges), keyed by wiring + -- path (see 'Forwarder'). + , forwarders :: !(Map String Forwarder) + -- | Resolved workloads (target groups), keyed by name. + , workloads :: !(Map String (Workload key input payload)) + -- | All asyncs (builders + recyclers + forwarders + observers), linked. + -- Caller should append their own worker asyncs for cleanup. + , asyncs :: ![Async.Async ()] + } + +-------------------------------------------------------------------------------- + +-- | The privileged operations a builder loop may perform, each a closure over +-- this builder's pipe and recycler. The raw 'Pipe.Pipe' and 'Recycler' are not +-- exposed, so a builder drives its own loop with full freedom but cannot reach +-- or corrupt the machinery: it may only pull inputs, publish a payload +-- (recording the recycle bookkeeping), or abandon inputs. +-- +-- The builder loop owns conservation of inputs: every batch returned by +-- 'baTakeInputs' should be handed to exactly one of 'baAddPayload' (as its +-- consumed set) or 'baDropInputs'. The engine cannot enforce this, so a loop +-- that leaks a batch merely shrinks the set of recyclable inputs. +data BuilderApi key input payload = BuilderApi + { -- | Pull this many inputs off the input queue. Blocks until that many are + -- available. + baTakeInputs :: Natural -> IO [input] + -- | Publish a payload. Records its consumed inputs and produced outputs + -- with the recycler (so the outputs return to the input queue when the + -- recycle strategy fires), then enqueues the payload. Arguments: + -- confirmation key, payload, consumed inputs, recyclable outputs. + , baAddPayload :: key -> payload -> [input] -> [input] -> IO () + -- | Abandon inputs already pulled by 'baTakeInputs': they are neither + -- recycled nor re-enqueued. The correct terminus for an unbuildable (e.g. + -- dust) batch. + , baDropInputs :: [input] -> IO () + } + +-- | Caller-provided builder. 'resolve' spawns one async per builder and runs +-- 'bhRunBuilder' in it, handing over a 'BuilderApi' wired to that builder's +-- pipe and recycler. The builder owns its loop (batching, grouping, coin +-- selection); the engine owns the thread and the machinery behind the API. +newtype BuilderHandle key input payload = BuilderHandle + { bhRunBuilder :: BuilderApi key input payload -> IO () + } + +-- | Caller-provided pipe queue-event handlers (e.g. for tracing). 'resolve' +-- unpacks these into the workload's 'Pipe', which fires them as items are added +-- to or removed from its two queues. Queue mechanics are pipe events, not +-- builder events, so they live here and not on 'BuilderHandle'. +data PipeHandle key input = PipeHandle + { -- | Fired after inputs added to the input queue (initial load or recycle). + phOnInputsEnqueued :: !(Pipe.OnInputsEvent input) + -- | Fired after inputs are removed from the input queue (builder take). + , phOnInputsDequeued :: !(Pipe.OnInputsEvent input) + -- | Fired after a payload is added to the payload queue. + , phOnPayloadEnqueued :: !(Pipe.OnPayloadEvent key) + -- | Fired after payload removed from the payload queue (worker dequeue). + , phOnPayloadDequeued :: !(Pipe.OnPayloadEvent key) + } + +-- | Caller-provided recycler event handlers (e.g. for tracing). 'resolve' +-- unpacks them into the workload's 'Recycler', which fires them as payloads +-- enter the backlog and as inputs are added to the pipe's input queue. Kept +-- separate from 'PipeHandle' because recycling is a 'Recycler' concern, not a +-- 'Pipe' one. +data RecyclerHandle key input payload = RecyclerHandle + { -- | Fired by the recycler with the added entry (key, consumed inputs, + -- produced outputs) and the resulting backlog size each time it adds a + -- payload to the backlog. + rhOnAddToBacklog :: !(Recycler.OnAddToBacklogEvent key input) + -- | Fired by the recycler with the inputs it adds to the pipe and the + -- resulting backlog size, each recycle. + , rhOnAddToPipe :: !(Recycler.OnAddToPipeEvent input) + -- | Fired with the dropped inputs, the dropped payloads, the fresh inputs + -- and the resulting backlog size each time a reset drops the queued inputs + -- and payloads and reseeds the input queue. + , rhOnReset :: !(Recycler.OnResetEvent key input payload) + -- | Optional recovery action. The forwarder runs it on an orphan and feeds + -- its result to 'Recycler.reset' (keyed under on_confirm, see + -- 'resolveForwarders'), which drops the pipe's queued inputs and payloads + -- and reseeds the input queue with it. + , rhRecover :: !(Maybe (IO [input])) + } + +-- | Caller-provided observer handle. 'resolve' spawns 'ohRun' in a labeled, +-- linked async and uses the subscription for 'Raw.RecycleOnConfirm' recycling. +data ObserverHandle key = ObserverHandle + { -- | IO action that runs the observer (e.g. a NodeToNode connection). + ohRun :: !(IO ()) + -- | Subscribe to the observer's event stream: returns an STM action that + -- reads the next event as its recycle key. + -- 'Right' = confirmed (recycle output inputs). + -- 'Left' = orphaned (recycle original inputs). + -- + -- Each call must create an independent subscription (every subscriber sees + -- every event). Observers are independent entities: one observer can serve + -- many workloads, and what each does with the events (plain confirm + -- recycling, rollback recovery) is decided per workload, never here. + , ohSubscribe :: !(IO (STM.STM (Either key key))) + } + +-------------------------------------------------------------------------------- + +-- | A resolved build loop: it takes inputs from a pipe, builds payloads, and +-- signals a recycler. It references its 'pipes' and 'recyclers' entries /by +-- name/ (today both the workload name). Its loop thread is 'builderAsync', also +-- collected into 'asyncs'. +data Builder = Builder + { -- | This builder's name (today the workload name). + builderName :: !String + -- | Name of the 'pipes' entry it drives (takes from / adds to). + , builderPipe :: !String + -- | Name of the 'recyclers' entry it signals via 'Recycler.addToBacklog'. + , builderRecycler :: !String + -- | Linked async running the build loop. + , builderAsync :: !(Async.Async ()) + } + +-- | A resolved recycler: the 'Internal.Recycler' logic plus the async running +-- its worker. A thin wrapper so the 'recyclers' pool carries its own thread, +-- like 'Builder' and 'Observer'. The 'Recycler.Recycler' inside deliberately +-- holds no async. The observer bridge for 'RecycleOnConfirm' is a separate +-- thread ('resolveForwarders'), not held here. +data Recycler key input payload = Recycler + { -- | This recycler's name (today the workload name). + recyclerName :: !String + -- | The underlying recycler from "Internal.Recycler". + , recyclerInternal :: !(Recycler.Recycler key input payload) + -- | Optional recovery action (from 'rhRecover'): the forwarder runs it on + -- an orphan and feeds its result to 'Recycler.reset'. + , recyclerRecover :: !(Maybe (IO [input])) + -- | Linked async running its worker (the sole writer of recycled inputs + -- back onto the pipe). + , recyclerAsync :: !(Async.Async ()) + } + +-- | A resolved observer with its lifecycle managed by 'resolve': the +-- caller-provided 'ObserverHandle' plus the async running its 'ohRun'. +data Observer key = Observer + { -- | Key from the config's @\"observers\"@ object. + observerName :: !String + -- | The caller-provided handle ('ohRun' + 'ohSubscribe'). The forwarders + -- subscribe to it for the workloads whose strategy names this observer. + , observerHandle :: !(ObserverHandle key) + -- | Linked async running the observer connection ('ohRun'). + , observerAsync :: !(Async.Async ()) + } + +-- | A resolved forwarder: the bridge thread that reads one observer +-- subscription and feeds each event through its workload's strategy wiring into +-- the recycler actions. Unlike the other pools it is keyed by the config +-- reference that wired it, @workload\/site\/observer@, with @site@ being +-- @recycle@ (the on_confirm strategy's observer) or @recovery@ (the recovery's +-- explicit observer), since one workload may subscribe to several observers. +-- Key uniqueness relies on names containing no @\'/\'@, enforced at validation +-- time like the rate-limit key scheme. It references what it bridges by name, +-- like 'Builder' does. +data Forwarder = Forwarder + { -- | This forwarder's name (the @workload\/site\/observer@ wiring path, also + -- the thread label). + forwarderName :: !String + -- | Name of the 'observers' entry it subscribes to. + , forwarderObserver :: !String + -- | Name of the 'recyclers' entry it feeds. + , forwarderRecycler :: !String + -- | Linked async reading the subscription forever. + , forwarderAsync :: !(Async.Async ()) + } + +-- | Fully resolved workload. Builder resources live in 'Builder' on the +-- 'Runtime', not here. +data Workload key input payload = Workload + { -- | Unique name identifying this workload. + workloadName :: !String + -- | Resolved targets, keyed by name. + , targets :: !(Map String (Target key input payload)) + } + +-- | A fully resolved target. Targets in the same workload share a 'Pipe'. +-- Targets with the same 'Validated.rateLimitKey' share a 'RL.RateLimiter'. +data Target key input payload = Target + { -- | Unique name identifying this target. + targetName :: !String + -- | Rate-limited, recycling payload fetch for this target, pre-built by + -- 'resolveTarget' (wraps the shared pipe's fetcher through the workload's + -- dequeue wiring). + -- The worker pulls through this and never touches the pipe or the recycler. + , targetFetcher :: !(Pipe.PayloadFetcher payload) + -- | Shared when 'Validated.rateLimitKey' matches. + , rateLimiter :: !RL.RateLimiter + -- | Resolved max tokens per request for this target. + , maxBatchSize :: !Natural + -- | What to do when the payload queue is exhausted. + , onExhaustion :: !Raw.OnExhaustion + -- | IP address or hostname of the target endpoint. + , targetAddr :: !String + -- | Port number of the target endpoint. + , targetPort :: !Int + } + +-------------------------------------------------------------------------------- +-- Resolution. +-------------------------------------------------------------------------------- + +-- | Limiter cache: maps a sharing key to an already-created rate limiter. +-- +-- Threaded across workloads so that top-level Shared limiters are reused. +type LimiterCache = Map String RL.RateLimiter + +-- | Resolve a 'Validated.Config' into a 'Runtime'. Everything is built into +-- name-keyed pools in dependency order: observers, then pipes, then recyclers +-- (each references its pipe), then builders and targets (each references a +-- pipe and recycler), then forwarders (each bridges an observer to a +-- recycler). See 'Runtime' for each pool's naming. +-- +-- Initial inputs are partitioned equally across workloads (last absorbs the +-- remainder). +resolve + :: Ord key + -- | Builder factory (index, name, config). + => (Int -> String -> Raw.Builder -> IO (BuilderHandle key input payload)) + -- | Pipe-events factory (index, name): the tracing handlers the pipe fires at + -- each queue event. + -> (Int -> String -> IO (PipeHandle key input)) + -- | Recycler-events factory (index, name): the tracing handlers the recycler + -- fires as payloads enter the backlog and as it recycles inputs. + -> (Int -> String -> IO (RecyclerHandle key input payload)) + -- | Observer factory (index, name, config). + -> (Int -> String -> Raw.Observer -> IO (ObserverHandle key)) + -> Validated.Config input + -> IO (Runtime key input payload) +resolve mkBuilderFn mkPipeHandleFn mkRecyclerHandleFn mkObserverFn validatedConfig = do + let workloadsMap = Validated.workloads validatedConfig + -- Distribute initial inputs equally across workloads, keyed by workload name. + -- Both Maps share the same ascending key order, so zip + fromAscList is safe. + let inputsByWorkload = + Map.fromAscList $ zip + (Map.keys workloadsMap) + (partitionInputs + (Map.size workloadsMap) + (toList (Validated.initialInputs validatedConfig)) + ) + -- Resolve the name-keyed pools in dependency order: each resolver takes the + -- already-resolved pools its entries reference. Observers stand alone, a + -- recycler needs its pipe, a builder and a workload's targets need their pipe + -- and recycler, and a forwarder bridges an observer to a recycler. + resolvedObservers <- resolveObservers mkObserverFn (Validated.observers validatedConfig) + resolvedPipes <- resolvePipes mkPipeHandleFn inputsByWorkload workloadsMap + resolvedRecyclers <- resolveRecyclers mkRecyclerHandleFn resolvedPipes workloadsMap + resolvedBuilders <- resolveBuilders mkBuilderFn resolvedPipes resolvedRecyclers workloadsMap + resolvedWorkloads <- resolveWorkloads resolvedPipes resolvedRecyclers workloadsMap + resolvedForwarders <- resolveForwarders resolvedRecyclers resolvedObservers workloadsMap + -- Assemble the final runtime. + pure Runtime + { config = validatedConfig + , builders = resolvedBuilders + , pipes = resolvedPipes + , recyclers = resolvedRecyclers + , observers = resolvedObservers + , forwarders = resolvedForwarders + , workloads = resolvedWorkloads + -- Collect all asyncs. Each pool entry carries a single async + -- ('builderAsync', 'recyclerAsync', 'forwarderAsync', 'observerAsync'). + , asyncs = map builderAsync (Map.elems resolvedBuilders) + ++ map recyclerAsync (Map.elems resolvedRecyclers) + ++ map forwarderAsync (Map.elems resolvedForwarders) + ++ map observerAsync (Map.elems resolvedObservers) + } + +-------------------------------------------------------------------------------- +-- Named-pool resolution (builders, pipes, recyclers, observers). +-------------------------------------------------------------------------------- + +-- Definitions are listed builder, pipe, recycler, observer for consistency +-- with the field order. 'resolve' calls them in the reverse (dependency) order. + +-- | Resolve one builder per workload into a name-keyed pool: spawn its build +-- loop over the workload's pipe and recycler (both by workload name). Each loop +-- takes inputs, builds a payload, records the tx's recyclable inputs with the +-- recycler ('Recycler.addToBacklog'), then enqueues the payload. Each 'Builder' +-- keeps its loop thread as 'builderAsync' (which 'resolve' also collects into +-- 'asyncs'). The pipe fires its own (pure) trace handlers. The recycler owns +-- all recycle timing. +resolveBuilders + -- | Builder factory (index, name, config). + :: (Int -> String -> Raw.Builder -> IO (BuilderHandle key input payload)) + -> Map String (Pipe.Pipe key input payload) + -> Map String (Recycler key input payload) + -> Map String Validated.Workload + -> IO (Map String Builder) +resolveBuilders mkBuilderFn resolvedPipes resolvedRecyclers workloadsMap = + Map.fromAscList <$> mapM + (\(ix, (wlName, validatedWorkload)) -> do + let thePipe = resolvedPipes Map.! wlName + recycler = recyclerInternal (resolvedRecyclers Map.! wlName) + strategy = Raw.builderRecycle (Validated.builder validatedWorkload) + builderHandle <- mkBuilderFn ix wlName (Validated.builder validatedWorkload) + -- The safe capability API handed to the builder loop: closures over this + -- builder's pipe and recycler, never the raw resources. 'baAddPayload' + -- holds the recyclable inputs with the recycler, then makes the payload + -- dequeuable, in that order: a release must never precede its + -- 'AddToBacklog' (see the Recycler invariants). Strategy wiring: no + -- strategy holds nothing, on_build confirms right at the build + -- ('Recycler.releaseOutputs', reason-free), the deferred strategies + -- confirm later (at dequeue or on an observer confirm). 'baDropInputs' + -- abandons a batch: 'Pipe.takeInputs' already removed it from the input + -- queue, so skipping the recycler is all it takes to drop it. + let recordBuild key consumed outputInputs = case strategy of + Nothing -> pure () + Just Raw.RecycleOnBuild -> do + Recycler.addToBacklog recycler key consumed outputInputs + Recycler.releaseOutputs recycler key + Just _ -> + Recycler.addToBacklog recycler key consumed outputInputs + api = BuilderApi + { baTakeInputs = Pipe.takeInputs thePipe + , baAddPayload = \key payload consumed outputInputs -> do + recordBuild key consumed outputInputs + Pipe.addPayload thePipe key payload + , baDropInputs = \_inputs -> pure () + } + async <- Async.async $ do + -- Always labeled threads. + tid <- myThreadId + labelThread tid wlName + bhRunBuilder builderHandle api + Async.link async + pure ( wlName + , Builder { builderName = wlName + , builderPipe = wlName + , builderRecycler = wlName + , builderAsync = async + } + ) + ) + -- Zero-based index and name provided to the builder factory. + (zip [0..] (Map.toAscList workloadsMap)) + +-- | Resolve one pipe per workload into a name-keyed pool (name = workload +-- name), loading that workload's initial inputs into it. 'Pipe.mkPipe' owns all +-- queue creation and wires the caller's tracing handlers. The pipe knows +-- nothing about recycling. +resolvePipes + -- | Pipe-events factory (index, name): the tracing handlers the pipe fires at + -- each queue event. + :: (Int -> String -> IO (PipeHandle key input)) + -- | Each workload's initial inputs, keyed by workload name. + -> Map String [input] + -> Map String Validated.Workload + -> IO (Map String (Pipe.Pipe key input payload)) +resolvePipes mkPipeHandleFn inputsByWorkload workloadsMap = + Map.fromAscList <$> mapM + (\(ix, (wlName, _validatedWorkload)) -> do + pipeHandle <- mkPipeHandleFn ix wlName + thePipe <- Pipe.mkPipe + (phOnInputsEnqueued pipeHandle) + (phOnInputsDequeued pipeHandle) + (phOnPayloadEnqueued pipeHandle) + (phOnPayloadDequeued pipeHandle) + -- Load the initial inputs one at a time through 'Pipe.addInputs', the + -- same call the recycler uses so each enters exactly like a recycled one. + mapM_ + (\initialInput -> Pipe.addInputs thePipe [initialInput]) + (inputsByWorkload Map.! wlName) + pure (wlName, thePipe) + ) + -- Zero-based index and name provided to the pipe factory. + (zip [0..] (Map.toAscList workloadsMap)) + +-- | Resolve one recycler per workload into a name-keyed pool. For each, build +-- the 'Internal.Recycler' logic and start its worker (the sole writer of +-- recycled inputs back onto the pipe). Each 'Recycler' wraps that logic with +-- its worker 'recyclerAsync', collected into 'asyncs'. The observer bridge for +-- 'RecycleOnConfirm' is resolved separately, by 'resolveForwarders'. +resolveRecyclers + :: Ord key + -- | Recycler-events factory (index, name): the tracing handlers the recycler + -- fires as payloads enter the backlog and as it recycles inputs. + => (Int -> String -> IO (RecyclerHandle key input payload)) + -> Map String (Pipe.Pipe key input payload) + -> Map String Validated.Workload + -> IO (Map String (Recycler key input payload)) +resolveRecyclers mkRecyclerHandleFn resolvedPipes workloadsMap = + Map.fromAscList <$> mapM + (\(ix, (wlName, _validatedWorkload)) -> do + recyclerHandle <- mkRecyclerHandleFn ix wlName + internal <- Recycler.mkRecycler + (resolvedPipes Map.! wlName) + (rhOnAddToBacklog recyclerHandle) + (rhOnAddToPipe recyclerHandle) + (rhOnReset recyclerHandle) + worker <- Recycler.runRecycler internal wlName + Async.link worker + pure ( wlName + , Recycler { recyclerName = wlName + , recyclerInternal = internal + , recyclerRecover = rhRecover recyclerHandle + , recyclerAsync = worker + } + ) + ) + -- Zero-based index and name provided to the recycler factory. + (zip [0..] (Map.toAscList workloadsMap)) + +-- | Resolve the observers into a name-keyed pool, spawning each one's 'ohRun' +-- in a labeled, linked async. Each 'Observer' keeps its 'ObserverHandle' (as +-- 'observerHandle'), which the forwarders subscribe to on behalf of each +-- referencing workload's recycler. +resolveObservers + -- | Observer factory (index, name, config). + :: (Int -> String -> Raw.Observer -> IO (ObserverHandle key)) + -> Map String Raw.Observer + -> IO (Map String (Observer key)) +resolveObservers mkObserverFn rawObservers = + Map.fromAscList <$> mapM + (\(ix, (obsName, rawObs)) -> do + obsHandle <- mkObserverFn ix obsName rawObs + obsAsync <- Async.async $ do + -- Always labeled threads. + tid <- myThreadId + labelThread tid ("observer/" ++ obsName) + ohRun obsHandle + Async.link obsAsync + pure ( obsName + , Observer { observerName = obsName + , observerHandle = obsHandle + , observerAsync = obsAsync + } + ) + ) + -- Zero-based index and name provided to the observer factory. + (zip [0..] (Map.toAscList rawObservers)) + +-------------------------------------------------------------------------------- +-- Forwarders (observer to recycler). +-------------------------------------------------------------------------------- + +-- | Resolve the forwarders that bridge observers to recyclers. Every forwarder +-- is the same thing: a thread that reads one subscribed observer stream and +-- feeds each event through the workload's strategy wiring into the recycler +-- actions. The recycler knows no strategy, this wiring is the only place an +-- observer event is interpreted: +-- +-- * 'Right' (confirmed) becomes 'Recycler.releaseOutputs' under on_confirm +-- and is ignored otherwise. +-- * 'Left' (orphaned) runs the workload's recovery action when one is +-- wired (a rollback invalidates the queued inputs, and the payloads +-- built from them, beyond the orphaned payload itself) and feeds its +-- result to 'Recycler.reset'. Under on_confirm the reset is KEYED: +-- built payloads stay held until their release, so the recycler applies +-- the reset only while the orphaned payload is still held, and a +-- foreign or duplicate orphan is ignored. The orphan burst of one +-- rollback then collapses at the backlog gate (at one recovery query +-- per orphan event). Under the optimistic strategies the payload was +-- already released at build or dequeue, so the reset is unkeyed and +-- unconditional, and the forwarder then discards the orphan burst the +-- rollback already delivered (one rollback, one recovery) while still +-- forwarding the confirms in it. Without a recovery a 'Left' becomes +-- 'Recycler.releaseConsumed' under on_confirm, and is ignored otherwise. +-- +-- A workload subscribes one forwarder per observer reference in its builder: +-- the 'Raw.RecycleOnConfirm' observer, and the observer its 'Raw.Recovery' +-- names explicitly. An on_confirm recovery without an observer adds no +-- reference (the default, the confirm subscription already carries the +-- orphans). Naming the confirm observer again explicitly creates a second +-- subscription, each event then delivered twice (duplicate confirms, and +-- keyed duplicate resets, are ignored at the unknown key). +-- +-- These are the sole bridges from the observers (which know a transaction's +-- outcome) to the recyclers, which are observer-agnostic and drain only their +-- own event queues. Workloads with no strategy or no observer reference +-- contribute no forwarder. Returns the name-keyed 'forwarders' pool, each +-- entry named by its wiring path (see 'Forwarder'), whose asyncs 'resolve' +-- collects into 'asyncs'. +resolveForwarders + -- | The recyclers to notify, keyed by workload name. + :: Map String (Recycler key input payload) + -- | Observers keyed by name (a strategy names the ones to subscribe to). + -> Map String (Observer key) + -- | Validated workloads (their recycle strategy and recovery select the + -- observers). + -> Map String Validated.Workload + -> IO (Map String Forwarder) +resolveForwarders resolvedRecyclers resolvedObservers workloadsMap = + fmap (Map.fromList . concat) $ mapM + (\(wlName, validatedWorkload) -> + case Raw.builderRecycle (Validated.builder validatedWorkload) of + Nothing -> pure [] + Just strategy -> do + -- All lookups are guaranteed present: recyclers are keyed by + -- workload name, and 'Validated.validate' rejects an undefined + -- observer reference. + let recyclerEntry = resolvedRecyclers Map.! wlName + recycler = recyclerInternal recyclerEntry + -- Strategy wiring: what a confirm means here (see the haddock + -- above). + confirmRight key = case strategy of + Raw.RecycleOnConfirm _ -> Recycler.releaseOutputs recycler key + _ -> pure () + -- One subscription per observer reference, tagged with the + -- config site that wired it ("recycle" or "recovery"): the + -- tag makes the pool keys unique when both sites name the + -- same observer (the documented double subscription). + subscriptions = + [ ("recycle", obsName) + | Raw.RecycleOnConfirm obsName <- [strategy] + ] + ++ [ ("recovery", obsName) + | Just recovery <- + [ Raw.builderRecovery + (Validated.builder validatedWorkload) + ] + , Just obsName <- [Raw.recoveryObserver recovery] + ] + mapM + (\(site, obsName) -> do + let forwarderKey = wlName ++ "/" ++ site ++ "/" ++ obsName + readEvent <- ohSubscribe + (observerHandle (resolvedObservers Map.! obsName)) + let -- Strategy wiring: what an orphan means here (see the + -- haddock above). + step event = case event of + Right key -> confirmRight key + Left key -> case recyclerRecover recyclerEntry of + Just recover -> do + fresh <- recover + case strategy of + -- on_confirm holds a payload until its release, so at + -- its orphan the key is still held and the reset can + -- be gated on it: the recycler drops a foreign or + -- duplicate one. No drain here, the backlog gate + -- absorbs the burst (at one recovery query per orphan + -- event). + Raw.RecycleOnConfirm _ -> + Recycler.reset recycler (Just key) fresh + -- The optimistic strategies released the payload at + -- build or dequeue, so an own orphan is no longer + -- held and the reset cannot be gated: unkeyed and + -- unconditional, followed by the drain that absorbs + -- the rollback's burst into one recovery. + _ -> do + Recycler.reset recycler Nothing fresh + drainOrphans + Nothing -> case strategy of + Raw.RecycleOnConfirm _ -> + Recycler.releaseConsumed recycler key + _ -> pure () + -- Forward the events this subscription already delivered, + -- dropping orphans (the unkeyed reset that just ran covers + -- them), until it is momentarily empty. One rollback delivers + -- a burst of orphans, this absorbs it into one recovery. Only + -- the unkeyed reset path may drain: after a keyed reset the + -- recycler might have ignored it, and draining would then + -- discard genuine orphans. + drainOrphans = do + mEvent <- STM.atomically + ((Just <$> readEvent) `STM.orElse` pure Nothing) + case mEvent of + Nothing -> pure () + Just (Left _) -> drainOrphans + Just (Right key) -> confirmRight key >> drainOrphans + forwarder <- Async.async $ do + -- Always labeled threads. + tid <- myThreadId + labelThread tid forwarderKey + forever (STM.atomically readEvent >>= step) + Async.link forwarder + pure ( forwarderKey + , Forwarder { forwarderName = forwarderKey + , forwarderObserver = obsName + , forwarderRecycler = wlName + , forwarderAsync = forwarder + } + ) + ) + subscriptions + ) + (Map.toAscList workloadsMap) + +-------------------------------------------------------------------------------- +-- Workload resolution. +-------------------------------------------------------------------------------- + +-- | Resolve every workload's targets into a name-keyed pool, threading the +-- rate-limiter cache across all of them so top-level Shared limiters are +-- reused. +-- Each workload's targets fetch from that workload's pipe and signal its +-- recycler (both looked up by workload name). See 'resolveWorkload'. +resolveWorkloads + :: Map String (Pipe.Pipe key input payload) + -> Map String (Recycler key input payload) + -> Map String Validated.Workload + -> IO (Map String (Workload key input payload)) +resolveWorkloads resolvedPipes resolvedRecyclers workloadsMap = do + (resolvedWorkloads, _) <- foldlM + (\(acc, cache) (wlName, validatedWorkload) -> do + (resolved, cache') <- + resolveWorkload + validatedWorkload + cache + (resolvedPipes Map.! wlName) + (recyclerInternal (resolvedRecyclers Map.! wlName)) + pure (Map.insert wlName resolved acc, cache') + ) + (Map.empty, Map.empty) + (Map.toAscList workloadsMap) + pure resolvedWorkloads + +-- | Resolve a single workload: build each target's rate-limited recycling fetch +-- and resolve each target's rate limiter. +-- +-- The 'Pipe' and its 'Recycler' come from the 'pipes' \/ 'recyclers' pools +-- (created by 'resolvePipes' \/ 'resolveRecyclers') and are passed in so that +-- all of the workload's targets share the same underlying queues and recycle +-- loop. +-- +-- Cascading defaults and conflict checks have already been performed by +-- "Cardano.Benchmarking.PullFiction.Config.Validated". This function only +-- creates rate limiters and fetchers. +resolveWorkload + :: Validated.Workload + -- | Limiter cache (threaded as a pure accumulator). + -> LimiterCache + -- | Pipe shared by all the workload's targets (from the 'pipes' pool). + -> Pipe.Pipe key input payload + -- | Recycler for this workload (from the 'recyclers' pool). + -> Recycler.Recycler key input payload + -> IO (Workload key input payload, LimiterCache) +resolveWorkload validatedWorkload cache0 thePipe recycler = do + let wlName = Validated.workloadName validatedWorkload + validatedTargets = Validated.targets validatedWorkload + -- Strategy wiring: only on_pull confirms a payload at dequeue + -- ('Recycler.releaseOutputs', reason-free). + confirmDequeued = + case Raw.builderRecycle (Validated.builder validatedWorkload) of + Just Raw.RecycleOnDequeue -> Recycler.releaseOutputs recycler + _ -> \_key -> pure () + (resolvedTargets, cache') <- foldlM + (\(acc, cache) (tName, validatedTarget) -> do + (resolved, cache'') <- + resolveTarget cache thePipe confirmDequeued validatedTarget + pure (Map.insert tName resolved acc, cache'') + ) + (Map.empty, cache0) + (Map.toAscList validatedTargets) + pure ( Workload { workloadName = wlName + , targets = resolvedTargets + } + , cache' + ) + +-------------------------------------------------------------------------------- +-- Target resolution. +-------------------------------------------------------------------------------- + +-- | Resolve a single target: look up or create its rate limiter from the cache, +-- build its rate-limited recycling fetch around the workload's dequeue wiring, +-- then build the 'Target' record. +resolveTarget + :: LimiterCache + -> Pipe.Pipe key input payload + -- | The workload's dequeue wiring, fired with each dequeued payload's key + -- (for on_pull it confirms the payload, otherwise a no-op). + -> (key -> IO ()) + -> Validated.Target + -> IO (Target key input payload, LimiterCache) +resolveTarget cache thePipe confirmDequeued validatedTarget = do + (limiter, cache') <- getOrCreateLimiter cache validatedTarget + let onEx = Validated.onExhaustion validatedTarget + -- The recycling fetch: fetch from the pipe, fire the workload's dequeue + -- wiring, deliver the payload. + inner = Pipe.payloadFetcher thePipe limiter onEx + fetcher = Pipe.PayloadFetcher + { Pipe.fetchPayload = do + (key, payload) <- Pipe.fetchPayload inner + confirmDequeued key + pure payload + , Pipe.tryFetchPayload = do + mKeyPayload <- Pipe.tryFetchPayload inner + case mKeyPayload of + Nothing -> pure Nothing + Just (key, payload) -> do + confirmDequeued key + pure (Just payload) + } + pure ( Target + { targetName = Validated.targetName validatedTarget + , targetFetcher = fetcher + , rateLimiter = limiter + , maxBatchSize = Validated.maxBatchSize validatedTarget + , onExhaustion = onEx + , targetAddr = Validated.addr validatedTarget + , targetPort = Validated.port validatedTarget + } + , cache' + ) + +-- | Look up or create a 'RL.RateLimiter' for a target. Limiters are shared by +-- the pre-computed 'Validated.rateLimitKey', which encodes the sharing scope: +-- +-- * @\@global@: one limiter for all targets across all workloads. +-- * @workloadName@: one per workload. +-- * @workloadName.targetName@: one per target. +-- * no rate-limit source: 'RL.newUnlimited' (uncached). +-- +-- A cache hit reuses the existing limiter. A miss creates a +-- 'RL.newTokenBucket', inserts it, and returns it. +getOrCreateLimiter + :: LimiterCache + -> Validated.Target + -> IO (RL.RateLimiter, LimiterCache) +getOrCreateLimiter cache target = + case Validated.rateLimitSource target of + Nothing -> pure (RL.newUnlimited, cache) + Just src -> do + let key = Validated.rateLimitKey src + tpsValue = Raw.tps (Validated.rateLimit src) + case Map.lookup key cache of + Just existing -> pure (existing, cache) + Nothing -> do + limiter <- RL.newTokenBucket tpsValue + pure (limiter, Map.insert key limiter cache) + +-------------------------------------------------------------------------------- +-- Input partitioning. +-------------------------------------------------------------------------------- + +-- | Split a list into @n@ contiguous chunks of roughly equal size. +-- The last chunk absorbs any remainder. +partitionInputs :: Int -> [a] -> [[a]] +partitionInputs n xs + | n <= 1 = [xs] + | otherwise = go xs n + where + chunkSize = length xs `div` n + go remaining 1 = [remaining] + go remaining k = + let (chunk, rest) = splitAt chunkSize remaining + in chunk : go rest (k - 1) + diff --git a/bench/tx-centrifuge/lib/pull-fiction/Cardano/Benchmarking/PullFiction/Config/Validated.hs b/bench/tx-centrifuge/lib/pull-fiction/Cardano/Benchmarking/PullFiction/Config/Validated.hs new file mode 100644 index 00000000000..741b8912df3 --- /dev/null +++ b/bench/tx-centrifuge/lib/pull-fiction/Cardano/Benchmarking/PullFiction/Config/Validated.hs @@ -0,0 +1,586 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE NumericUnderscores #-} + +-------------------------------------------------------------------------------- + +-- | Validated load-generator configuration with cascading defaults applied. +-- +-- Types mirror "Cardano.Benchmarking.PullFiction.Config.Raw" but with hidden +-- data constructors. The only way to obtain values is through 'validate', which +-- guarantees that every value has passed validation (e.g. @tps > 0@, +-- valid names, etc). +-- +-- Cascading defaults are resolved here: +-- +-- * @builder@: setting it at both the top level and the workload level is an +-- error; otherwise workload value > top level value > error. +-- * @rate_limit@: setting it at both the top level and the workload level is an +-- error; otherwise the workload inherits the top-level value (or 'Nothing' +-- for unlimited). +-- * @max_batch_size@: target value > workload value > top-level value > +-- default (0, unlimited). +-- * @on_exhaustion@: target value > workload value > top-level value > +-- default (@\"block\"@). +-- +-- After 'validate', every 'Target' has a concrete @maxBatchSize@ and every +-- 'Workload' has a concrete @builder@ (no 'Maybe'). +-- +-- 'Workload' and 'Config' store their children in 'Map's keyed by name +-- (alphabetical order, JSON object key order is not preserved). +-- +-- __Import qualified.__ Field names clash with +-- "Cardano.Benchmarking.PullFiction.Config.Raw" and +-- "Cardano.Benchmarking.PullFiction.Config.Runtime". +module Cardano.Benchmarking.PullFiction.Config.Validated + ( + -- * Config. + Config + , initialInputs, inputSources, observers, workloads, startupDelaySeconds + + -- * Workload. + , Workload + , workloadName, builder, targets + + -- * RateLimitSource. + , RateLimitSource (..) + + -- * Target. + , Target + , targetName + , rateLimitSource + , maxBatchSize, onExhaustion + , addr, port + + -- * Validation. + , validate + + ) where + +-------------------------------------------------------------------------------- + +---------- +-- base -- +---------- +import Control.Monad (when) +import Data.List.NonEmpty (NonEmpty) +import Data.Maybe (fromMaybe) +import Numeric.Natural (Natural) +---------------- +-- containers -- +---------------- +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +------------------ +-- pull-fiction -- +------------------ +import Cardano.Benchmarking.PullFiction.Config.Raw qualified as Raw + +-------------------------------------------------------------------------------- +-- Defaults. +-------------------------------------------------------------------------------- + +-- | Default scope for a top-level rate limiter when not specified in JSON. +defaultTopLevelScope :: Raw.TopLevelScope +defaultTopLevelScope = Raw.TopShared + +-- | Default scope for a workload-level rate limiter when not specified in JSON. +defaultWorkloadScope :: Raw.WorkloadScope +defaultWorkloadScope = Raw.WorkloadShared + +-- | Default maximum batch size when neither the workload nor the top-level +-- config specifies one. 0 means unlimited (use whatever the node requests). +defaultMaxBatchSize :: Natural +defaultMaxBatchSize = 0 + +-- | Default on-exhaustion behaviour when not specified at any level. +defaultOnExhaustion :: Raw.OnExhaustion +defaultOnExhaustion = Raw.Block + +-- | Default startup delay in seconds when not specified in JSON. +-- 0 means no delay: workers connect to targets as soon as they are spawned. +defaultStartupDelaySeconds :: Natural +defaultStartupDelaySeconds = 0 + +-------------------------------------------------------------------------------- + +-- | Top-level configuration. +-- +-- See 'Raw.Config' for field semantics. All invariants have been checked and +-- cascading defaults applied by 'validate'. +data Config input = Config + { -- | Initial inputs provided by the caller and stored by 'validate'. + initialInputs :: !(NonEmpty input) + -- | Input sources (keyed by name). + -- Opaque; interpretation is the caller's responsibility. + , inputSources :: !(Map String Raw.InputSource) + -- | Observers (keyed by name). + -- Opaque; interpretation is the caller's responsibility. + , observers :: !(Map String Raw.Observer) + -- | Workloads keyed by name. Iteration order is alphabetical (Map order). + , workloads :: !(Map String Workload) + -- | Resolved startup delay in seconds with 0 meaning no delay. + -- Consumed by the caller (see @Main.hs@). + , startupDelaySeconds :: !Natural + } + deriving (Show, Eq) + +-------------------------------------------------------------------------------- + +-- | A single workload with cascading defaults applied. +-- +-- 'builder' is always concrete (no 'Maybe'); cascading from the top level +-- config is performed by 'validate'. +data Workload = Workload + { -- | User provided name. + workloadName :: !String + -- | Resolved builder: workload value > top level value. + -- Opaque; interpretation is the caller's responsibility. + , builder :: !Raw.Builder + -- | Targets keyed by name. Iteration order is alphabetical. + , targets :: !(Map String Target) + } + deriving (Show, Eq) + +-------------------------------------------------------------------------------- + +-- | Resolved rate limit for a target, with its sharing key pre-computed. +-- +-- The 'rateLimitKey' encodes the sharing boundary using fully qualified names: +-- +-- * @\@global@: one limiter shared by all targets across all workloads. +-- * @workloadName@: one limiter per workload (each shared by all its targets). +-- * @workloadName.targetName@: one limiter per target. +-- +-- Because workload and target names may not start with @\@@ or contain @.@ +-- (enforced at validation time), these keys are guaranteed to be unique. +data RateLimitSource = RateLimitSource + { -- | Cache key for limiter sharing (the fully qualified name). + rateLimitKey :: !String + -- | Validated rate limit parameters. + , rateLimit :: !Raw.RateLimit + } + deriving (Show, Eq) + +-------------------------------------------------------------------------------- + +-- | A target endpoint to connect to. +-- +-- 'maxBatchSize' and 'onExhaustion' are concrete (no 'Maybe'). Cascading +-- defaults have been applied by 'validate'. +data Target = Target + { -- | User provided name. + targetName :: !String + -- | Resolved rate limit source ('Nothing' means unlimited). + , rateLimitSource :: !(Maybe RateLimitSource) + -- | Resolved max batch size. + -- 0 means unlimited, use whatever the node requests. + -- target value > workload value > top-level value > default (0, unlimited). + , maxBatchSize :: !Natural + -- | Resolved on-exhaustion behaviour. + -- target value > workload value > top-level value > default (block). + , onExhaustion :: !Raw.OnExhaustion + -- How to connect to the target. + , addr :: !String + , port :: !Int + } + deriving (Show, Eq) + +-------------------------------------------------------------------------------- +-- Validation. +-------------------------------------------------------------------------------- + +-- | Validate a 'Raw.Config', enforce all business rules, and cascade top-level +-- defaults into workloads. +-- +-- Input loading is the caller's responsibility; passes the already-loaded +-- inputs directly. This keeps the validation layer pure and decouples it from +-- IO concerns like key loading and network magic interpretation. +-- +-- Returns 'Left' with a descriptive error message on the first violation. +validate + -- | Raw configuration as parsed from JSON. + :: Raw.Config + -- | Initial inputs (already loaded by the caller). + -> NonEmpty input + -> Either String (Config input) +validate raw inputs = do + -- Input sources. Always top-level and by name. + -- (opaque; passed through without interpretation). + let resolvedSources = fromMaybe + Map.empty -- Default value. + (Raw.maybeInputSources raw) + -- Observers. Always top-level and by name. + -- (opaque; passed through without interpretation). + let resolvedObservers = fromMaybe + Map.empty -- Default value. + (Raw.maybeObservers raw) + -- Names. Workload and target names are validated in their validators. + -- Observer and input source names are the Map keys, validated here: observer + -- names end up inside the forwarder pool's wiring-path keys (see + -- Config.Runtime), input source names follow the same rule for uniformity. + mapM_ (validateName "Observer") (Map.keys resolvedObservers) + mapM_ (validateName "InputSource") (Map.keys resolvedSources) + -- Top level builder. Future iterations will have builders by name. + -- (opaque; passed through without interpretation). + let maybeTopBuilder = Raw.maybeTopLevelBuilder raw + -- Top level rate limit. + maybeTopRateLimit <- + case Raw.maybeTopLevelRateLimit raw of + Nothing -> pure Nothing + Just (maybeTopScope, rawRL) -> do + let topScope = fromMaybe + defaultTopLevelScope -- Default value. + maybeTopScope + validatedRL <- validateRateLimit rawRL + pure (Just (topScope, validatedRL)) + -- Max batch size. + let topMaxBatchSize = fromMaybe + defaultMaxBatchSize -- Default value. + (Raw.maybeTopLevelMaxBatchSize raw) + -- On-exhaustion behaviour. + let topOnExhaustion = fromMaybe + defaultOnExhaustion -- Default value. + (Raw.maybeTopLevelOnExhaustion raw) + -- Workloads. + let rawWorkloads = fromMaybe + Map.empty -- Default value. + (Raw.maybeWorkloads raw) + when (Map.null rawWorkloads) $ + Left "Config: at least one workload is required" + workloadsMap <- Map.traverseWithKey + (\name workload -> + validateWorkload + name + maybeTopBuilder + maybeTopRateLimit + topMaxBatchSize + topOnExhaustion + workload + ) + rawWorkloads + -- Inputs must cover all workloads: Runtime.partitionInputs splits them into + -- contiguous chunks, so fewer inputs than workloads leaves some with zero. + let inputCount = length inputs + when (inputCount < Map.size workloadsMap) $ + Left $ "Config: not enough initial inputs (" ++ show inputCount + ++ ") for " ++ show (Map.size workloadsMap) ++ " workload(s)" + -- Referential integrity of the input source and observers pools: every + -- referenced name defined, every defined name referenced. The two pools are + -- independent namespaces: every reference field is typed ("source" fields + -- resolve against input sources, "observer" fields against observers), so an + -- observer and an input source may share a name. + validateInputSourceReferences + resolvedSources + (Raw.initialInputsSource (Raw.initialInputs raw)) + workloadsMap + validateObserverReferences resolvedObservers workloadsMap + -- Startup delay (top-level scalar, no cascade). Default 0 (no delay). + let startupDelay = fromMaybe + defaultStartupDelaySeconds -- Default value. + (Raw.maybeStartupDelaySeconds raw) + -- Final validated config. + pure Config + { initialInputs = inputs + , inputSources = resolvedSources + , observers = resolvedObservers + , workloads = workloadsMap + , startupDelaySeconds = startupDelay + } + +-------------------------------------------------------------------------------- + +-- Returns 'Left' with a descriptive error message on the first violation. +validateWorkload + -- | Workload name (from Map key). + :: String + -- | Top level builder (opaque). + -> Maybe Raw.Builder + -- | Validated top-level scope / rate limit. + -> Maybe (Raw.TopLevelScope, Raw.RateLimit) + -- | Resolved top-level max batch size. + -> Natural + -- | Resolved top-level on-exhaustion behaviour. + -> Raw.OnExhaustion + -- | The parsed workload from JSON. + -> Raw.Workload + -> Either String Workload +validateWorkload name + maybeTopBuilder + maybeTopRateLimit + topMaxBatchSize + topOnExhaustion + rawWorkload = do + -- Name. + validateName "Workload" name + -- Builder conflict: setting at both levels is ambiguous. + case (maybeTopBuilder, Raw.maybeBuilder rawWorkload) of + (Just _, Just _) -> + Left $ "builder set at both the top level and in workload: " ++ show name + _ -> pure () + -- Resolve builder: workload level > top level > error. + resolvedBuilder <- do + case Raw.maybeBuilder rawWorkload of + Just parsedBuilder -> do + -- Workload-level builder is used (top-level was already ruled out above). + pure parsedBuilder + Nothing -> do + case maybeTopBuilder of + Just topLevelBuilder -> pure topLevelBuilder + Nothing -> Left $ + "Workload " ++ show name + ++ ": builder is required (no workload or top level default)" + -- Recovery rules. A recovery reseeds the recycling loop, so it requires a + -- recycle strategy. And a recovery without an explicit observer defaults to + -- the confirm observer, which only on_confirm has. + case Raw.builderRecovery resolvedBuilder of + Nothing -> pure () + Just recovery -> + case Raw.builderRecycle resolvedBuilder of + Nothing -> Left $ + "Workload " ++ show name + ++ ": \"recovery\" requires a \"recycle\" strategy" + Just strategy -> + case (Raw.recoveryObserver recovery, strategy) of + (Just _, _) -> pure () + (Nothing, Raw.RecycleOnConfirm _) -> pure () + (Nothing, _) -> Left $ + "Workload " ++ show name + ++ ": \"recovery\" without an \"observer\" is only valid with" + ++ " the \"on_confirm\" recycle strategy (the default is the" + ++ " confirm observer)" + -- Rate-limit conflict: setting at both levels is ambiguous. + case (maybeTopRateLimit, Raw.maybeRateLimit rawWorkload) of + (Just _, Just _) -> + Left $ + "rate_limit is set at both the top level and in workload: " ++ show name + _ -> pure () + -- Resolve effective rate limit: workload-level > top-level > unlimited. + -- The scope and validated rate limit are cascaded to validateTarget, which + -- computes the final RateLimitSource (including the cache key). + effectiveRateLimit <- do + case Raw.maybeRateLimit rawWorkload of + -- There is a rate limit at the workload level. + Just (maybeWlScope, rawRL) -> do + validatedRL <- validateRateLimit rawRL + let wlScope = fromMaybe + defaultWorkloadScope -- Default value. + maybeWlScope + -- `Right` workload scope. + pure (Just (Right wlScope, validatedRL)) + -- There is no rate limit at the workload level. + Nothing -> do + case maybeTopRateLimit of + Just (topScope, validatedTopRL) -> do + -- `Left` top level scope. + pure (Just (Left topScope, validatedTopRL)) + Nothing -> do + pure Nothing + -- Cascade max_batch_size: workload > top-level (always concrete). + -- The per-target override is applied inside validateTarget. + let workloadBatchSize = fromMaybe + topMaxBatchSize -- Default value. + (Raw.maybeMaxBatchSize rawWorkload) + -- Cascade on_exhaustion: workload > top-level. + let workloadOnExhaustion = fromMaybe + topOnExhaustion -- Default value. + (Raw.maybeOnExhaustion rawWorkload) + -- Targets. + when (Map.null (Raw.targets rawWorkload)) $ + Left $ "Workload " ++ show name ++ ": targets must not be empty" + targetsMap <- Map.traverseWithKey + (\tName target -> validateTarget + name tName effectiveRateLimit workloadBatchSize workloadOnExhaustion target + ) + (Raw.targets rawWorkload) + -- Final validated workload. + pure Workload + { workloadName = name + , builder = resolvedBuilder + , targets = targetsMap + } + +-- Returns 'Left' with a descriptive error message on the first violation. +validateTarget + -- | Workload name (for cache key computation). + :: String + -- | Target name (from Map key). + -> String + -- | If 'Just': 'Left' is top level scope, 'Right' is workload scope. + -> Maybe (Either Raw.TopLevelScope Raw.WorkloadScope, Raw.RateLimit) + -- | Resolved max batch size. + -> Natural + -- | Resolved on-exhaustion behaviour. + -> Raw.OnExhaustion + -- The target parsed from JSON. + -> Raw.Target + -> Either String Target +validateTarget wlName tgtName effectiveRateLimit workloadBatchSize workloadOnExhaustion rawTarget = do + -- Name. + validateName "Target" tgtName + -- Resolve rate limit source with pre-computed cache key. + -- The key scheme uses fully-qualified names: + -- @global → one limiter for everything + -- workloadName → one per workload + -- workloadName.target → one per target + let maybeRateLimitSource = + case effectiveRateLimit of + Nothing -> Nothing + Just (scope, rl) -> Just $ case scope of + -- Using the scope set at the top level rate limit. + Left Raw.TopShared -> RateLimitSource "@global" rl + Left Raw.TopPerWorkload -> RateLimitSource wlName rl + Left Raw.TopPerTarget -> RateLimitSource (wlName++"."++tgtName) rl + -- Using scope set at the workload level rate limit. + Right Raw.WorkloadShared -> RateLimitSource wlName rl + Right Raw.WorkloadPerTarget -> RateLimitSource (wlName++"."++tgtName) rl + -- Cascade max_batch_size: target > workload (always concrete). + let resolvedMaxBatchSize = fromMaybe + workloadBatchSize -- Default value. + (Raw.maybeTargetMaxBatchSize rawTarget) + -- Cascade on_exhaustion: target > workload (always concrete). + let resolvedOnExhaustion = fromMaybe + workloadOnExhaustion -- Default value. + (Raw.maybeTargetOnExhaustion rawTarget) + -- Final validated target. + pure Target + { targetName = tgtName + , rateLimitSource = maybeRateLimitSource + , maxBatchSize = resolvedMaxBatchSize + , onExhaustion = resolvedOnExhaustion + , addr = Raw.addr rawTarget + , port = Raw.port rawTarget + } + +-------------------------------------------------------------------------------- + +-- | Referential integrity between input sources and their two reference sites, +-- @initial_inputs@ and builder recoveries: every referenced source must be +-- defined and every defined source must be referenced. Runtime and the caller +-- rely on this: they look the source up by name, never re-checking. +-- +-- Returns 'Left' with a descriptive error message on the first violation. +validateInputSourceReferences + -- | Defined input sources (keyed by name). + :: Map String Raw.InputSource + -- | The @initial_inputs@ source reference. + -> String + -- | Validated workloads (their builders' recoveries name the sources). + -> Map String Workload + -> Either String () +validateInputSourceReferences definedSources initialSource workloadsMap = do + let referencedSources = + initialSource + : [ Raw.recoverySource recovery + | wl <- Map.elems workloadsMap + , Just recovery <- [Raw.builderRecovery (builder wl)] + ] + unknownSources = filter + (`Map.notMember` definedSources) + referencedSources + unusedSources = filter + (`notElem` referencedSources) + (Map.keys definedSources) + case unknownSources of + [] -> pure () + _ -> Left $ + "undefined input source(s) referenced: " + ++ show unknownSources + case unusedSources of + [] -> pure () + _ -> Left $ + "input source(s) defined but never referenced: " + ++ show unusedSources + +-- | Referential integrity between builders and observers: every observer named +-- by some builder's 'Raw.RecycleOnConfirm' or 'Raw.Recovery' must be defined, +-- and every defined observer must be referenced by some builder. +-- Same rules as 'validateInputSourceReferences'. +-- +-- Returns 'Left' with a descriptive error message on the first violation. +validateObserverReferences + -- | Defined observers (keyed by name). + :: Map String Raw.Observer + -- | Validated workloads (their builders name the observers). + -> Map String Workload + -> Either String () +validateObserverReferences definedObservers workloadsMap = do + let builderObservers wl = + [ obsName + | Just (Raw.RecycleOnConfirm obsName) <- + [Raw.builderRecycle (builder wl)] + ] + ++ [ obsName + | Just recovery <- [Raw.builderRecovery (builder wl)] + , Just obsName <- [Raw.recoveryObserver recovery] + ] + referencedObservers = + [ obsName + | wl <- Map.elems workloadsMap + , obsName <- builderObservers wl + ] + unknownObservers = filter + (`Map.notMember` definedObservers) + referencedObservers + unusedObservers = filter + (`notElem` referencedObservers) + (Map.keys definedObservers) + -- A builder's RecycleOnConfirm or recovery must name a defined observer, else + -- its confirm/orphan stream has no source. Runtime relies on this: it looks + -- the observer up by name (a total 'Map.!'), never re-checking. + case unknownObservers of + [] -> pure () + _ -> Left $ + "builder(s) reference undefined observer(s): " + ++ show unknownObservers + -- Conversely, an observer defined but referenced by no builder runs for + -- nothing and the generator silently drains funds. The most common cause is + -- placing the "recycle" key inside "params" instead of at the builder level. + case unusedObservers of + [] -> pure () + _ -> Left $ + "observer(s) defined but not referenced by any builder: " + ++ show unusedObservers + ++ ".\nHint: \"recycle\" must be a sibling of \"type\" and" + ++ " \"params\" in the builder object, not nested inside \"params\"." + +-------------------------------------------------------------------------------- + +validateRateLimit :: Raw.RateLimit -> Either String Raw.RateLimit +validateRateLimit rl@(Raw.TokenBucket rawTps) = do + when (isNaN rawTps) $ + Left "RateLimit: tps must be a number, got NaN" + when (isInfinite rawTps) $ + Left "RateLimit: tps must be finite" + when (rawTps <= 0) $ + Left "RateLimit: tps must be > 0" + -- Guard against extremely small TPS values: 1e9 / tps can overflow to + -- Infinity, and `round Infinity :: Integer` throws at runtime. + when (isInfinite (1_000_000_000 / rawTps)) $ + Left "RateLimit: tps is too small (1e9 / tps overflows)" + -- Guard against extremely large TPS values: round(1e9 / tps) can reach 0, + -- which silently disables the rate limiter. + when (round (1_000_000_000 / rawTps) == (0 :: Integer)) $ + Left "RateLimit: tps is too large (nanosPerToken rounds to 0)" + pure rl + +-- | Validate that a name does not start with @\'@\'@ and contains neither +-- @\'.\'@ nor @\'/\'@. +-- +-- @\'@\'@ and @\'.\'@ are reserved for the rate-limit cache key scheme (see +-- 'RateLimitSource'). @\'/\'@ is reserved for the forwarder pool's +-- wiring-path keys, @workload\/site\/observer@ (see @Config.Runtime@): a name +-- containing @\'/\'@ could make two paths collide, silently losing a pool +-- entry. +validateName :: String -> String -> Either String () +validateName context name = do + case name of + [] -> + Left $ context ++ ": name must be non-empty" + ('@':_) -> + Left $ context ++ ": name must not start with '@', got " ++ show name + _ -> pure () + when ('.' `elem` name) $ + Left $ context ++ ": name must not contain '.', got " ++ show name + when ('/' `elem` name) $ + Left $ context ++ ": name must not contain '/', got " ++ show name + diff --git a/bench/tx-centrifuge/lib/pull-fiction/Cardano/Benchmarking/PullFiction/Internal/Pipe.hs b/bench/tx-centrifuge/lib/pull-fiction/Cardano/Benchmarking/PullFiction/Internal/Pipe.hs new file mode 100644 index 00000000000..a18eb5d607a --- /dev/null +++ b/bench/tx-centrifuge/lib/pull-fiction/Cardano/Benchmarking/PullFiction/Internal/Pipe.hs @@ -0,0 +1,410 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE NumericUnderscores #-} + +-------------------------------------------------------------------------------- + +-- | The 'Pipe': a generic pair of STM queues that moves items and nothing more. +-- It owns two private queues, an unbounded input queue (with a live depth +-- counter) and a bounded payload queue, and reports every queue change through +-- four caller-supplied event handlers (e.g. for tracing). +-- +-- Work flows input queue → builder → payload queue → worker. The 'Pipe' knows +-- /nothing/ about recycling: the bookkeeping and the recycle loop that closes +-- inputs back onto the input queue live in +-- 'Cardano.Benchmarking.PullFiction.Internal.Recycler' (the strategy wiring +-- lives in 'Config.Runtime'), which drives this pipe from the outside (it +-- calls 'addInputs' to recycle). 'Config.Runtime' wraps 'payloadFetcher' and +-- fires the workload's dequeue wiring on each pull. +-- +-- The input queue has 'addInputs' \/ 'takeInputs'. The payload queue has +-- 'addPayload' (in) and 'payloadFetcher' (out, rate-limited). Each queue also +-- has a drop ('dropInputs' \/ 'dropPayloads'), the reset primitives that +-- empty it. Every payload +-- carries a @key@ that identifies it (e.g. its txId). The key rides through the +-- pipe untouched so that the fetcher's caller can correlate a pulled payload +-- with its own recycle bookkeeping, and so the enqueue \/ dequeue handlers can +-- put it in a trace. The pipe never interprets the key. +-- +-- The 'Pipe' is purely synchronous and spawns no threads: every operation +-- returns once its STM work and event handler complete (a blocking fetch parks +-- the /caller's/ thread, it starts none of its own). All async behaviour lives +-- outside, never here (the builder loop and the recycler in 'Config.Runtime', +-- the observer announce loop and per-target fetch workers in @Main@). +-- +-- The data constructor is hidden, build a 'Pipe' with 'mkPipe'. +module Cardano.Benchmarking.PullFiction.Internal.Pipe + ( -- * Pipe (content is kept private). + Pipe, mkPipe + -- * Event handlers. + , OnPayloadEvent + , OnInputsEvent + -- * Input queue operations (the queue itself is private). + , takeInputs + , addInputs + , dropInputs + -- * Payload queue operations (the queue itself is private). + , addPayload + , dropPayloads + , QueueStarved (..), PayloadFetcher (..), payloadFetcher + ) where + +-------------------------------------------------------------------------------- + +---------- +-- base -- +---------- +import Control.Concurrent (threadDelay) +import Control.Exception (Exception, throwIO) +import Control.Monad (replicateM, when) +import Numeric.Natural (Natural) +--------- +-- stm -- +--------- +import Control.Concurrent.STM qualified as STM +------------------ +-- pull-fiction -- +------------------ +import Cardano.Benchmarking.PullFiction.Clock qualified as Clock +import Cardano.Benchmarking.PullFiction.Config.Raw qualified as Raw +import Cardano.Benchmarking.PullFiction.Internal.RateLimiter qualified as RL + +-------------------------------------------------------------------------------- + +-- | Handler for an input-queue event, given the inputs that were added or +-- removed and the input-queue depth afterwards. Passing the inputs (rather than +-- just their count) lets the caller put their data in a trace. The count is +-- their @length@. +type OnInputsEvent input = [input] -> Natural -> IO () + +-- | Handler for a payload-queue event, given the payload's key and the +-- payload-queue depth afterwards. Passing the key (as 'OnInputsEvent' passes the +-- inputs) lets the caller put it in a trace. +type OnPayloadEvent key = key -> Natural -> IO () + +-- | Two private queues plus queue-event handlers. +-- Construct with 'mkPipe' only, the constructor is not exported. +data Pipe key input payload = Pipe + { -- | Unbounded input queue (TQueue): must never block on write (the initial + -- load at startup, recycle bursts at steady-state). Backpressure comes from + -- 'pipePayloadQueue' instead. + pipeInputQueue :: !(STM.TQueue input) + -- | Live element count of 'pipeInputQueue'. ('STM.TQueue' has no O(1) + -- length, so we track it: starts at @0@ in 'mkPipe', @+@ on 'addInputs', + -- @-@ on 'takeInputs', always in the same STM transaction as the queue + -- itself.) + , pipeInputDepth :: !(STM.TVar Natural) + -- | Bounded payload queue (capacity 'payloadQueueCapacity'). It's the sole + -- source of backpressure. Each element is @(key, payload)@: the key rides + -- along so the fetcher's caller can identify the pulled payload (e.g. for + -- its recycle bookkeeping) and the dequeue handler can trace it. + , pipePayloadQueue :: !(STM.TBQueue (key, payload)) + -- | Fired after inputs are added to the input queue (by 'addInputs': the + -- caller's initial load or a recycle). + , pipeOnInputsEnqueued :: !(OnInputsEvent input) + -- | Fired after inputs are removed from the input queue ('takeInputs'). + , pipeOnInputsDequeued :: !(OnInputsEvent input) + -- | Fired after a payload is added to the payload queue ('addPayload'). + , pipeOnPayloadEnqueued :: !(OnPayloadEvent key) + -- | Fired after a payload is removed from the payload queue (by + -- 'payloadFetcher'). + , pipeOnPayloadDequeued :: !(OnPayloadEvent key) + } + +-------------------------------------------------------------------------------- + +-- | Capacity of 'pipePayloadQueue'. Bounded (unlike the input queue): the +-- builder blocks here when workers cannot consume fast enough, which is the +-- pipeline's sole source of backpressure. Large enough to absorb GC pauses at +-- high TPS (e.g. 100k TPS drains 8192 entries in ~80 ms). +payloadQueueCapacity :: Natural +payloadQueueCapacity = 8192 + +-- | Build an empty 'Pipe' with the four queue-event handlers (input enqueued\/ +-- dequeued, payload enqueued\/dequeued). The only way to construct a 'Pipe', so +-- the queues and the depth counter are always created consistently. +-- +-- The input queue starts empty. The caller loads the initial inputs afterwards +-- with 'addInputs', the same call the recycler uses, so an initial input is +-- indistinguishable from a recycled one. There is no \"initial input\" concept +-- below this call. +mkPipe + :: OnInputsEvent input -- ^ Fired after inputs are enqueued (added). + -> OnInputsEvent input -- ^ Fired after inputs are dequeued (taken). + -> OnPayloadEvent key -- ^ Fired after a payload is enqueued. + -> OnPayloadEvent key -- ^ Fired after a payload is dequeued (pulled). + -> IO (Pipe key input payload) +mkPipe onInputEnqueued onInputDequeued onPayloadEnqueued onPayloadDequeued = do + -- Input queue: unbounded (TQueue) so loading and recycling never block. + -- It starts empty, the caller must load (initial) inputs through 'addInputs'. + inputQueue <- STM.newTQueueIO + inputDepth <- STM.newTVarIO (0 :: Natural) + -- Payload queue: bounded (see 'payloadQueueCapacity'), the sole backpressure. + payloadQueue <- STM.newTBQueueIO payloadQueueCapacity + pure Pipe + { -- STM fields. + pipeInputQueue = inputQueue + , pipeInputDepth = inputDepth + , pipePayloadQueue = payloadQueue + -- Events. + , pipeOnInputsEnqueued = onInputEnqueued + , pipeOnInputsDequeued = onInputDequeued + , pipeOnPayloadEnqueued = onPayloadEnqueued + , pipeOnPayloadDequeued = onPayloadDequeued + } + +-------------------------------------------------------------------------------- + +-- | Add inputs to the input queue, bump the depth counter and fire the +-- input-enqueued handler with the added inputs and the resulting input-queue +-- depth. The write and the depth read share one STM transaction but the handler +-- runs after it. An empty input list is a no-op (no trace). +-- +-- The only path onto the input queue, used both to load the initial inputs and +-- (by 'Internal.Recycler') to recycle. It treats every input the same, +-- regardless of where it came from. +addInputs :: Pipe key input payload -> [input] -> IO () +addInputs pipe inputs = when (not (null inputs)) $ do + inputDepth <- STM.atomically $ do + ---------- STM START ---------- + mapM_ (STM.writeTQueue (pipeInputQueue pipe)) inputs + STM.modifyTVar' (pipeInputDepth pipe) (+ fromIntegral (length inputs)) + STM.readTVar (pipeInputDepth pipe) + ---------- STM ENDED ---------- + -- Caller event: InputsEnqueued. + pipeOnInputsEnqueued pipe inputs inputDepth + +-- | Take @n@ inputs for the builder: block until @n@ are available, remove them +-- from the input queue, and decrement the depth counter, all in one STM +-- transaction, then fire the input-dequeued handler with the taken inputs and +-- the resulting input-queue depth outside STM. +-- Blocking here is the intended backpressure when inputs are scarce (e.g. all +-- in flight). +takeInputs :: Pipe key input payload -> Natural -> IO [input] +takeInputs pipe n = do + (inputs, inputDepth) <- STM.atomically $ do + ---------- STM START ---------- + is <- replicateM (fromIntegral n) (STM.readTQueue (pipeInputQueue pipe)) + STM.modifyTVar' (pipeInputDepth pipe) (subtract (fromIntegral (length is))) + depth <- STM.readTVar (pipeInputDepth pipe) + pure (is, depth) + ---------- STM ENDED ---------- + -- Caller event: InputsDequeued. + pipeOnInputsDequeued pipe inputs inputDepth + pure inputs + +-- | Drop every input currently in the input queue: atomically empty it +-- and reset the depth counter to zero, returning the removed inputs so the +-- caller can trace what it discarded. Fires the input-dequeued handler with the +-- removed inputs and the resulting depth (@0@). An empty queue is a no-op. +-- +-- Unlike 'takeInputs' (which removes a fixed @n@ and blocks until they are +-- available), 'dropInputs' removes whatever is present and never blocks. It is +-- the reset primitive: a caller that has learned its queued inputs are stale +-- (e.g. a rollback invalidated them) drops them here, then reseeds the queue +-- with 'addInputs'. +dropInputs :: Pipe key input payload -> IO [input] +dropInputs pipe = do + inputs <- STM.atomically $ do + ---------- STM START ---------- + is <- STM.flushTQueue (pipeInputQueue pipe) + STM.writeTVar (pipeInputDepth pipe) 0 + pure is + ---------- STM ENDED ---------- + -- Caller event: InputsDequeued (the emptied queue's inputs, depth 0). + when (not (null inputs)) $ + pipeOnInputsDequeued pipe inputs 0 + pure inputs + +-------------------------------------------------------------------------------- + +-- | Add a built payload to the payload queue (the payload-side counterpart of +-- 'addInputs'), tagged with its @key@, then fire the payload-enqueued handler +-- with the payload-queue depth (measured via 'STM.lengthTBQueue' in the same +-- transaction as the write). +-- +-- The pipe stores and forwards @(key, payload)@ untouched. What the key means +-- (e.g. a txId) and any recycle bookkeeping under it are the caller's concern +-- (see 'Internal.Recycler'). +addPayload + :: Pipe key input payload + -> key -- ^ Key identifying this payload (e.g. its txId). + -> payload -- ^ The built payload to add for workers. + -> IO () +addPayload pipe key payload = do + payloadDepth <- STM.atomically $ do + ---------- STM START ---------- + STM.writeTBQueue (pipePayloadQueue pipe) (key, payload) + STM.lengthTBQueue (pipePayloadQueue pipe) + ---------- STM ENDED ---------- + -- Caller event: PayloadEnqueued. + pipeOnPayloadEnqueued pipe key payloadDepth + +-- | Drop every payload currently in the payload queue: atomically empty it, +-- returning the removed @(key, payload)@ pairs so the caller can count or +-- trace what it discarded. An empty queue is a no-op. +-- +-- The payload-side counterpart of 'dropInputs' and the other half of the +-- reset primitive: payloads built from dropped inputs are as stale as the +-- inputs themselves, so a caller resetting the input queue drops them too +-- instead of delivering transactions that no longer apply. No queue event +-- fires here: the payload-dequeued handler carries a single key, so a full +-- queue would emit thousands of events on one reset. The caller reports the +-- drop instead (see the Reset event in 'Internal.Recycler'). +dropPayloads :: Pipe key input payload -> IO [(key, payload)] +dropPayloads pipe = + STM.atomically $ STM.flushTBQueue (pipePayloadQueue pipe) + +-------------------------------------------------------------------------------- +-- Payload fetch (rate-limited). +-------------------------------------------------------------------------------- + +-- | Fatal exception thrown, in 'Raw.Error' on-exhaustion mode, when the payload +-- queue is empty but the rate limiter has authorized a fetch: the payload +-- builder cannot produce payloads fast enough for the configured TPS demand. +-- The caller must reduce TPS, add initial inputs, enlarge the payload queue, or +-- parallelise the builder. In 'Raw.Block' mode the fetch waits instead, the +-- blocking fetch parks until a payload arrives and if non-blocking returns +-- 'Nothing'. +data QueueStarved = QueueStarved !String + deriving (Show) + +instance Exception QueueStarved + +-- | The two rate-limited ways to pull from a queue, produced by 'payloadFetcher'. +-- The payload queue itself is never exposed, so a payload can only leave the +-- pipe through one of these, always paced by the rate limiter and always firing +-- the payload-dequeued handler. Parameterised over the pulled element @a@ +-- (here @(key, payload)@) so a caller can wrap it (e.g. 'Config.Runtime' +-- strips the key after firing the dequeue wiring with it). +data PayloadFetcher a = PayloadFetcher + { -- | Claim a rate-limit slot, sleep for the computed delay, and return one + -- element. On an empty queue it either parks until a payload arrives + -- ('Raw.Block') or throws 'QueueStarved' ('Raw.Error'). + fetchPayload :: IO a + -- | Return @Just a@ if the rate limit allows and the queue is non-empty, + -- 'Nothing' if ahead of schedule, or if the queue is empty in 'Raw.Block' + -- mode. Throws 'QueueStarved' on an empty queue in 'Raw.Error'. + , tryFetchPayload :: IO (Maybe a) + } + +-- | Build the rate-limited payload fetcher for one consumer (e.g. one target) +-- over this 'Pipe'\'s private payload queue, pacing every pull with the given +-- 'RL.RateLimiter' and handling an empty queue per 'Raw.OnExhaustion'. +-- +-- Each successful pull removes one @(key, payload)@ from the queue in a single +-- rate-limit transaction (never parking inside STM while payloads flow), sleeps +-- for the computed delay /outside/ STM, then fires the payload-dequeued handler. +-- Because the payload queue is not exported, this is the only way out of the +-- pipe: a payload can never be delivered unpaced. Recycling is /not/ done here. +-- 'Config.Runtime' wraps this fetcher, firing the workload's dequeue wiring +-- on each pull. +payloadFetcher + :: Pipe key input payload + -> RL.RateLimiter -- ^ Paces every pull (shared limiters allowed). + -> Raw.OnExhaustion -- ^ What to do on an empty queue. + -> PayloadFetcher (key, payload) +payloadFetcher pipe rateLimiter onExhaustion = PayloadFetcher + { fetchPayload = goBlocking + , tryFetchPayload = goNonBlocking + } + where + queue = pipePayloadQueue pipe + -- Post-dequeue step (the payload has just been removed from the queue): + -- report the new payload-queue depth through the dequeue handler. + afterDequeue key = do + -- Length of the payload queue is fetched in a different STM, not in sync. + payloadDepth <- STM.atomically $ STM.lengthTBQueue queue + -- Caller event: PayloadDequeued. + pipeOnPayloadDequeued pipe key payloadDepth + --------------- + -- Blocking. -- + --------------- + goBlocking = do + now <- Clock.getTime + result <- STM.atomically $ do + ---------- STM START ---------- + RL.waitToken now rateLimiter queue + ---------- STM ENDED ---------- + case result of + Just ((key, payload), delay) -> do + -- Delays this thread only, not the (possibly shared) rate limiter. + threadDelayNanos (Clock.toNanoSecs delay) + -- Process the event and return. + afterDequeue key + pure (key, payload) + -- The queue is empty. + Nothing -> case onExhaustion of + Raw.Error -> + -- The payload queue is empty. The payload builder cannot keep up + -- with the configured TPS demand. At this stage of the library we + -- treat this as a fatal error rather than silently degrading + -- throughput. The user must either reduce TPS, increase the number + -- of initial inputs, or parallelise the builder. + throwIO $ QueueStarved + "fetchPayload: payload queue empty, cannot keep up with TPS." + Raw.Block -> do + -- Gate: park until the builder produces at least one payload. + -- + -- 'peekTBQueue' retries (parks the thread via STM retry) until the + -- queue is non-empty, then succeeds without consuming the item. + -- This is event-driven: the thread uses zero CPU while parked and + -- wakes as soon as the builder writes. + -- + -- The stale-clock concern documented in 'RL.waitToken' does not + -- apply here: 'goBlocking' captures a fresh timestamp on every + -- iteration, so the rate limiter always sees an accurate clock. + -- Fairness is likewise unaffected: the rate limiter's FIFO property + -- comes from the atomic slot claiming inside 'waitToken', not from + -- the retry mechanism. + -- + -- Trade-off: when N workers are starved on the same queue, a single + -- builder write wakes all N (GHC's STM wake-all). N-1 fail + -- 'tryReadTBQueue' inside 'waitToken' and re-park. This is bounded + -- by the number of targets per workload and is far cheaper than + -- polling ('threadDelay' would cause N wakeups per requested sleep + -- time regardless of builder activity). + _ <- STM.atomically $ STM.peekTBQueue queue + goBlocking + ------------------- + -- Non-blocking. -- + ------------------- + goNonBlocking = do + now <- Clock.getTime + result <- STM.atomically $ do + ---------- STM START ---------- + RL.tryWaitToken now rateLimiter queue + ---------- STM ENDED ---------- + case result of + -- Rate limited (ahead of schedule): no payload this round. + Left _ -> pure Nothing + -- Not rate limited and the queue was not empty. + Right (Just (key, payload)) -> do + -- Process the event and return. + afterDequeue key + pure (Just (key, payload)) + -- The queue is empty. + Right Nothing -> case onExhaustion of + Raw.Error -> + -- The payload queue is empty. The payload builder cannot keep up + -- with the configured TPS demand. At this stage of the library we + -- treat this as a fatal error rather than silently degrading + -- throughput. The user must either reduce TPS, increase the number + -- of initial inputs, or parallelise the builder. + throwIO $ QueueStarved + "tryFetchPayload: payload queue empty, cannot keep up with TPS." + Raw.Block -> pure Nothing + +-- | Safely sleep for a duration in nanoseconds. +-- +-- Converts nanoseconds to microseconds for 'threadDelay'. To prevent integer +-- overflow on 32-bit systems (where 'Int' maxes out at ~2147s), the delay is +-- clamped to 'maxBound :: Int', so even extremely low TPS (below ~0.0005) +-- sleeps for the maximum representable period rather than wrapping to a small or +-- negative value and triggering an accidental token burst. +-- Replaces: `threadDelay (fromIntegral (Clock.toNanoSecs nanos `div` 1_000))`. +threadDelayNanos :: Integer -> IO () +threadDelayNanos nanos = + let micros = nanos `div` 1_000 + clamped = fromIntegral (min (fromIntegral (maxBound :: Int)) micros) + in when (clamped > 0) $ threadDelay clamped + diff --git a/bench/tx-centrifuge/lib/pull-fiction/Cardano/Benchmarking/PullFiction/Internal/RateLimiter.hs b/bench/tx-centrifuge/lib/pull-fiction/Cardano/Benchmarking/PullFiction/Internal/RateLimiter.hs new file mode 100644 index 00000000000..2da7ac25406 --- /dev/null +++ b/bench/tx-centrifuge/lib/pull-fiction/Cardano/Benchmarking/PullFiction/Internal/RateLimiter.hs @@ -0,0 +1,187 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE NumericUnderscores #-} + +-------------------------------------------------------------------------------- + +-- | Server-side GCRA rate limiter for pull-based token dispensing. +-- +-- Computes delays but never sleeps — the caller is responsible for sleeping +-- outside the STM transaction (keeps the critical section short and the limiter +-- testable in pure STM). +-- +-- The 'TBQueue' is an explicit parameter so that queue reads and rate-limit +-- accounting are atomic while the limiter stays decoupled from any particular +-- queue. +module Cardano.Benchmarking.PullFiction.Internal.RateLimiter + ( RateLimiter, newTokenBucket, newUnlimited + , waitToken, tryWaitToken + ) where + +-------------------------------------------------------------------------------- + +--------- +-- stm -- +--------- +import Control.Concurrent.STM qualified as STM +------------------ +-- pull-fiction -- +------------------ +import Cardano.Benchmarking.PullFiction.Clock qualified as Clock + +-------------------------------------------------------------------------------- + +-- | 'TokenBucket' for a configured TPS ceiling, or 'Unlimited'. +data RateLimiter + = TokenBucket + -- | Emission interval T in nanoseconds (cached). + !Integer + -- | Start time (set on first claim). + !(STM.TVar (Maybe Clock.TimeSpec)) + -- | Tokens sent so far. + !(STM.TVar Integer) + -- | No rate limit. + | Unlimited + +-- | Create a token-bucket rate limiter targeting @tps@ tokens per second. +-- +-- Uses the Generic Cell Rate Algorithm (GCRA), also known as the virtual +-- scheduling algorithm (ITU-T I.371). Equivalent to Turner's leaky bucket as a +-- meter (Turner 1986, "New Directions in Communications", IEEE Comm. Mag. +-- 24(10)). +-- +-- The algorithm tracks a /Theoretical Arrival Time/ (TAT), the earliest time +-- the next token is allowed: +-- +-- @ +-- TAT(0) = now -- first token, no delay +-- TAT(N+1) = max(TAT(N), now) + T -- T = emission interval = 1\/rate +-- allow iff TAT <= now + τ -- τ = burst tolerance +-- @ +-- +-- With @τ = 0@ (the current implementation) no burst is allowed: each token +-- must wait until its scheduled time. Adding @τ > 0@ would permit up to @τ / T@ +-- tokens to arrive ahead of schedule (the dual token-bucket formulation with +-- bucket depth @τ / T@). +-- +-- TODO: Add a @maxBurst@ parameter to the rate limit config. The burst +-- tolerance becomes @τ = maxBurst * T@, and the admission check becomes +-- @TAT <= now + τ@. +-- +-- The start time is captured on the first token claim, so any delay between +-- limiter creation and the first request does not cause a burst of catch-up +-- tokens. +-- +-- Performance: @nanosPerToken@ (the emission interval @T@) is pre-computed +-- once at construction via @round (1e9 / tps)@. This trades a tiny rounding +-- error (at most +/-0.5 ns per token) for O(1) integer multiplication in +-- 'nextTokenTargetTime', avoiding 'Rational' division that would otherwise +-- dominate at high token counts. +newTokenBucket :: Double -> IO RateLimiter +newTokenBucket tps = do + startVar <- STM.newTVarIO Nothing + countVar <- STM.newTVarIO 0 + let !nanosPerToken = round (1_000_000_000 / tps) :: Integer + pure (TokenBucket nanosPerToken startVar countVar) + +-- | An unlimited rate limiter (never blocks on rate). +newUnlimited :: RateLimiter +newUnlimited = Unlimited + +-------------------------------------------------------------------------------- + +-- | @targetTime(N) = startTime + N * nanosPerToken@. +-- Token 0 is special-cased in 'waitToken' (delay 0). +-- O(1) integer multiply + add — no division on the hot path. +nextTokenTargetTime :: Integer -> Clock.TimeSpec -> Integer -> Clock.TimeSpec +nextTokenTargetTime nanosPerToken startTime tokensSent = + let !offset = Clock.fromNanoSecs (tokensSent * nanosPerToken) + in startTime + offset + +-------------------------------------------------------------------------------- + +-- | Try to claim the next token. Runs entirely in STM, never retries. +-- +-- @Just (token, delay)@ when a token is available; 'Nothing' when the queue is +-- empty (caller sleeps and retries). +-- +-- __Fairness__: consume + slot-claim are one STM transaction, so concurrent +-- threads see a strictly increasing @tokensSent@ counter — FIFO-fair. +-- +-- Never blocks inside STM, so the caller-captured @timeNow@ stays accurate +-- (no stale-clock TPS drift). +waitToken :: Clock.TimeSpec + -> RateLimiter + -> STM.TBQueue token + -> STM.STM (Maybe (token, Clock.TimeSpec)) +-- No TPS: try to read a token without blocking. +waitToken _ Unlimited queue = do + maybeToken <- STM.tryReadTBQueue queue + case maybeToken of + Nothing -> pure Nothing + Just token -> pure (Just (token, 0)) +-- With a TPS. +waitToken timeNow (TokenBucket nanosPerToken startTVar countTVar) queue = do + maybeToken <- STM.tryReadTBQueue queue + case maybeToken of + Nothing -> pure Nothing + Just token -> do + maybeStartTime <- STM.readTVar startTVar + case maybeStartTime of + -- Rate limiter running, claim a rate-limit slot. + Just startTime -> do + tokensSent <- STM.readTVar countTVar + STM.writeTVar countTVar (tokensSent + 1) + let !targetTime = nextTokenTargetTime + nanosPerToken startTime tokensSent + !delay = max 0 (targetTime - timeNow) + pure (Just (token, delay)) + -- First call, record start time. + Nothing -> do + STM.writeTVar startTVar (Just timeNow) + STM.writeTVar countTVar 1 + pure (Just (token, 0)) + +-- | Non-blocking variant: checks the rate limit /first/ and returns +-- @Left delay@ without touching the queue when ahead of schedule. +-- +-- @Right Nothing@: not rate-limited but queue empty. +-- @Right (Just token)@: token claimed. +tryWaitToken :: Clock.TimeSpec + -> RateLimiter + -> STM.TBQueue token + -> STM.STM (Either Clock.TimeSpec (Maybe token)) +-- No TPS. +tryWaitToken _ Unlimited queue = Right <$> STM.tryReadTBQueue queue +-- With a TPS. +tryWaitToken timeNow + (TokenBucket nanosPerToken startTVar countTVar) + queue = do + maybeStartTime <- STM.readTVar startTVar + case maybeStartTime of + -- Rate limiter running, check if ahead of schedule. + Just startTime -> do + tokensSent <- STM.readTVar countTVar + let !targetTime = nextTokenTargetTime + nanosPerToken startTime tokensSent + if targetTime > timeNow + -- Ahead of schedule. + then pure (Left (targetTime - timeNow)) + -- Available headroom. + else do + maybeToken <- STM.tryReadTBQueue queue + case maybeToken of + Nothing -> pure (Right Nothing) + Just token -> do + STM.writeTVar countTVar (tokensSent + 1) + pure (Right (Just token)) + -- First call, no rate limit to check. + Nothing -> do + maybeToken <- STM.tryReadTBQueue queue + case maybeToken of + Nothing -> pure (Right Nothing) + Just token -> do + -- Record the time only if a token was available. + STM.writeTVar startTVar (Just timeNow) + STM.writeTVar countTVar 1 + pure (Right (Just token)) diff --git a/bench/tx-centrifuge/lib/pull-fiction/Cardano/Benchmarking/PullFiction/Internal/Recycler.hs b/bench/tx-centrifuge/lib/pull-fiction/Cardano/Benchmarking/PullFiction/Internal/Recycler.hs new file mode 100644 index 00000000000..f08d8532163 --- /dev/null +++ b/bench/tx-centrifuge/lib/pull-fiction/Cardano/Benchmarking/PullFiction/Internal/Recycler.hs @@ -0,0 +1,372 @@ +{-# LANGUAGE ImportQualifiedPost #-} + +-------------------------------------------------------------------------------- + +-- | The 'Recycler': the mechanism of closed-loop input recycling, kept out of +-- the 'Pipe' so the pipe stays a plain queue pair, and kept free of any recycle +-- strategy so it stays a plain mechanism. Its /user/ ('Config.Runtime') drives +-- it through four axiomatic actions, each firing (fire-and-forget) the +-- same-named 'PayloadLifecycle' instruction onto the recycler's queue: +-- +-- * 'addToBacklog': add a payload's two input sets, the /consumed/ inputs +-- and the produced /outputs/, to the backlog. +-- * 'releaseOutputs': release the held outputs to the input queue. +-- Reason-free: the caller decides when a payload counts +-- as confirmed (at build, at dequeue, or on an observer +-- confirm), the recycler does not know. +-- * 'releaseConsumed': release the held consumed inputs to the input queue +-- instead (the payload was discarded downstream, it will +-- never confirm). +-- * 'reset': drop every queued input and queued payload, then +-- reseed the input queue with the caller's fresh inputs. +-- Optionally gated by a key (see the unknown-key +-- invariant below). +-- +-- What to call and when, per recycle strategy, is wiring that lives entirely in +-- 'Config.Runtime'. The recycle worker ('runRecycler') reads the queue on its +-- own thread, keeps the backlog (the held input sets) in its own /local/ map, +-- and is the sole writer to the pipe's input queue (which is what will later +-- let it shuffle a drained batch), so no shared or locked state is needed. +-- +-- The worker emits one observable event per action family for tracing: +-- /AddToBacklog/ each time it adds a payload's entry to the backlog +-- ('addToBacklog'), /AddToPipe/ each time a release adds recycled inputs to the +-- pipe (via 'Pipe.addInputs') and /Reset/ each time a reset drops the queued +-- inputs and payloads and reseeds the input queue. +-- +-- INVARIANT: each in-flight payload must have a unique @key@. The map is keyed +-- by @key@, so two live payloads sharing a key would clobber each other's held +-- inputs. Callers satisfy this with a per-payload identifier, Main uses the +-- txId (distinct inputs imply distinct txId, and the closed loop only reuses a +-- key after the previous payload under it was recycled). +-- +-- INVARIANT: a payload's 'addToBacklog' must be enqueued before any of its +-- releases, which the callers guarantee ('baAddPayload' holds before the +-- payload becomes dequeuable, and an observer can only see a submitted +-- payload). The worker therefore IGNORES a release for an unknown key: it is +-- foreign (the observer broadcast is unfiltered), a duplicate (a second +-- subscription), or already released. A keyed reset ('reset' with 'Just') obeys +-- the same rule: for an unknown key NO reset happens, the event is ignored. (To +-- keep these two ideas apart, comments here say the queues are /dropped/ by a +-- reset and an unknown-key event is /ignored/.) This is what lets the generator +-- share a chain with unrelated traffic without recycling, or resetting on, +-- other people's events. +module Cardano.Benchmarking.PullFiction.Internal.Recycler + ( -- * Recycler. + Recycler, mkRecycler + , runRecycler + -- * Event handlers. + , OnAddToBacklogEvent + , OnAddToPipeEvent + , OnResetEvent + -- * Actions (fire-and-forget). + , addToBacklog + , releaseOutputs + , releaseConsumed + , reset + ) where + +-------------------------------------------------------------------------------- + +---------- +-- base -- +---------- +import Control.Concurrent (myThreadId) +import GHC.Conc (labelThread) +import Numeric.Natural (Natural) +----------- +-- async -- +----------- +import Control.Concurrent.Async qualified as Async +---------------- +-- containers -- +---------------- +import Data.Map.Strict qualified as Map +--------- +-- stm -- +--------- +import Control.Concurrent.STM qualified as STM +------------------ +-- pull-fiction -- +------------------ +import Cardano.Benchmarking.PullFiction.Internal.Pipe qualified as Pipe + +-------------------------------------------------------------------------------- + +-- | A point in a payload's lifecycle, fired (fire-and-forget) onto the +-- recycler's queue by the same-named actions and interpreted by the worker. +-- Each says /what to do/, never /why/. +data PayloadLifecycle key input + = -- | Add a payload's consumed inputs and produced outputs to the backlog, + -- keyed by @key@. + AddToBacklog !key ![input] ![input] + -- | Release the held outputs of @key@ to the input queue. + | ReleaseOutputs !key + -- | Release the held consumed inputs of @key@ to the input queue. + | ReleaseConsumed !key + -- | Drop every queued input and payload, and reseed with these fresh + -- inputs. With 'Just' a key, apply only while that key is held (an unknown + -- key means no reset happens, the event is ignored). With 'Nothing', apply + -- unconditionally. + | Reset !(Maybe key) ![input] + +-- | Handler fired by the recycle worker each time it adds a payload entry to +-- the backlog ('addToBacklog'), with the payload's key, its consumed inputs, +-- its produced outputs and the resulting backlog size (e.g. for tracing). The +-- whole entry is passed: what to render is the handler's decision, not the +-- recycler's. The final 'Natural' is the backlog size after this add: the +-- number of payloads the recycler is holding, awaiting their release. It is NOT +-- a pipe queue depth. +-- Created by the caller and passed to 'mkRecycler', mirrors 'Pipe' events. +type OnAddToBacklogEvent key input = + key -> [input] -> [input] -> Natural -> IO () + +-- | Handler fired by the recycle worker each time it adds recycled inputs to +-- the pipe's input queue, with those inputs and the resulting backlog size +-- (e.g. for tracing). +-- Created by the caller and passed to 'mkRecycler', mirrors 'Pipe' events. +type OnAddToPipeEvent input = [input] -> Natural -> IO () + +-- | Handler fired by the recycle worker each time a reset drops the queued +-- inputs and payloads and reseeds the input queue, with the dropped inputs, the +-- dropped payloads (each with its key), the fresh inputs and the resulting +-- backlog size (always @0@, a reset clears the backlog) (e.g. for tracing). +-- Both dropped sets are passed in full: what to render (all of it, a count, +-- just the keys) is the handler's decision, not the recycler's. +-- Created by the caller and passed to 'mkRecycler', mirrors 'Pipe' events. +type OnResetEvent key input payload = + [input] -> [(key, payload)] -> [input] -> Natural -> IO () + +-- | Recycling state for one 'Pipe'. Construct with 'mkRecycler' only. Holds no +-- backlog map and no worker async: the map is the worker's own local state and +-- the async is returned by 'runRecycler'. +data Recycler key input payload = Recycler + { -- | The pipe whose input queue receives recycled inputs (via + -- 'Pipe.addInputs'). + recyclerPipe :: !(Pipe.Pipe key input payload) + -- | Fired by the worker when it adds a payload's entry to the backlog, + -- with the key, the consumed inputs, the produced outputs and the + -- resulting backlog size (e.g. for tracing). + , recyclerOnAddToBacklog :: !(OnAddToBacklogEvent key input) + -- | Fired by the worker with the inputs it adds to the pipe and the + -- resulting backlog size, each time it recycles (e.g. for tracing). + , recyclerOnAddToPipe :: !(OnAddToPipeEvent input) + -- | Fired by the worker with the dropped inputs, the dropped payloads, the + -- fresh inputs and the resulting backlog size, each time a reset drops the + -- queued inputs and payloads and reseeds the input queue (e.g. for + -- tracing). + , recyclerOnReset :: !(OnResetEvent key input payload) + -- | The fire-and-forget lifecycle-signal queue: the actions write, the + -- worker reads (FIFO, see the 'AddToBacklog' before release invariant + -- above). + , recyclerInbox :: !(STM.TQueue (PayloadLifecycle key input)) + } + +-------------------------------------------------------------------------------- + +-- | Build the recycler state for one pipe: just the event queue. +-- It spawns no worker: call 'runRecycler' for that. +mkRecycler + -- | Pipe to recycle into. + :: Pipe.Pipe key input payload + -- | Fired with the added entry (key, consumed inputs, produced outputs) and + -- the resulting backlog size each time a payload enters the backlog. + -> OnAddToBacklogEvent key input + -- | Fired with the inputs and backlog size each time the worker adds recycled + -- inputs to the pipe. + -> OnAddToPipeEvent input + -- | Fired with the dropped inputs, the dropped payloads, the fresh inputs and + -- the resulting backlog size each time a reset drops the queued inputs and + -- payloads and reseeds the input queue. + -> OnResetEvent key input payload + -> IO (Recycler key input payload) +mkRecycler pipe onAddToBacklog onAddToPipe onReset = do + inbox <- STM.newTQueueIO + pure Recycler + { recyclerPipe = pipe + , recyclerOnAddToBacklog = onAddToBacklog + , recyclerOnAddToPipe = onAddToPipe + , recyclerOnReset = onReset + , recyclerInbox = inbox + } + +-- | The worker's local record of one held payload: its consumed inputs and its +-- produced outputs, in that order, remembered at 'AddToBacklog' until a release +-- picks one set. +data Held input = Held ![input] ![input] + +-- | Spawn the recycle worker and return it (unlinked, so the caller links it, +-- as with the builder async). +-- +-- The worker drains the lifecycle-signal queue and acts on every event, keeping +-- the held input sets in a worker-local map (only it touches it): +-- 'AddToBacklog' holds, 'ReleaseOutputs' \/ 'ReleaseConsumed' recycle the +-- picked set and forget the key, 'Reset' drops the queued inputs and payloads +-- and reseeds the input queue with the fresh inputs it carries (gated on its +-- key being held, when keyed). A release, or a keyed reset, for an unknown key +-- is ignored (see the invariants in the module header). +-- +-- It fires 'recyclerOnAddToBacklog' when it adds a payload to the backlog, +-- 'recyclerOnAddToPipe' when a release adds inputs to the pipe (both with the +-- resulting backlog size) and 'recyclerOnReset' when a reset drops the queued +-- inputs and payloads and reseeds the input queue. It needs no observer or +-- fetcher: the events arrive through the actions. When 'Config.Runtime' wires +-- no action calls for a workload, the worker just parks on the forever-empty +-- queue. +runRecycler + :: Ord key + => Recycler key input payload + -- | Builder name (used to label the recycler thread). + -> String + -> IO (Async.Async ()) +runRecycler recycler name = Async.async $ do + tid <- myThreadId + labelThread tid (name ++ "/recycler") + let -- Backlog size (the number of held payloads) as a 'Natural'. + depthOf s = fromIntegral (Map.size s) + -- Recycle one set of a held payload and forget the key: add the set to + -- the pipe ('Pipe.addInputs' is a no-op on an empty one), then fire the + -- add-to-pipe handler. + recycle key inputs backlog = do + let backlog' = Map.delete key backlog + Pipe.addInputs (recyclerPipe recycler) inputs + -- Caller event: AddToPipe. Fired after the fact with the inputs and the + -- resulting backlog size, either way (an empty recycle is traced too). + (recyclerOnAddToPipe recycler) inputs (depthOf backlog') + pure backlog' + go backlog = do + event <- STM.atomically $ do + ---------- STM START ---------- + STM.readTQueue (recyclerInbox recycler) + ---------- STM ENDED ---------- + backlog' <- case event of + AddToBacklog key consumed outputs -> do + let backlog' = Map.insert key (Held consumed outputs) backlog + -- Caller event: AddToBacklog. The payload's entry just entered + -- the backlog, fired after the fact with the key, both input + -- sets and the resulting backlog size. + (recyclerOnAddToBacklog recycler) key consumed outputs + (depthOf backlog') + pure backlog' + -- The releases pick which held set returns to the input queue: + -- the outputs or the consumed inputs. A release for an unknown + -- key is ignored (see the module header). + ReleaseOutputs key -> + case Map.lookup key backlog of + Just (Held _consumed outputs) -> recycle key outputs backlog + Nothing -> pure backlog + ReleaseConsumed key -> + case Map.lookup key backlog of + Just (Held consumed _outputs) -> recycle key consumed backlog + Nothing -> pure backlog + -- A keyed reset applies only while its key is held: like a release, + -- an unknown key is foreign, a duplicate, or already superseded by an + -- earlier reset that cleared the backlog. An unkeyed reset always + -- applies. + Reset maybeKey fresh -> do + let applies = case maybeKey of + Nothing -> True + Just key -> Map.member key backlog + if not applies + -- Ignored: NO reset happens, nothing is dropped from the queues, + -- and the fresh inputs are discarded unused. + then pure backlog + -- Drop the queued inputs and the queued payloads built from them, + -- reseed the input queue with the fresh inputs and clear the + -- backlog (the reseed supersedes every held payload). + else do + droppedInputs <- Pipe.dropInputs (recyclerPipe recycler) + -- Queued payloads are as stale as the queued inputs: they spend + -- the lineage the reset abandons, so delivering them only feeds + -- the targets transactions that no longer apply. Deliberately a + -- separate STM transaction from the input drop above: fusing + -- the two would gain no invariant (the builder's take, build + -- and add span separate transactions anyway, so a payload built + -- from pre-reset inputs can land after any boundary) and would + -- catch less (a payload landing between the two flushes is + -- swept by this later one). A payload the builder is completing + -- right now can still slip in after this flush, which is + -- harmless (a stale payload fails downstream). + droppedPayloads <- Pipe.dropPayloads (recyclerPipe recycler) + -- 'Pipe.addInputs' is a no-op on an empty fresh set. + Pipe.addInputs (recyclerPipe recycler) fresh + -- Caller event: Reset. Fired after the fact with the dropped + -- inputs, the dropped payloads, the fresh inputs and the + -- resulting backlog size, either way (a reset clears the + -- backlog, so the size is 0). + (recyclerOnReset recycler) droppedInputs droppedPayloads fresh 0 + pure Map.empty + go backlog' + go (Map.empty :: Map.Map key (Held input)) + +-------------------------------------------------------------------------------- + +-- | Add a payload's two input sets to the recycler's backlog (fire-and-forget): +-- the consumed inputs and the produced outputs, in that order. Exactly one +-- later release ('releaseOutputs' or 'releaseConsumed') picks the set to +-- recycle. +addToBacklog + :: Recycler key input payload + -- | Key identifying the payload (e.g. its txId). + -> key + -- | Inputs consumed to build this payload. + -> [input] + -- | New inputs (outputs) produced by this payload. + -> [input] + -> IO () +addToBacklog recycler key consumedInputs outputInputs = do + send recycler (AddToBacklog key consumedInputs outputInputs) + +-- | Release the held outputs of a payload to the input queue (fire-and-forget). +-- Reason-free: 'Config.Runtime' decides when a payload counts as confirmed (at +-- build, at dequeue, or on an observer confirm), the recycler does not know. +releaseOutputs + :: Recycler key input payload + -- | Key identifying the payload (e.g. its txId). + -> key + -> IO () +releaseOutputs recycler key = do + send recycler (ReleaseOutputs key) + +-- | Release the held consumed inputs of a payload to the input queue +-- (fire-and-forget): the payload was discarded downstream (e.g. a chain +-- rollback orphaned it), it will never confirm, so its consumed inputs come +-- back instead of its outputs. +releaseConsumed + :: Recycler key input payload + -- | Key identifying the payload (e.g. its txId). + -> key + -> IO () +releaseConsumed recycler key = do + send recycler (ReleaseConsumed key) + +-- | Drop every queued input and queued payload, and reseed the input queue with +-- the given fresh inputs (fire-and-forget). The caller obtains the fresh inputs +-- however it likes (e.g. an on-chain UTxO re-query), the recycler only applies +-- them. The queued payloads go too because they were built from the inputs the +-- reset drops (see 'Pipe.dropPayloads'). +-- +-- With 'Just' a key the reset is gated: it applies only while that key is held +-- in the backlog (the caller is saying "reset because of this payload"), and +-- for an unknown key no reset happens at all, the event is ignored, following +-- the same rule as the releases (see the module header). With 'Nothing' the +-- reset always applies. Whether a meaningful key is available at the trigger is +-- the caller's wiring concern (see 'Config.Runtime'). +reset + :: Recycler key input payload + -- | 'Just' the key of the payload whose event triggered the reset (gate the + -- reset on it being held), or 'Nothing' to reset unconditionally. + -> Maybe key + -- | New inputs. + -> [input] + -> IO () +reset recycler maybeKey fresh = do + send recycler (Reset maybeKey fresh) + +-- | Enqueue one lifecycle event onto the recycler's inbox. +send :: Recycler key input payload -> PayloadLifecycle key input -> IO () +send recycler event = STM.atomically $ do + ---------- STM START ---------- + STM.writeTQueue (recyclerInbox recycler) event + ---------- STM ENDED ---------- + diff --git a/bench/tx-centrifuge/lib/pull-fiction/Cardano/Benchmarking/PullFiction/WorkloadRunner.hs b/bench/tx-centrifuge/lib/pull-fiction/Cardano/Benchmarking/PullFiction/WorkloadRunner.hs new file mode 100644 index 00000000000..e9d5decf821 --- /dev/null +++ b/bench/tx-centrifuge/lib/pull-fiction/Cardano/Benchmarking/PullFiction/WorkloadRunner.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE ImportQualifiedPost #-} + +-------------------------------------------------------------------------------- + +module Cardano.Benchmarking.PullFiction.WorkloadRunner + ( TargetWorker + , runWorkload + ) where + +-------------------------------------------------------------------------------- + +---------- +-- base -- +---------- +import Control.Concurrent (myThreadId) +import GHC.Conc (labelThread) +----------- +-- async -- +----------- +import Control.Concurrent.Async qualified as Async +---------------- +-- containers -- +---------------- +import Data.Map.Strict qualified as Map +------------------ +-- pull-fiction -- +------------------ +import Cardano.Benchmarking.PullFiction.Config.Runtime qualified as Runtime +import Cardano.Benchmarking.PullFiction.Internal.Pipe qualified as Pipe + +-------------------------------------------------------------------------------- +-- Workload runner. +-------------------------------------------------------------------------------- + +-- | A worker callback that runs inside a labeled 'Async.Async'. +-- +-- 'runWorkload' spawns a labeled async per target that calls this callback with +-- the target's pre-built fetch actions ('Runtime.targetFetcher'). The callback +-- receives: +-- +-- 1. The fully resolved 'Runtime.Target' (carries addr, port, batch size, and +-- target name for error attribution). +-- 2. @fetchPayload@: blocking fetch that claims one rate-limit slot and returns +-- one @payload@. +-- 3. @tryFetchPayload@: non-blocking variant that returns @Nothing@ when +-- rate-limited or when the queue is empty, and otherwise behaves like +-- @fetchPayload@. +-- +-- The fetch actions come from 'Runtime.targetFetcher', which 'Config.Runtime' +-- built by wrapping the pipe's fetcher through the workload's dequeue wiring: +-- the rate limit, on-exhaustion policy and dequeue confirms happen inside it. +-- This module holds no fetch, rate-limit or recycle logic, and knows nothing +-- about the pipe's queues or the recycler. The callback's only responsibilities +-- are delivering the payload and application-level bookkeeping. +-- +-- The thread is already labeled @workloadName\/targetName@ by 'runWorkload'. +-- The callback body runs for the lifetime of the generator. It should not +-- create its own async or label its own thread. 'runWorkload' handles both. +type TargetWorker key input payload + = Runtime.Target key input payload -- ^ The resolved target. + -> IO payload -- ^ Blocking fetch (rate-limited, recycles inputs). + -> IO (Maybe payload) -- ^ Non-blocking fetch (rate-limited, recycles inputs). + -> IO () -- ^ Worker body (runs inside labeled async). + +-- | Run a load-generation workload: for each target, spawn a labeled async and +-- call the worker callback inside it with the target's two fetch actions. +-- +-- Rate limiter creation, the shared\/independent decision, and the recycling +-- fetch are all handled by 'Runtime.resolve' (the fetch lives on +-- 'Runtime.targetFetcher'). This function only spawns and labels the workers. +-- +-- For each target the function: +-- +-- 1. Reads the pre-built 'Pipe.PayloadFetcher' from 'Runtime.targetFetcher'. +-- 2. Computes a thread label: @workloadName ++ \"\/\" ++ targetName@. +-- 3. Creates an 'Async.Async' that labels the thread, then runs the worker +-- callback with the two fetch actions. +-- +-- Returns the list of worker asyncs (__unlinked__). Callers decide how to +-- monitor them: 'Main.hs' links them for immediate propagation. The test +-- harness polls synchronously so Tasty's 'withResource' can cache the +-- exception. +runWorkload + :: Runtime.Workload key input payload + -> TargetWorker key input payload + -> IO [Async.Async ()] +runWorkload workload targetWorker = + mapM + (\target -> do + let fetcher = Runtime.targetFetcher target + -- Always labeled threads. + threadLabel = + Runtime.workloadName workload ++ "/" ++ Runtime.targetName target + -- Return async (unlinked, caller decides monitoring strategy). + async <- Async.async $ do + tid <- myThreadId + labelThread tid threadLabel + targetWorker target + (Pipe.fetchPayload fetcher) + (Pipe.tryFetchPayload fetcher) + pure async + ) + (Map.elems (Runtime.targets workload)) diff --git a/bench/tx-centrifuge/lib/tx-centrifuge/Cardano/Benchmarking/TxCentrifuge/Block.hs b/bench/tx-centrifuge/lib/tx-centrifuge/Cardano/Benchmarking/TxCentrifuge/Block.hs new file mode 100644 index 00000000000..05dad09af65 --- /dev/null +++ b/bench/tx-centrifuge/lib/tx-centrifuge/Cardano/Benchmarking/TxCentrifuge/Block.hs @@ -0,0 +1,150 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE LambdaCase #-} + +-------------------------------------------------------------------------------- + +-- | Translation layer between @cardano-api@ and @ouroboros-consensus@ types. +-- +-- The benchmarking tool uses @cardano-api@ types internally (@Api.TxId@, +-- @Api.Tx@) because they are era-agnostic and simple to work with. The +-- Ouroboros mini-protocols (TxSubmission2, ChainSync, BlockFetch) speak +-- @ouroboros-consensus@ types (@GenTx@, @GenTxId@, @CardanoBlock@), which are +-- era-indexed sum types with one constructor per era. This module is the +-- single translation point between the two: +-- +-- * Outbound (submitting): @Api.Tx@ → @GenTx@ via 'toGenTx'. +-- * Inbound (node replies): @GenTxId@ → @Api.TxId@ via 'fromGenTxId'. +-- * Inbound (chain-following): @CardanoBlock@ → @[Api.TxId]@ via 'extractTxIds', +-- which also reaches into @cardano-ledger@ to unwrap raw block bodies +-- (ideally @cardano-api@ would provide this, but it currently does not). +-- +-- Centralising all boundary crossings here keeps the rest of the codebase +-- unaware of the consensus type machinery. +module Cardano.Benchmarking.TxCentrifuge.Block + ( -- * Block type. + CardanoBlock + -- * A block's transaction. + , BlockTx (..) + -- * Transaction extraction. + , extractTxIds + , extractFromShelleyBlock + -- * Protocol boundary. + , toGenTx + , fromGenTxId + ) where + +-------------------------------------------------------------------------------- + +---------- +-- base -- +---------- +import Data.Foldable (toList) +import Data.Functor.Const (Const (..)) +----------------- +-- cardano-api -- +----------------- +import Cardano.Api qualified as Api +-------------------- +-- cardano-ledger -- +-------------------- +import Cardano.Ledger.Block qualified as LedgerBlock +import Cardano.Ledger.Core qualified as Core +--------------------------------- +-- ouroboros-consensus:cardano -- +--------------------------------- +import Ouroboros.Consensus.Cardano.Block qualified as Cardano +import Ouroboros.Consensus.Shelley.Eras qualified as Eras +import Ouroboros.Consensus.Shelley.Ledger qualified as Shelley +import Ouroboros.Consensus.Shelley.Ledger.Mempool qualified as Mempool +--------------------------------------------- +-- ouroboros-consensus:ouroboros-consensus -- +--------------------------------------------- +import Ouroboros.Consensus.Block qualified as Block +import Ouroboros.Consensus.Ledger.SupportsMempool qualified as SupportsMempool + +-------------------------------------------------------------------------------- +-- Block type. +-------------------------------------------------------------------------------- + +-- | The Cardano block type used throughout the benchmarking tool. +type CardanoBlock = Cardano.CardanoBlock Eras.StandardCrypto + +-------------------------------------------------------------------------------- +-- Block transactions. +-------------------------------------------------------------------------------- + +-- | A transaction observed in a block, used for both confirmed and orphaned +-- (rolled-back) transactions. +data BlockTx = BlockTx + { -- | The transaction ID. + blockTxId :: !Api.TxId + -- | Block number where this transaction was observed. + , blockTxBlockNo :: !Block.BlockNo + -- | Slot number where this transaction was observed. + , blockTxSlotNo :: !Block.SlotNo + } + deriving (Show, Eq) + +-------------------------------------------------------------------------------- +-- Transaction ID extraction. +-------------------------------------------------------------------------------- + +-- | Extract all transaction IDs from a Cardano block. +extractTxIds :: CardanoBlock -> [Api.TxId] +extractTxIds = \case + -- Byron era: skip (different tx format and not relevant for benchmarking). + Cardano.BlockByron _ -> [] + -- Shelley-based eras: extract TxIds. + Cardano.BlockShelley blk -> extractFromShelleyBlock blk + Cardano.BlockAllegra blk -> extractFromShelleyBlock blk + Cardano.BlockMary blk -> extractFromShelleyBlock blk + Cardano.BlockAlonzo blk -> extractFromShelleyBlock blk + Cardano.BlockBabbage blk -> extractFromShelleyBlock blk + Cardano.BlockConway blk -> extractFromShelleyBlock blk + Cardano.BlockDijkstra blk -> extractFromShelleyBlock blk + +-- | Extract transaction IDs from a Shelley-based block. +extractFromShelleyBlock + :: Core.EraBlockBody ledgerEra + => Shelley.ShelleyBlock proto ledgerEra + -> [Api.TxId] +extractFromShelleyBlock shelleyBlock = + case Shelley.shelleyBlockRaw shelleyBlock of + LedgerBlock.Block _ body -> + let txSeq = getConst (Core.txSeqBlockBodyL Const body) + in map toTxId (toList txSeq) + where + toTxId tx = Api.fromShelleyTxId (Core.txIdTx tx) + +-------------------------------------------------------------------------------- +-- Protocol boundary. +-------------------------------------------------------------------------------- + +-- | Convert a cardano-api transaction to the consensus 'Mempool.GenTx' type. +-- This is the single point where we cross from cardano-api types to +-- ouroboros-consensus types. +toGenTx :: Api.Tx Api.ConwayEra -> SupportsMempool.GenTx CardanoBlock +toGenTx tx = Api.toConsensusGenTx $ Api.TxInMode Api.shelleyBasedEra tx + +-- | Convert a consensus 'Mempool.GenTxId' to a cardano-api 'Api.TxId'. +-- +-- All Shelley-based eras use the same 'Mempool.ShelleyTxId' wrapper, so a +-- single 'Api.fromShelleyTxId' covers every post-Byron era. +fromGenTxId :: SupportsMempool.GenTxId CardanoBlock -> Api.TxId +fromGenTxId (Cardano.GenTxIdByron _) = + error "fromGenTxId: Byron transactions not supported" +fromGenTxId (Cardano.GenTxIdShelley (Mempool.ShelleyTxId i)) = + Api.fromShelleyTxId i +fromGenTxId (Cardano.GenTxIdAllegra (Mempool.ShelleyTxId i)) = + Api.fromShelleyTxId i +fromGenTxId (Cardano.GenTxIdMary (Mempool.ShelleyTxId i)) = + Api.fromShelleyTxId i +fromGenTxId (Cardano.GenTxIdAlonzo (Mempool.ShelleyTxId i)) = + Api.fromShelleyTxId i +fromGenTxId (Cardano.GenTxIdBabbage (Mempool.ShelleyTxId i)) = + Api.fromShelleyTxId i +fromGenTxId (Cardano.GenTxIdConway (Mempool.ShelleyTxId i)) = + Api.fromShelleyTxId i +fromGenTxId (Cardano.GenTxIdDijkstra (Mempool.ShelleyTxId i)) = + Api.fromShelleyTxId i + diff --git a/bench/tx-centrifuge/lib/tx-centrifuge/Cardano/Benchmarking/TxCentrifuge/Fund.hs b/bench/tx-centrifuge/lib/tx-centrifuge/Cardano/Benchmarking/TxCentrifuge/Fund.hs new file mode 100644 index 00000000000..9aaa9411b3a --- /dev/null +++ b/bench/tx-centrifuge/lib/tx-centrifuge/Cardano/Benchmarking/TxCentrifuge/Fund.hs @@ -0,0 +1,285 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +-------------------------------------------------------------------------------- + +module Cardano.Benchmarking.TxCentrifuge.Fund + ( -- * A fund. + Fund (..) + -- * Creating funds. + , loadFunds + , discoverFunds + , discoverFundsAtAddresses + -- * Utils. + , genesisTxIn + , deriveAddress + , readSigningKey + ) where + +-------------------------------------------------------------------------------- + +---------- +-- base -- +---------- +import Data.Bifunctor (first) +import Data.IORef qualified as IORef +import Text.Read (readMaybe) +----------- +-- aeson -- +----------- +import Data.Aeson qualified as Aeson +import Data.Aeson ((.:), (.:?)) +import Data.Aeson.Types qualified as Aeson +----------------- +-- cardano-api -- +----------------- +import Cardano.Api qualified as Api +---------------- +-- containers -- +---------------- +import Data.Map.Strict qualified as Map +---------- +-- text -- +---------- +import Data.Text qualified as T +import Data.Text.Encoding qualified as T +------------------- +-- tx-centrifuge -- +------------------- +import Cardano.Benchmarking.TxCentrifuge.NodeToClient.UTxOQuery qualified as UTxOQuery + +-------------------------------------------------------------------------------- +-- A fund. +-------------------------------------------------------------------------------- + +-- | A spendable fund: a UTxO reference, its Lovelace value, and the signing key +-- required to spend it. +data Fund = Fund + { fundTxIn :: !Api.TxIn + -- | Lovelace amount. + , fundValue :: !Integer + -- | Key to spend this UTxO. + , fundSignKey :: !(Api.SigningKey Api.PaymentKey) + } + +-------------------------------------------------------------------------------- +-- Creating funds. +-------------------------------------------------------------------------------- + +-- | Internal: JSON-parseable fund entry. Two variants: +-- +-- * 'FundEntryPayment': a regular fund with an explicit UTxO reference. +-- @{ "tx_in": "txid#ix", "value": 1000000, "signing_key": "payment.skey" }@ +-- +-- * 'FundEntryGenesis': a genesis UTxO fund identified only by its key. +-- The TxIn is derived via 'Api.genesisUTxOPseudoTxIn' (always TxIx 0). +-- @{ "signing_key": "genesis.skey", "value": 1000000 }@ +data FundEntry + = FundEntryPayment !Api.TxIn !Integer !FilePath + | FundEntryGenesis !Integer !FilePath + +instance Aeson.FromJSON FundEntry where + parseJSON = Aeson.withObject "Fund" $ \o -> do + -- Common fields. + val <- o .: "value" + keyPath <- o .: "signing_key" + -- If it has a "tx_in" field it is a 'FundEntryPayment'. + mbTxInStr <- o .:? "tx_in" + case mbTxInStr of + Just txInStr -> do + txIn <- parseTxIn txInStr + pure (FundEntryPayment txIn val keyPath) + Nothing -> do + pure (FundEntryGenesis val keyPath) + +-- | Parse @"txid#ix"@ format. Both parts are required. +parseTxIn :: T.Text -> Aeson.Parser Api.TxIn +parseTxIn text = + let (txIdHex, rest) = T.breakOn "#" text + in case T.uncons rest of + Just ('#', ds) -> + case Api.deserialiseFromRawBytesHex @Api.TxId (T.encodeUtf8 txIdHex) of + Left err -> fail $ "Invalid TxId: " ++ show err + Right txId -> case readMaybe (T.unpack ds) of + Nothing -> fail $ "Invalid TxIx: expected an integer, got " ++ show ds + Just ix -> pure $ Api.TxIn txId (Api.TxIx ix) + _ -> fail "Invalid TxIn: expected \"txid#ix\" format" + +-- | Load funds from a JSON file and return them as a list. +-- The JSON file should contain an array of fund objects, each with a +-- @"signing_key"@ field pointing to a @.skey@ file. +-- Signing keys are cached by path to avoid redundant disk reads. +-- +-- For key-only entries (no @"txIn"@), the genesis UTxO pseudo-TxIn is derived +-- from the signing key using the provided 'Api.NetworkId'. +-- +-- NOTE: the entire JSON array is decoded into memory before returning. +-- For very large fund files a streaming parser (e.g. json-stream) could yield +-- funds incrementally so the caller can start filling queues before the file +-- is fully read. +loadFunds :: Api.NetworkId -> FilePath -> IO (Either String [Fund]) +loadFunds networkId path = do + result <- Aeson.eitherDecodeFileStrict' path + case result of + Left err -> pure (Left err) + Right (entries :: [FundEntry]) -> do + keyCache <- IORef.newIORef Map.empty + eFunds <- mapM (entryToFund networkId keyCache) entries + case sequence eFunds of + Left err -> pure (Left err) + Right funds -> pure (Right funds) + +-- | Convert a JSON entry to a Fund by loading its signing key (cached). +entryToFund + :: Api.NetworkId + -> IORef.IORef (Map.Map FilePath (Api.SigningKey Api.PaymentKey)) + -> FundEntry + -> IO (Either String Fund) +entryToFund networkId cacheRef entry = do + let keyPath = entryKeyPath entry + cache <- IORef.readIORef cacheRef + case Map.lookup keyPath cache of + Just key -> pure $ Right $ mkFund key + Nothing -> do + eKey <- readSigningKey keyPath + case eKey of + Left err -> pure $ Left $ + "Failed to load signing key " + ++ keyPath ++ ": " ++ err + Right key -> do + IORef.modifyIORef' cacheRef (Map.insert keyPath key) + pure $ Right $ mkFund key + where + + entryKeyPath :: FundEntry -> FilePath + entryKeyPath (FundEntryPayment _ _ p) = p + entryKeyPath (FundEntryGenesis _ p) = p + + mkFund :: Api.SigningKey Api.PaymentKey -> Fund + mkFund key = case entry of + FundEntryPayment txIn val _ -> Fund txIn val key + FundEntryGenesis val _ -> Fund (genesisTxIn networkId key) val key + +-- | Discover starting funds on chain. For each signing key, derive the address +-- it controls, ask the local node for the UTxOs there, and return one 'Fund' +-- per UTxO, tagged with the key that owns it so the spending transaction can +-- always be signed. Mirrors 'loadFunds': 'Right' with the (possibly empty) +-- funds, or 'Left' if a key cannot be read or the query fails. +-- +-- Addresses are deduplicated first: two key files can control the same address, +-- and the node returns each UTxO once, so attributing a UTxO to more than one +-- key would build duplicate references that double spend the same output. +-- +-- Point the keys at each builder's destination address (see +-- 'destination_signing_key'): the recycling loop keeps a builder's outputs +-- there, so discovery re-picks-up exactly the funds a previous run left, making +-- restart stateless. +discoverFunds + :: Api.NetworkId + -> FilePath -- ^ NodeToClient socket path of the local node to query. + -> [FilePath] -- ^ Signing key files to discover funds under. + -> IO (Either String [Fund]) +discoverFunds networkId socketPath keyPaths = do + -- Read each key and derive the address it controls. + eKeyAddrs <- mapM readKeyAddr keyPaths + case sequence eKeyAddrs of + Left err -> pure (Left err) + Right keyAddrs0 -> do + -- Deduplicate by address so each on-chain UTxO is attributed to exactly + -- one key. Keys deriving the same address share a key hash, so any one of + -- them signs for it. + let keyAddrs = + Map.elems $ Map.fromList + [ (addr, (skey, addr)) | (skey, addr) <- keyAddrs0 ] + discoverFundsAtAddresses networkId socketPath keyAddrs + where + readKeyAddr path = do + eKey <- readSigningKey path + pure $ case eKey of + Left e -> Left $ "signing key (" ++ path ++ "): " ++ e + Right skey -> Right (skey, deriveAddress networkId skey) + +-- | Discover the funds currently at the given addresses, each paired with the +-- signing key that can spend there (both already in memory, unlike +-- 'discoverFunds', which reads keys from disk and dedupes before delegating +-- here). Queries the local node for the UTxOs at the addresses and returns +-- one 'Fund' per UTxO, tagged with its address's key so the spending +-- transaction can be signed. 'Right' with the (possibly empty) funds, or +-- 'Left' if the query fails. +-- +-- Also the recovery counterpart to 'discoverFunds': after a chain rollback +-- invalidates a builder's queued inputs, reseed from ground truth by +-- re-querying the builder's own destination address. +discoverFundsAtAddresses + :: Api.NetworkId + -- | NodeToClient socket path of the local node to query. + -> FilePath + -- | Keys paired with the address each controls. + -> [(Api.SigningKey Api.PaymentKey, Api.AddressInEra Api.ConwayEra)] + -> IO (Either String [Fund]) +discoverFundsAtAddresses networkId socketPath keyAddrs = do + eUtxos <- + UTxOQuery.queryUTxOsAtAddresses socketPath networkId (map snd keyAddrs) + pure $ case eUtxos of + Left err -> Left err + Right utxosByAddr -> Right + [ Fund { fundTxIn = txin, fundValue = val, fundSignKey = skey } + | (skey, addr) <- keyAddrs + , (txin, val) <- Map.findWithDefault [] addr utxosByAddr + ] + +-------------------------------------------------------------------------------- +-- Utils. +-------------------------------------------------------------------------------- + +-- | Derive the genesis UTxO pseudo-TxIn from a payment signing key. +-- Casts to 'Api.GenesisUTxOKey' to compute the key hash expected by +-- 'Api.genesisUTxOPseudoTxIn'. +genesisTxIn :: Api.NetworkId -> Api.SigningKey Api.PaymentKey -> Api.TxIn +genesisTxIn networkId + = Api.genesisUTxOPseudoTxIn networkId + . Api.verificationKeyHash + . Api.getVerificationKey + . castToGenesisUTxOKey + +-- | Cast a 'Api.PaymentKey' signing key to a 'Api.GenesisUTxOKey' signing key. +-- Both key types use the same underlying ed25519 representation; this cast +-- enables computing the genesis UTxO pseudo-TxIn via +-- 'Api.genesisUTxOPseudoTxIn'. +castToGenesisUTxOKey + :: Api.SigningKey Api.PaymentKey + -> Api.SigningKey Api.GenesisUTxOKey +castToGenesisUTxOKey (Api.PaymentSigningKey skey) = + Api.GenesisUTxOSigningKey skey + +-- | Derive the enterprise (no-stake) Shelley address controlled by a payment +-- signing key under the given network. +deriveAddress + :: Api.NetworkId + -> Api.SigningKey Api.PaymentKey + -> Api.AddressInEra Api.ConwayEra +deriveAddress networkId signingKey = + Api.shelleyAddressInEra + (Api.shelleyBasedEra @Api.ConwayEra) $ + Api.makeShelleyAddress networkId + (Api.PaymentCredentialByKey + (Api.verificationKeyHash + (Api.getVerificationKey signingKey))) + Api.NoStakeAddress + +-- | Read a signing key from a text envelope file. +-- Accepts both @PaymentSigningKey_ed25519@ and +-- @GenesisUTxOSigningKey_ed25519@ key types. +-- Genesis UTxO keys are cast to payment keys. +readSigningKey :: FilePath -> IO (Either String (Api.SigningKey Api.PaymentKey)) +readSigningKey fp = do + result <- Api.readFileTextEnvelopeAnyOf + [ Api.FromSomeType (Api.AsSigningKey Api.AsPaymentKey) id + , Api.FromSomeType + (Api.AsSigningKey Api.AsGenesisUTxOKey) + Api.castSigningKey + ] + (Api.File fp) + pure $ first show result diff --git a/bench/tx-centrifuge/lib/tx-centrifuge/Cardano/Benchmarking/TxCentrifuge/NodeToClient.hs b/bench/tx-centrifuge/lib/tx-centrifuge/Cardano/Benchmarking/TxCentrifuge/NodeToClient.hs new file mode 100644 index 00000000000..4d5d33c31bf --- /dev/null +++ b/bench/tx-centrifuge/lib/tx-centrifuge/Cardano/Benchmarking/TxCentrifuge/NodeToClient.hs @@ -0,0 +1,280 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE TypeApplications #-} + +-------------------------------------------------------------------------------- + +-- | NodeToClient (local socket) connection for the tx-centrifuge. +-- +-- Mirrors the interface of "Cardano.Benchmarking.TxCentrifuge.NodeToNode" but +-- connects to a local cardano-node via a Unix domain socket instead of TCP. +-- +-- == Key differences from NodeToNode +-- +-- * __Transport__: Unix domain socket ('FilePath') instead of TCP +-- ('Network.Socket.AddrInfo'). +-- +-- * __ChainSync__: Delivers full blocks (not just headers). No separate +-- BlockFetch client is needed because a single ChainSync client can both +-- follow the chain and extract transaction IDs for confirmation tracking. +-- +-- * __LocalTxSubmission__: Synchronous, push-based submission (submit one tx, +-- get accept\/reject) instead of the pull-based TxSubmission2 protocol. +-- +-- * __Additional protocols__: LocalStateQuery and LocalTxMonitor are +-- available (currently wired as idle\/null clients; callers can extend +-- 'Clients' when needed). +-- +-- * __No KeepAlive__: The NodeToClient protocol suite does not include a +-- KeepAlive mini-protocol. +module Cardano.Benchmarking.TxCentrifuge.NodeToClient + ( -- * Client bundle. + Clients (..) + , emptyClients + -- * Connection. + , connect + ) where + +-------------------------------------------------------------------------------- + +---------- +-- base -- +---------- +import Data.Proxy (Proxy (..)) +import Data.Void (Void) +---------------- +-- bytestring -- +---------------- +import Data.ByteString.Lazy qualified as BSL +---------------- +-- containers -- +---------------- +import Data.Map.Strict qualified as Map +----------------- +-- network-mux -- +----------------- +import Network.Mux qualified as Mux +----------------------- +-- cardano-diffusion -- +----------------------- +import Cardano.Network.NodeToClient qualified as NtC +----------------------------------- +-- ouroboros-consensus:diffusion -- +----------------------------------- +import Ouroboros.Consensus.Network.NodeToClient qualified as NetN2C +--------------------------------------------- +-- ouroboros-consensus:ouroboros-consensus -- +--------------------------------------------- +import Ouroboros.Consensus.Block.Abstract qualified as Block +import Ouroboros.Consensus.Node.NetworkProtocolVersion qualified as NetVer +import Ouroboros.Consensus.Node.Run () +-- Orphan instances needed for +-- RunNode / SupportedNetworkProtocolVersion Block.CardanoBlock +import Ouroboros.Consensus.Shelley.Ledger.SupportsProtocol () +--------------------------- +-- ouroboros-network:api -- +--------------------------- +import Ouroboros.Network.Magic qualified as Magic +--------------------------------- +-- ouroboros-network:framework -- +--------------------------------- +import Ouroboros.Network.Driver qualified as Driver +import Ouroboros.Network.Driver.Stateful qualified as StatefulDriver +import Ouroboros.Network.IOManager qualified as IOManager +import Ouroboros.Network.Mux qualified as NetMux +import Ouroboros.Network.Protocol.Handshake.Version qualified as Handshake +--------------------------------- +-- ouroboros-network:protocols -- +--------------------------------- +import Ouroboros.Network.Protocol.ChainSync.Client qualified as CSClient +import Ouroboros.Network.Protocol.LocalStateQuery.Type qualified as LSQ +import Ouroboros.Network.Protocol.LocalTxSubmission.Client qualified as LTxSub +------------------- +-- tx-centrifuge -- +------------------- +import Cardano.Benchmarking.TxCentrifuge.NodeToClient.TxIdSync + qualified as TxIdSync +import Cardano.Benchmarking.TxCentrifuge.NodeToClient.TxSubmission + qualified as TxSubmission +import Cardano.Benchmarking.TxCentrifuge.Block qualified as Block +import Cardano.Benchmarking.TxCentrifuge.Tracing qualified as Tracing + +-------------------------------------------------------------------------------- +-- Client bundle. +-------------------------------------------------------------------------------- + +-- | Bundle of mini-protocol clients for a NodeToClient (local) connection. +-- +-- All clients are optional ('Maybe'). When 'Nothing', a null\/idle client is +-- used that waits forever without participating in the protocol. +-- +-- This allows callers to selectively enable protocols: +-- * TxSubmission only: submitting transactions via local socket. +-- * ChainSync only: following the chain (observation \/ confirmation tracking). +data Clients = Clients + { clientChainSync :: !(Maybe TxIdSync.ChainSyncClient) + , clientTxSubmission :: !(Maybe TxSubmission.TxSubmissionClient) + } + +-- | Empty clients: all protocols disabled (null\/idle clients). +emptyClients :: Clients +emptyClients = Clients + { clientChainSync = Nothing + , clientTxSubmission = Nothing + } + +-------------------------------------------------------------------------------- +-- Connection. +-------------------------------------------------------------------------------- + +-- | Connect to a local cardano-node via NodeToClient protocols. +-- +-- Establishes a multiplexed connection over a Unix domain socket running +-- ChainSync, LocalTxSubmission, LocalStateQuery, and LocalTxMonitor clients. +-- LocalStateQuery and LocalTxMonitor are always set to null\/idle clients; +-- ChainSync and LocalTxSubmission are controlled by the 'Clients' bundle. +-- +-- Returns @Left msg@ on connection failure or unexpected termination. +-- In normal operation the connection runs indefinitely (the mux never +-- returns successfully). +connect + :: IOManager.IOManager + -> Block.CodecConfig Block.CardanoBlock + -> Magic.NetworkMagic + -> Tracing.Tracers + -- | Path to the node's local Unix domain socket. + -> FilePath + -> Clients + -> IO (Either String ()) +connect + ioManager + codecConfig + networkMagic + _tracers + socketPath + clients = do + done <- NtC.connectTo + (NtC.localSnocket ioManager) + NtC.nullNetworkConnectTracers + peerMultiplex + socketPath + case done of + Left err -> pure $ Left $ + "connection failed: " ++ show err + Right () -> pure $ Left + "connection terminated unexpectedly" + + where + + supportedVers + :: Map.Map + NetVer.NodeToClientVersion + (NetVer.BlockNodeToClientVersion Block.CardanoBlock) + supportedVers = + NetVer.supportedNodeToClientVersions (Proxy @Block.CardanoBlock) + + -- Offer all supported protocol versions so the handshake negotiates the + -- highest version both sides support. The remote node will raise a + -- `VersionMismatch` exception if it does not support any of these versions. + peerMultiplex + :: NtC.Versions + NetVer.NodeToClientVersion + NtC.NodeToClientVersionData + ( NetMux.OuroborosApplicationWithMinimalCtx + 'Mux.InitiatorMode + NtC.LocalAddress + BSL.ByteString + IO + () + Void + ) + peerMultiplex = Handshake.Versions $ Map.unions + [ Handshake.getVersions $ + NtC.versionedNodeToClientProtocols + n2cVer + ( NtC.NodeToClientVersionData + { NtC.networkMagic = networkMagic + , NtC.query = False + } + ) + -- Two codec options are available: + -- * 'NetN2C.clientCodecs': ChainSync delivers deserialized blocks + -- ('Block.CardanoBlock'). The client can inspect block contents + -- directly (e.g. extract transaction IDs) at the cost of decoding + -- every block on arrival. + -- * 'NetN2C.defaultCodecs': ChainSync delivers serialised blocks + -- ('Serialised Block.CardanoBlock'). Blocks stay as raw CBOR + -- until explicitly decoded, deferring the CPU cost but requiring + -- an extra deserialisation step before inspection. + -- + -- We use 'clientCodecs' because TxIdSync calls 'Block.extractTxIds' + -- on every block, which needs the deserialized body. + (protocolBundle (NetN2C.clientCodecs codecConfig blkN2cVer n2cVer)) + | (n2cVer, blkN2cVer) <- Map.toList supportedVers + ] + + -- | All four NodeToClient protocols are always present in the bundle. + -- Protocols without a client in 'Clients' get a null\/idle peer that waits + -- forever. + protocolBundle + :: NetN2C.ClientCodecs Block.CardanoBlock IO + -> NtC.NodeToClientProtocols + 'Mux.InitiatorMode + NtC.LocalAddress + BSL.ByteString + IO + () + Void + protocolBundle myCodecs = NtC.NodeToClientProtocols + { NtC.localChainSyncProtocol = + NetMux.InitiatorProtocolOnly + $ NetMux.MiniProtocolCb $ \_ctx channel -> + case clientChainSync clients of + Just cs -> + Driver.runPeer + mempty + (NetN2C.cChainSyncCodec myCodecs) + channel + (CSClient.chainSyncClientPeer cs) + Nothing -> + Driver.runPeer + mempty + (NetN2C.cChainSyncCodec myCodecs) + channel + NtC.chainSyncPeerNull + , NtC.localTxSubmissionProtocol = + NetMux.InitiatorProtocolOnly + $ NetMux.MiniProtocolCb $ \_ctx channel -> + case clientTxSubmission clients of + Just ltx -> + Driver.runPeer + mempty + (NetN2C.cTxSubmissionCodec myCodecs) + channel + (LTxSub.localTxSubmissionClientPeer ltx) + Nothing -> + Driver.runPeer + mempty + (NetN2C.cTxSubmissionCodec myCodecs) + channel + NtC.localTxSubmissionPeerNull + , NtC.localStateQueryProtocol = + NetMux.InitiatorProtocolOnly + $ NetMux.MiniProtocolCb $ \_ctx channel -> + StatefulDriver.runPeer + mempty + (NetN2C.cStateQueryCodec myCodecs) + channel + LSQ.StateIdle + NtC.localStateQueryPeerNull + , NtC.localTxMonitorProtocol = + NetMux.InitiatorProtocolOnly + $ NetMux.MiniProtocolCb $ \_ctx channel -> + Driver.runPeer + mempty + (NetN2C.cTxMonitorCodec myCodecs) + channel + NtC.localTxMonitorPeerNull + } + diff --git a/bench/tx-centrifuge/lib/tx-centrifuge/Cardano/Benchmarking/TxCentrifuge/NodeToClient/TxIdSync.hs b/bench/tx-centrifuge/lib/tx-centrifuge/Cardano/Benchmarking/TxCentrifuge/NodeToClient/TxIdSync.hs new file mode 100644 index 00000000000..41a037ca8cb --- /dev/null +++ b/bench/tx-centrifuge/lib/tx-centrifuge/Cardano/Benchmarking/TxCentrifuge/NodeToClient/TxIdSync.hs @@ -0,0 +1,300 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ImportQualifiedPost #-} + +-------------------------------------------------------------------------------- + +-- | Transaction confirmation tracking via local ChainSync (NodeToClient). +-- +-- This is the NodeToClient counterpart of +-- "Cardano.Benchmarking.TxCentrifuge.NodeToNode.TxIdSync". N2C ChainSync +-- delivers full deserialized blocks (not just headers), so the entire +-- pipeline collapses into a single ChainSync client and no separate +-- BlockFetch client or intermediate header queue is needed. +-- +-- @ +-- N2N: ChainSync (headers) -> header queue -> BlockFetch (blocks) -> process +-- N2C: ChainSync (blocks) ----------------------------------------> process +-- @ +-- +-- The purpose of this module is to recycle funds as soon as possible. +-- Without inspecting the nodes' mempools, we follow the chain and +-- broadcast two kinds of events: +-- +-- * @Right@: a transaction reached confirmation depth — its outputs +-- can be recycled. +-- * @Left@: a transaction was in a rolled-back block and did not +-- reappear in the winning fork — its original inputs can be +-- recycled. +-- +-- The @Left@ path recovers the main source of lost funds: in Cardano, +-- a rollback does not re-add the rolled-back block's transactions to +-- the mempool. Without this recovery, those inputs would be permanently +-- leaked from the recycling loop. +-- +-- Rolled-back transactions are not orphaned immediately. They are held +-- in limbo because the winning fork may contain some (but not all) of +-- them, possibly at different block heights. Only transactions that do +-- not reappear within 2×@confirmationDepth@ blocks are broadcast as +-- orphans. +-- +-- The @confirmationDepth@ parameter (D) controls when @Right@ events +-- fire: a block is confirmed after D blocks on top. For orphans, +-- D is applied twice: the rolled-back block's replacement must first +-- be confirmed (D blocks), then the limbo entry waits D more confirmed +-- blocks to allow the tx to reappear at a different height on the +-- winning fork. Total orphan latency: 2×D blocks. +-- +-- == Usage +-- +-- @ +-- state <- emptyState Config { confirmationDepth = 6 } +-- sub <- atomically $ dupTChan (stateBroadcast state) +-- -- Pass 'chainSyncClient state' to 'NodeToClient.connect' +-- -- Read confirmed transactions from sub via readTChan +-- @ +module Cardano.Benchmarking.TxCentrifuge.NodeToClient.TxIdSync + ( -- * Configuration + Config (..) + -- * Client type + , ChainSyncClient + -- * State + , State, emptyState + -- * Subscription. + , stateBroadcast + -- * Protocol Client + , chainSyncClient + ) where + +-------------------------------------------------------------------------------- + +---------- +-- base -- +---------- +import Data.Foldable (forM_, toList) +import Numeric.Natural (Natural) +---------------- +-- containers -- +---------------- +import Data.Sequence (Seq) +import Data.Sequence qualified as Seq +import Data.Set qualified as Set +--------------------------------------------- +-- ouroboros-consensus:ouroboros-consensus -- +--------------------------------------------- +import Ouroboros.Consensus.Block qualified as Block +--------------------------- +-- ouroboros-network:api -- +--------------------------- +import Ouroboros.Network.Block qualified as Net +--------------------------------- +-- ouroboros-network:protocols -- +--------------------------------- +import Ouroboros.Network.Protocol.ChainSync.Client qualified as CS +--------- +-- stm -- +--------- +import Control.Concurrent.STM qualified as STM +------------------- +-- tx-centrifuge -- +------------------- +import Cardano.Benchmarking.TxCentrifuge.Block qualified as Block + +-------------------------------------------------------------------------------- +-- Types. +-------------------------------------------------------------------------------- + +-- | Configuration for transaction synchronization. +data Config = Config + { -- | Number of blocks to wait before confirming. + -- 0 = immediate (no reorg protection), N = wait for N blocks on top. + confirmationDepth :: !Natural + } + +-- | N2C ChainSync delivers full deserialized blocks (not just headers). +type ChainSyncClient = + CS.ChainSyncClient + Block.CardanoBlock + (Net.Point Block.CardanoBlock) + (Net.Tip Block.CardanoBlock) + IO + () + +-------------------------------------------------------------------------------- +-- Internal State. +-------------------------------------------------------------------------------- + +-- | Shared state for the ChainSync client. +-- +-- Compared to the N2N version, there is no @stateHeaders@ queue: N2C +-- ChainSync delivers full blocks directly, so we go straight from +-- roll-forward to block processing. +data State = State + { -- | Configuration. + stateConfig :: !Config + -- | Current chain tip as reported by the node. + , stateCurrentTip :: !(STM.TVar (Net.Tip Block.CardanoBlock)) + -- | Blocks received but not yet confirmed (ordered by block number). + -- Uses @TVar (Seq …)@ instead of @TBQueue@ because rollbacks need to filter + -- out blocks children of the rollback point. + , statePendingBlocks :: !(STM.TVar (Seq Block.CardanoBlock)) + -- | Tx IDs from rolled-back blocks awaiting resolution. + -- Resolved when confirmed blocks catch up: entries whose tx ID appears in + -- a confirmed block are removed; entries whose height has been confirmed + -- past are broadcast as orphans (Left). + , stateLimbo :: !(STM.TVar (Seq Block.BlockTx)) + -- | Broadcast channel for confirmed and orphaned transactions. + -- 'Right' = confirmed (recycle output inputs). + -- 'Left' = orphaned (recycle original inputs). + -- Write-only end; subscribers obtain a read-end via + -- @STM.dupTChan . stateBroadcast@. + , stateBroadcast :: !(STM.TChan (Either Block.BlockTx Block.BlockTx)) + } + +-- | Create initial sync state. +emptyState :: Config -> IO State +emptyState config = do + currentTip <- STM.newTVarIO Net.TipGenesis + pendingBlocks <- STM.newTVarIO Seq.empty + limbo <- STM.newTVarIO Seq.empty + broadcast <- STM.newBroadcastTChanIO + pure State + { stateConfig = config + , stateCurrentTip = currentTip + , statePendingBlocks = pendingBlocks + , stateLimbo = limbo + , stateBroadcast = broadcast + } + +-------------------------------------------------------------------------------- +-- ChainSync Client. +-------------------------------------------------------------------------------- + +-- | ChainSync client that receives full blocks and tracks confirmations. +-- +-- On @MsgRollForward@: processes the block immediately (no header queue, +-- no BlockFetch because the block is already complete). +-- On @MsgRollBackward@: discards pending blocks children of the rollback point. +chainSyncClient :: State -> ChainSyncClient +chainSyncClient state = CS.ChainSyncClient $ pure clientStIdle + where + -- Request the next update from the server. + clientStIdle = CS.SendMsgRequestNext + (pure ()) -- Action when server says "await". + clientStNext -- Handler for the roll-forward / roll-backward response. + -- Handle the server's roll-forward or roll-backward response. + clientStNext = CS.ClientStNext + { -- A new block arrived. Update the tip and process in one transaction. + CS.recvMsgRollForward = \block tip -> CS.ChainSyncClient $ do + STM.atomically $ do + ---------- STM START ---------- + STM.writeTVar (stateCurrentTip state) tip + processNewBlock state block + ---------- STM ENDED ---------- + pure clientStIdle + , -- Rollback: discard pending blocks that are children of the rollback + -- point and move discarded blocks' txs IDs to limbo. + CS.recvMsgRollBackward = \rollbackPoint tip -> CS.ChainSyncClient $ do + let keepBlock blk = case rollbackPoint of + Net.BlockPoint newSlot _ -> Block.blockSlot blk <= newSlot + Net.GenesisPoint -> False + STM.atomically $ do + ---------- STM START ---------- + STM.writeTVar (stateCurrentTip state) tip + pendingBlocks <- STM.readTVar (statePendingBlocks state) + -- spanl: pendingBlocks ordered by slot (appended in chain order). + let (keep, discard) = Seq.spanl keepBlock pendingBlocks + -- Kept blocks: overrides entirely `statePendingBlocks`. + STM.writeTVar (statePendingBlocks state) keep + -- Discarded blocks: Append discarded txs IDs to `stateLimbo`. + let newLimbo = Seq.fromList + [ Block.BlockTx + { Block.blockTxId = txId + , Block.blockTxBlockNo = Block.blockNo block + , Block.blockTxSlotNo = Block.blockSlot block + } + | block <- toList discard + , txId <- Block.extractTxIds block + ] + STM.modifyTVar' (stateLimbo state) (\q -> q <> newLimbo) + ---------- STM ENDED ---------- + pure clientStIdle + } + +-------------------------------------------------------------------------------- +-- Block Processing. +-------------------------------------------------------------------------------- + +-- | Add a block to @statePendingBlocks@ and broadcast any transactions that +-- have reached the configured confirmation depth. +-- +-- Must be called inside an @atomically@ block together with the tip update +-- so that the tip write and block processing are a single atomic step. +-- +-- TODO: This is identical to 'NodeToNode.TxIdSync.processNewBlock'. Once +-- recycling of "due" transactions is added to both, extract the shared logic +-- into a common helper (e.g. in Block.hs) parameterised over the common state +-- fields. +processNewBlock :: State -> Block.CardanoBlock -> STM.STM () +processNewBlock state newBlock = do + tip <- STM.readTVar (stateCurrentTip state) + pendingBlocks <- STM.readTVar (statePendingBlocks state) + -- Appends the new block and splits the ordered `Seq` of blocks into two. + let (confirmedBlocks, remainingBlocks) = + let depth = fromIntegral + (confirmationDepth (stateConfig state)) :: Block.BlockNo + isBlockConfirmed block = case tip of + Net.TipGenesis -> False + Net.Tip _ _ tipBlockNo -> tipBlockNo >= Block.blockNo block + depth + in -- spanl: pending ordered by blockNo (appended in chain order). + Seq.spanl isBlockConfirmed (pendingBlocks <> Seq.singleton newBlock) + -- Remove confirmed blocks from state first. + STM.writeTVar (statePendingBlocks state) remainingBlocks + -- Broadcast each confirmed transaction. + forM_ confirmedBlocks $ \block -> do -- No `toList`, skips intermediate list. + forM_ (Block.extractTxIds block) $ \txId -> do + STM.writeTChan + (stateBroadcast state) + (Right Block.BlockTx + { Block.blockTxId = txId + , Block.blockTxBlockNo = Block.blockNo block + , Block.blockTxSlotNo = Block.blockSlot block + } + ) + -- Resolve limbo against confirmed blocks. + -- Tx IDs that reappear in a confirmed block are removed (the `Right` + -- broadcast above already recycles their outputs). + -- Limbo entries whose height has been confirmed past are true orphans + -- (broadcast as `Left` below). + limbo <- STM.readTVar (stateLimbo state) + let (keepLimbo, toOrphan) = + let depth = fromIntegral + (confirmationDepth (stateConfig state)) :: Block.BlockNo + lastConfirmedBlockNo = case confirmedBlocks of + _ Seq.:|> lastConfirmedBlock -> Block.blockNo lastConfirmedBlock + _ -> 0 + -- Extract confirmed txs IDs to a set, more efficient queries. + confirmedTxIdSet = + Set.fromList + [ txId + | block <- toList confirmedBlocks + , txId <- Block.extractTxIds block + ] + blockTxConfirmed e = Block.blockTxId e `Set.member` confirmedTxIdSet + -- Allow confirmationDepth extra blocks for the tx to reappear at a + -- different height on the winning fork. Forks deeper than + -- confirmationDepth already cause permanent fund loss by design. + pastConfirmed e = + lastConfirmedBlockNo >= Block.blockTxBlockNo e + depth + in + -- partition, not spanl! + -- The limbo is unordered (multiple rollbacks at different heights). + Seq.partition + (not . pastConfirmed) + -- First discard from limbo all confirmed tx IDs. + (Seq.filter (not . blockTxConfirmed) limbo) + -- Remove orphaned txs from state first. + STM.writeTVar (stateLimbo state) keepLimbo + -- Broadcast orphaned txs. + forM_ toOrphan $ \entry -> do -- No `toList`, skips intermediate list. + STM.writeTChan (stateBroadcast state) (Left entry) + diff --git a/bench/tx-centrifuge/lib/tx-centrifuge/Cardano/Benchmarking/TxCentrifuge/NodeToClient/TxSubmission.hs b/bench/tx-centrifuge/lib/tx-centrifuge/Cardano/Benchmarking/TxCentrifuge/NodeToClient/TxSubmission.hs new file mode 100644 index 00000000000..6713cca3ddb --- /dev/null +++ b/bench/tx-centrifuge/lib/tx-centrifuge/Cardano/Benchmarking/TxCentrifuge/NodeToClient/TxSubmission.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE TypeApplications #-} + +-------------------------------------------------------------------------------- + +-- | LocalTxSubmission client for NodeToClient connections. +-- +-- LocalTxSubmission is a synchronous, push-based protocol: the client submits +-- one transaction at a time and receives an immediate accept\/reject response. +-- This contrasts with the pull-based TxSubmission2 protocol used by +-- NodeToNode, where the remote node drives the conversation by requesting +-- transactions. +-- +-- The client loops forever: fetch a transaction, submit it, report the result, +-- repeat. +module Cardano.Benchmarking.TxCentrifuge.NodeToClient.TxSubmission + ( TxSubmissionClient + , SubmitResult (..) + , txSubmissionClient + ) where + +-------------------------------------------------------------------------------- + +----------------- +-- cardano-api -- +----------------- +import Cardano.Api qualified as Api +--------------------------------------------- +-- ouroboros-consensus:ouroboros-consensus -- +--------------------------------------------- +import Ouroboros.Consensus.Ledger.SupportsMempool qualified as Mempool +--------------------------------- +-- ouroboros-network:protocols -- +--------------------------------- +import Ouroboros.Network.Protocol.LocalTxSubmission.Client + ( SubmitResult (..) + ) +import Ouroboros.Network.Protocol.LocalTxSubmission.Client qualified as LTxSub +------------------- +-- tx-centrifuge -- +------------------- +import Cardano.Benchmarking.TxCentrifuge.Block qualified as Block + +-------------------------------------------------------------------------------- +-- Client type. +-------------------------------------------------------------------------------- + +-- | A LocalTxSubmission client submitting Conway-era transactions. +-- +-- The protocol is synchronous: each 'SendMsgSubmitTx' blocks until the node +-- replies with 'SubmitSuccess' or @'SubmitFail' reason@. The node validates +-- the transaction against its current ledger state and mempool before +-- replying. +type TxSubmissionClient = + LTxSub.LocalTxSubmissionClient + (Mempool.GenTx Block.CardanoBlock) + (Mempool.ApplyTxErr Block.CardanoBlock) + IO + () + +-------------------------------------------------------------------------------- +-- Client construction. +-------------------------------------------------------------------------------- + +-- | Build a 'TxSubmissionClient' that loops forever, submitting +-- transactions one at a time. +-- +-- On each iteration: +-- +-- 1. Call @blockingFetch@ to obtain the next transaction (may block). +-- 2. Submit the transaction to the local node. +-- 3. Call @onResult@ with the 'Api.TxId' and the submit result +-- ('SubmitSuccess' or @'SubmitFail' reason@ with a @show@-ed rejection). +-- 4. Repeat from (1). +txSubmissionClient + :: String + -- ^ Target name (for identification in callbacks). + -> IO (Api.Tx Api.ConwayEra) + -- ^ Blocking fetch: wait for the next transaction to submit. + -> (Api.TxId -> SubmitResult String -> IO ()) + -- ^ Callback after each submission. The rejection reason (if any) is + -- stringified via 'show' on @'Mempool.ApplyTxErr' Block.CardanoBlock@. + -> TxSubmissionClient +txSubmissionClient _targetName blockingFetch onResult = + LTxSub.LocalTxSubmissionClient nextTx + where + nextTx :: IO + ( LTxSub.LocalTxClientStIdle + (Mempool.GenTx Block.CardanoBlock) + (Mempool.ApplyTxErr Block.CardanoBlock) + IO + () + ) + nextTx = do + tx <- blockingFetch + let !genTx = Block.toGenTx tx + !txId = Api.getTxId (Api.getTxBody tx) + pure $ LTxSub.SendMsgSubmitTx genTx $ \result -> do + onResult txId (mapResult result) + nextTx + + mapResult + :: SubmitResult (Mempool.ApplyTxErr Block.CardanoBlock) + -> SubmitResult String + mapResult SubmitSuccess = SubmitSuccess + mapResult (SubmitFail err) = SubmitFail (show err) + diff --git a/bench/tx-centrifuge/lib/tx-centrifuge/Cardano/Benchmarking/TxCentrifuge/NodeToClient/UTxOQuery.hs b/bench/tx-centrifuge/lib/tx-centrifuge/Cardano/Benchmarking/TxCentrifuge/NodeToClient/UTxOQuery.hs new file mode 100644 index 00000000000..c45ff462242 --- /dev/null +++ b/bench/tx-centrifuge/lib/tx-centrifuge/Cardano/Benchmarking/TxCentrifuge/NodeToClient/UTxOQuery.hs @@ -0,0 +1,162 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-------------------------------------------------------------------------------- + +-- | One-shot on-chain UTxO discovery over the NodeToClient LocalStateQuery +-- mini-protocol. +-- +-- Given the local node's socket and a set of addresses, this asks the node for +-- the UTxOs currently sitting at those addresses. The generator uses it at +-- startup to find its live funds on chain (see @discoverFunds@ in +-- @Fund@), which makes a restart stateless: point it at the builders' +-- destination addresses and it recovers whatever the recycling loop left there. +-- +-- The query era is detected at runtime ('Api.QueryCurrentEra') rather than +-- hardcoded, so it follows the chain across the Shelley-based eras cardano-api +-- supports (Shelley through Conway today). Results are keyed by the caller's +-- own 'Api.AddressInEra' values, so it looks funds up with the very addresses +-- it passed in and never touches the era-agnostic 'Api.AddressAny' projection +-- used internally to join the node's reply back to those addresses. +module Cardano.Benchmarking.TxCentrifuge.NodeToClient.UTxOQuery + ( queryUTxOsAtAddresses + ) where + +-------------------------------------------------------------------------------- + +---------- +-- base -- +---------- +import Control.Exception (SomeException, try) +----------------- +-- cardano-api -- +----------------- +import Cardano.Api qualified as Api +import Cardano.Api.Network qualified as Net +------------------------- +-- cardano-ledger-core -- +------------------------- +import Cardano.Ledger.Coin qualified as L +---------------- +-- containers -- +---------------- +import Data.Map.Strict qualified as Map + +-------------------------------------------------------------------------------- + +-- | Ask the local node for the UTxOs sitting at the given addresses. +-- +-- Returns a map from each input address to the @(TxIn, lovelace)@ pairs found +-- there (only addresses with at least one UTxO appear). Yields 'Left' on any +-- failure: the socket is unreachable, the acquire fails, or the node reports an +-- era mismatch. +-- +-- The input addresses are 'Api.ConwayEra'-typed for the caller's convenience +-- (the on-the-wire bytes are era-agnostic across Shelley-based eras). The query +-- itself runs in whatever era the node reports. +queryUTxOsAtAddresses + :: FilePath + -- ^ NodeToClient socket path of the local node to query. + -> Api.NetworkId + -> [Api.AddressInEra Api.ConwayEra] + -> IO (Either String + (Map.Map (Api.AddressInEra Api.ConwayEra) [(Api.TxIn, Integer)]) + ) +queryUTxOsAtAddresses socketPath networkId addrs = do + let connectInfo = Api.LocalNodeConnectInfo + { Api.localConsensusModeParams = + Api.CardanoModeParams (Api.EpochSlots 21600) + , Api.localNodeNetworkId = networkId + , Api.localNodeSocketPath = Api.File socketPath + } + -- Reverse index from the era-agnostic address projection back to the + -- caller's era-typed address. The node replies with query-era addresses, + -- so we join on the projection to recover the address the caller passed. + -- Its key set is also the (deduplicated) query address set. + inputByAny = Map.fromList [ (addressInEraToAny a, a) | a <- addrs ] + -- 'Api.queryNodeLocalState' does not catch IOExceptions, so a missing or + -- dead socket would crash rather than return 'Left'. Wrap it so the caller + -- always gets a clean error to report. + result <- try (runQuery connectInfo inputByAny) + pure $ case result of + Left ex -> + Left $ + "local node connection failed (is the node running and the socket " + ++ "path correct?): " ++ show (ex :: SomeException) + Right r -> r + +-- | Detect the node's current era, then run the UTxO query in that era. +runQuery + :: Api.LocalNodeConnectInfo + -> Map.Map Api.AddressAny (Api.AddressInEra Api.ConwayEra) + -> IO (Either String + (Map.Map (Api.AddressInEra Api.ConwayEra) [(Api.TxIn, Integer)]) + ) +runQuery connectInfo inputByAny = do + eEra <- Api.runExceptT $ + Api.queryNodeLocalState connectInfo Net.VolatileTip Api.QueryCurrentEra + case eEra of + Left acqFailure -> + pure $ Left $ "QueryCurrentEra acquire failed: " ++ show acqFailure + Right (Api.AnyCardanoEra era) -> + Api.caseByronOrShelleyBasedEra + (pure $ Left + "node is in the Byron era, UTxO discovery needs a Shelley-based era" + ) + (\sbe -> queryShelleyEra connectInfo sbe inputByAny) + era + +-- | Run the @QueryUTxOByAddress@ in the given (existential) Shelley-based era +-- and reduce the result to @(TxIn, lovelace)@ pairs keyed by the caller's input +-- address. The reduction happens inside the era scope because the era cannot +-- escape the 'Api.UTxO' type. +queryShelleyEra + :: forall era + . Api.LocalNodeConnectInfo + -> Api.ShelleyBasedEra era + -> Map.Map Api.AddressAny (Api.AddressInEra Api.ConwayEra) + -> IO (Either String + (Map.Map (Api.AddressInEra Api.ConwayEra) [(Api.TxIn, Integer)]) + ) +queryShelleyEra connectInfo sbe inputByAny = do + let query :: Api.QueryInMode (Either Api.EraMismatch (Api.UTxO era)) + query = + Api.QueryInEra + (Api.QueryInShelleyBasedEra sbe + (Api.QueryUTxO (Api.QueryUTxOByAddress (Map.keysSet inputByAny))) + ) + eResult <- Api.runExceptT $ + Api.queryNodeLocalState connectInfo Net.VolatileTip query + pure $ case eResult of + Left acqFailure -> + Left $ "UTxO query acquire failed: " ++ show acqFailure + Right (Left eraMismatch) -> + Left $ "UTxO query era mismatch: " ++ show eraMismatch + Right (Right (Api.UTxO utxoMap)) -> + Right (groupByAddress inputByAny utxoMap) + +-- | Group the node's @TxIn -> TxOut@ UTxO map by the caller's input address, +-- projecting each 'Api.TxOut' to its 'Api.AddressAny' and looking that up in +-- the reverse index to recover the 'Api.ConwayEra' address the caller passed. +-- A UTxO whose address is not in the index is dropped (cannot happen for a +-- by-address query, but keeps the fold total). +groupByAddress + :: Map.Map Api.AddressAny (Api.AddressInEra Api.ConwayEra) + -> Map.Map Api.TxIn (Api.TxOut Api.CtxUTxO era) + -> Map.Map (Api.AddressInEra Api.ConwayEra) [(Api.TxIn, Integer)] +groupByAddress inputByAny = Map.foldlWithKey' step Map.empty + where + step acc txin (Api.TxOut addr val _datum _refScript) = + case Map.lookup (addressInEraToAny addr) inputByAny of + Just inAddr -> + let L.Coin amount = Api.txOutValueToLovelace val + in Map.insertWith (++) inAddr [(txin, amount)] acc + Nothing -> acc + +-- | Erase the era index of an 'Api.AddressInEra', giving the era-agnostic +-- 'Api.AddressAny'. Used internally to join the node's query-era reply back to +-- the caller's 'Api.ConwayEra' input addresses (the on-the-wire bytes match +-- across Shelley-based eras, so the projection is a stable join key). +addressInEraToAny :: Api.AddressInEra era -> Api.AddressAny +addressInEraToAny (Api.AddressInEra _ addr) = Api.toAddressAny addr diff --git a/bench/tx-centrifuge/lib/tx-centrifuge/Cardano/Benchmarking/TxCentrifuge/NodeToNode.hs b/bench/tx-centrifuge/lib/tx-centrifuge/Cardano/Benchmarking/TxCentrifuge/NodeToNode.hs new file mode 100644 index 00000000000..62ee5831172 --- /dev/null +++ b/bench/tx-centrifuge/lib/tx-centrifuge/Cardano/Benchmarking/TxCentrifuge/NodeToNode.hs @@ -0,0 +1,394 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE TypeApplications #-} + +-------------------------------------------------------------------------------- + +-- | NodeToNode (TCP) connection for the tx-centrifuge. +-- +-- Mirrors the interface of "Cardano.Benchmarking.TxCentrifuge.NodeToClient" but +-- connects to a remote cardano-node via TCP instead of a Unix domain socket. +-- +-- == Key differences from NodeToClient +-- +-- * __Transport__: TCP ('Network.Socket.AddrInfo') instead of a Unix domain +-- socket ('FilePath'). +-- +-- * __ChainSync__: Delivers headers only. A separate BlockFetch client is +-- required to retrieve full blocks for transaction ID extraction. +-- +-- * __TxSubmission2__: Pull-based submission (the node requests transaction +-- IDs and bodies) instead of the synchronous, push-based LocalTxSubmission +-- protocol. +-- +-- * __KeepAlive__: Required to prevent the remote node from dropping idle +-- connections. Not present in the NodeToClient protocol suite. +-- +-- * __Protocol inclusion__: Protocols with no client ('Nothing') are excluded +-- from the mux entirely (empty list), rather than running a null\/idle peer. +module Cardano.Benchmarking.TxCentrifuge.NodeToNode + ( -- * Client bundle. + Clients (..), emptyClients + -- * Connection. + , connect + ) where + +-------------------------------------------------------------------------------- + +---------- +-- base -- +---------- +import Data.Maybe (catMaybes) +import Data.Proxy (Proxy (..)) +import Data.Void (Void) +---------------- +-- bytestring -- +---------------- +import Data.ByteString.Lazy qualified as BSL +---------------- +-- containers -- +---------------- +import Data.Map.Strict qualified as Map +------------- +-- network -- +------------- +import Network.Socket qualified as Socket +----------------- +-- network-mux -- +----------------- +import Network.Mux qualified as Mux +----------------------- +-- cardano-diffusion -- +----------------------- +import Cardano.Network.NodeToNode qualified as NtN +----------------------------------- +-- ouroboros-consensus:diffusion -- +----------------------------------- +import Ouroboros.Consensus.Network.NodeToNode qualified as NetN2N +--------------------------------------------- +-- ouroboros-consensus:ouroboros-consensus -- +--------------------------------------------- +import Ouroboros.Consensus.Block.Abstract qualified as Block +import Ouroboros.Consensus.Node.NetworkProtocolVersion qualified as NetVer +import Ouroboros.Consensus.Node.Run () +-- Orphan instances needed for +-- RunNode / SupportedNetworkProtocolVersion Block.CardanoBlock +import Ouroboros.Consensus.Shelley.Ledger.SupportsProtocol () +--------------------------- +-- ouroboros-network:api -- +--------------------------- +import Ouroboros.Network.Magic qualified as Magic +import Ouroboros.Network.PeerSelection.PeerSharing qualified as PeerSharing +import Ouroboros.Network.PeerSelection.PeerSharing.Codec qualified as PSCodec +--------------------------------- +-- ouroboros-network:framework -- +--------------------------------- +import Ouroboros.Network.Context qualified as NetCtx +import Ouroboros.Network.Driver qualified as Driver +import Ouroboros.Network.IOManager qualified as IOManager +import Ouroboros.Network.Mux qualified as NetMux +import Ouroboros.Network.Protocol.Handshake.Version qualified as Handshake +import Ouroboros.Network.Snocket qualified as Snocket +--------------------------------- +-- ouroboros-network:protocols -- +--------------------------------- +import Ouroboros.Network.Protocol.BlockFetch.Client qualified as BFClient +import Ouroboros.Network.Protocol.ChainSync.Client qualified as CSClient +import Ouroboros.Network.Protocol.KeepAlive.Client qualified as KAClient +import Ouroboros.Network.Protocol.KeepAlive.Codec qualified as KACodec +import Ouroboros.Network.Protocol.TxSubmission2.Client qualified as TxSub +--------------- +-- serialise -- +--------------- +import Codec.Serialise qualified as Serialise +------------------- +-- tx-centrifuge -- +------------------- +import Cardano.Benchmarking.TxCentrifuge.NodeToNode.KeepAlive + qualified as KeepAlive +import Cardano.Benchmarking.TxCentrifuge.NodeToNode.TxIdSync + qualified as TxIdSync +import Cardano.Benchmarking.TxCentrifuge.NodeToNode.TxSubmission + qualified as TxSubmission +import Cardano.Benchmarking.TxCentrifuge.Block qualified as Block +import Cardano.Benchmarking.TxCentrifuge.Tracing qualified as Tracing + +-------------------------------------------------------------------------------- +-- Client bundle. +-------------------------------------------------------------------------------- + +-- | Bundle of mini-protocol clients for a NodeToNode connection. +-- +-- All clients are optional ('Maybe'). When 'Nothing', the protocol is not +-- included in the connection at all, the mux simply doesn't run that +-- mini-protocol. This is the proper way to disable protocols per the +-- ouroboros-network design (using @[]@ / 'mempty' in the protocol bundle). +-- +-- This allows callers to selectively enable protocols: +-- +-- * TxSubmission only: for submitting transactions without chain following. +-- * ChainSync + BlockFetch: for tracking transaction confirmations. +-- * All: for full closed-loop operation with confirmation-based recycling. +data Clients = Clients + { clientBlockFetch :: !(Maybe TxIdSync.BlockFetchClient) + , clientChainSync :: !(Maybe TxIdSync.ChainSyncClient) + , clientKeepAlive :: !(Maybe KeepAlive.KeepAliveClient) + , clientTxSubmission :: !(Maybe TxSubmission.TxSubmissionClient) + } + +-- | Empty clients: all protocols disabled (null/idle clients). +emptyClients :: Clients +emptyClients = Clients + { clientBlockFetch = Nothing + , clientChainSync = Nothing + , clientKeepAlive = Nothing + , clientTxSubmission = Nothing + } + +-------------------------------------------------------------------------------- +-- Mini-protocol builders. +-------------------------------------------------------------------------------- + +-- | Protocol limits matching cardano-diffusion defaults. +-- See Cardano.Network.NodeToNode.defaultMiniProtocolParameters. + +blockFetchLimits :: NetMux.MiniProtocolLimits +blockFetchLimits = NetMux.MiniProtocolLimits + { NetMux.maximumIngressQueue = 20_000_000 } + +chainSyncLimits :: NetMux.MiniProtocolLimits +chainSyncLimits = NetMux.MiniProtocolLimits + { NetMux.maximumIngressQueue = 300_000 } + +keepAliveLimits :: NetMux.MiniProtocolLimits +keepAliveLimits = NetMux.MiniProtocolLimits + { NetMux.maximumIngressQueue = 1_500 } + +txSubmissionLimits :: NetMux.MiniProtocolLimits +txSubmissionLimits = NetMux.MiniProtocolLimits + { NetMux.maximumIngressQueue = 10_000_000 } + +-- | Build a BlockFetch mini-protocol. +mkBlockFetchMiniProtocol + :: NetN2N.Codecs Block.CardanoBlock NtN.RemoteAddress + Serialise.DeserialiseFailure IO + BSL.ByteString BSL.ByteString BSL.ByteString BSL.ByteString + BSL.ByteString BSL.ByteString BSL.ByteString + -> TxIdSync.BlockFetchClient + -> NetMux.MiniProtocol + 'Mux.InitiatorMode + (NetCtx.MinimalInitiatorContext NtN.RemoteAddress) + (NetCtx.ResponderContext NtN.RemoteAddress) + BSL.ByteString IO () Void +mkBlockFetchMiniProtocol codecs client = NetMux.MiniProtocol + { NetMux.miniProtocolNum = NetMux.MiniProtocolNum 3 + , NetMux.miniProtocolStart = Mux.StartOnDemand + , NetMux.miniProtocolLimits = blockFetchLimits + , NetMux.miniProtocolRun = NetMux.InitiatorProtocolOnly + $ NetMux.MiniProtocolCb $ \_ctx channel -> + Driver.runPeer mempty (NetN2N.cBlockFetchCodec codecs) channel + (BFClient.blockFetchClientPeer client) + } + +-- | Build a ChainSync mini-protocol. +mkChainSyncMiniProtocol + :: NetN2N.Codecs Block.CardanoBlock NtN.RemoteAddress + Serialise.DeserialiseFailure IO + BSL.ByteString BSL.ByteString BSL.ByteString BSL.ByteString + BSL.ByteString BSL.ByteString BSL.ByteString + -> TxIdSync.ChainSyncClient + -> NetMux.MiniProtocol + 'Mux.InitiatorMode + (NetCtx.MinimalInitiatorContext NtN.RemoteAddress) + (NetCtx.ResponderContext NtN.RemoteAddress) + BSL.ByteString IO () Void +mkChainSyncMiniProtocol codecs client = NetMux.MiniProtocol + { NetMux.miniProtocolNum = NetMux.MiniProtocolNum 2 + , NetMux.miniProtocolStart = Mux.StartOnDemand + , NetMux.miniProtocolLimits = chainSyncLimits + , NetMux.miniProtocolRun = NetMux.InitiatorProtocolOnly + $ NetMux.MiniProtocolCb $ \_ctx channel -> + Driver.runPeer mempty (NetN2N.cChainSyncCodec codecs) channel + (CSClient.chainSyncClientPeer client) + } + +-- | Build a KeepAlive mini-protocol. +mkKeepAliveMiniProtocol + :: NetN2N.Codecs Block.CardanoBlock NtN.RemoteAddress + Serialise.DeserialiseFailure IO + BSL.ByteString BSL.ByteString BSL.ByteString BSL.ByteString + BSL.ByteString BSL.ByteString BSL.ByteString + -> Tracing.Tracers + -> KeepAlive.KeepAliveClient + -> NetMux.MiniProtocol + 'Mux.InitiatorMode + (NetCtx.MinimalInitiatorContext NtN.RemoteAddress) + (NetCtx.ResponderContext NtN.RemoteAddress) + BSL.ByteString IO () Void +mkKeepAliveMiniProtocol codecs tracers client = NetMux.MiniProtocol + { NetMux.miniProtocolNum = NetMux.MiniProtocolNum 8 + , NetMux.miniProtocolStart = Mux.StartOnDemandAny + , NetMux.miniProtocolLimits = keepAliveLimits + , NetMux.miniProtocolRun = NetMux.InitiatorProtocolOnly + $ NetMux.MiniProtocolCb $ \_ctx channel -> + Driver.runPeerWithLimits + (Tracing.trKeepAlive tracers) + (NetN2N.cKeepAliveCodec codecs) + (KACodec.byteLimitsKeepAlive (const 0)) + KACodec.timeLimitsKeepAlive + channel + $ KAClient.keepAliveClientPeer client + } + +-- | Build a TxSubmission mini-protocol. +mkTxSubmissionMiniProtocol + :: NetN2N.Codecs Block.CardanoBlock NtN.RemoteAddress + Serialise.DeserialiseFailure IO + BSL.ByteString BSL.ByteString BSL.ByteString BSL.ByteString + BSL.ByteString BSL.ByteString BSL.ByteString + -> Tracing.Tracers + -> TxSubmission.TxSubmissionClient + -> NetMux.MiniProtocol + 'Mux.InitiatorMode + (NetCtx.MinimalInitiatorContext NtN.RemoteAddress) + (NetCtx.ResponderContext NtN.RemoteAddress) + BSL.ByteString IO () Void +mkTxSubmissionMiniProtocol codecs tracers client = NetMux.MiniProtocol + { NetMux.miniProtocolNum = NetMux.MiniProtocolNum 4 + , NetMux.miniProtocolStart = Mux.StartOnDemand + , NetMux.miniProtocolLimits = txSubmissionLimits + , NetMux.miniProtocolRun = NetMux.InitiatorProtocolOnly + $ NetMux.MiniProtocolCb $ \_ctx channel -> + Driver.runPeer (Tracing.trTxSubmission2 tracers) + (NetN2N.cTxSubmission2Codec codecs) channel + (TxSub.txSubmissionClientPeer client) + } + +-------------------------------------------------------------------------------- + +-- | Connect to a remote cardano-node via NodeToNode protocols. +-- +-- Establishes a multiplexed connection running ChainSync, BlockFetch, +-- TxSubmission2 and KeepAlive clients. +-- +-- Protocols with no client ('Nothing') in 'Clients' are excluded from the mux +-- entirely (empty list in the protocol bundle). +-- +-- Returns @Left msg@ on handshake failure or unexpected connection termination. +-- The @Right@ case is unreachable (the mux never returns successfully). +connect + :: IOManager.IOManager + -> Block.CodecConfig Block.CardanoBlock + -> Magic.NetworkMagic + -> Tracing.Tracers + -> Socket.AddrInfo + -> Clients + -> IO (Either String ()) +connect + ioManager + codecConfig + networkMagic + tracers + remoteAddr + clients = do + done <- NtN.connectTo (Snocket.socketSnocket ioManager) + NtN.NetworkConnectTracers + { NtN.nctMuxTracers = Mux.nullTracers + , NtN.nctHandshakeTracer = mempty + } + peerMultiplex + Nothing + (Socket.addrAddress remoteAddr) + case done of + Left err -> pure $ Left $ + "handshake failed: " ++ show err + Right choice -> case choice of + Left () -> pure $ Left + "connection terminated unexpectedly" + Right {} -> error "connect: unreachable (Void)" + + where + + supportedVers + :: Map.Map + NetVer.NodeToNodeVersion + (NetVer.BlockNodeToNodeVersion Block.CardanoBlock) + supportedVers = + NetVer.supportedNodeToNodeVersions (Proxy @Block.CardanoBlock) + + -- Offer all supported protocol versions so the handshake negotiates the + -- highest version both sides support. The remote node will raise a + -- `VersionMismatch` exception if it does not support any of these versions. + peerMultiplex + :: NtN.Versions + NetVer.NodeToNodeVersion + NtN.NodeToNodeVersionData + ( NetMux.OuroborosApplication + 'Mux.InitiatorMode + (NetCtx.MinimalInitiatorContext NtN.RemoteAddress) + (NetCtx.ResponderContext NtN.RemoteAddress) + BSL.ByteString + IO + () + Void + ) + peerMultiplex = Handshake.Versions $ Map.unions + [ Handshake.getVersions $ + Handshake.simpleSingletonVersions + n2nVer + ( NtN.NodeToNodeVersionData + { NtN.networkMagic = networkMagic + , NtN.diffusionMode = NtN.InitiatorOnlyDiffusionMode + , NtN.peerSharing = PeerSharing.PeerSharingDisabled + , NtN.query = False + } + ) + $ \_n2nData -> bundleToApp + (protocolBundle + (NetN2N.defaultCodecs + codecConfig blkN2nVer + PSCodec.encodeRemoteAddress + PSCodec.decodeRemoteAddress + n2nVer + ) + ) + | (n2nVer, blkN2nVer) <- Map.toList supportedVers + ] + + -- | Build the protocol bundle with conditional protocol inclusion. + -- Protocols with 'Nothing' clients are excluded (empty list). + protocolBundle + :: NetN2N.Codecs Block.CardanoBlock NtN.RemoteAddress + Serialise.DeserialiseFailure IO + BSL.ByteString BSL.ByteString BSL.ByteString BSL.ByteString + BSL.ByteString BSL.ByteString BSL.ByteString + -> NetMux.OuroborosBundle + 'Mux.InitiatorMode + (NetCtx.MinimalInitiatorContext NtN.RemoteAddress) + (NetCtx.ResponderContext NtN.RemoteAddress) + BSL.ByteString + IO + () + Void + protocolBundle myCodecs = NetMux.TemperatureBundle + -- Hot protocols: ChainSync, BlockFetch, TxSubmission (conditional). + (NetMux.WithHot $ catMaybes + [ mkChainSyncMiniProtocol myCodecs <$> clientChainSync clients + , mkBlockFetchMiniProtocol myCodecs <$> clientBlockFetch clients + , mkTxSubmissionMiniProtocol myCodecs tracers <$> clientTxSubmission clients + ]) + -- Warm protocols: none. + (NetMux.WithWarm []) + -- Established protocols: KeepAlive (conditional). + (NetMux.WithEstablished $ catMaybes + [ mkKeepAliveMiniProtocol myCodecs tracers <$> clientKeepAlive clients + ]) + + -- | Convert bundle to application by folding all protocols. + bundleToApp :: NetMux.OuroborosBundle mode initiatorCtx responderCtx bs m a b + -> NetMux.OuroborosApplication mode initiatorCtx responderCtx bs m a b + bundleToApp (NetMux.TemperatureBundle (NetMux.WithHot h) (NetMux.WithWarm w) (NetMux.WithEstablished e)) = + NetMux.OuroborosApplication (h <> w <> e) + diff --git a/bench/tx-centrifuge/lib/tx-centrifuge/Cardano/Benchmarking/TxCentrifuge/NodeToNode/KeepAlive.hs b/bench/tx-centrifuge/lib/tx-centrifuge/Cardano/Benchmarking/TxCentrifuge/NodeToNode/KeepAlive.hs new file mode 100644 index 00000000000..1185428c19b --- /dev/null +++ b/bench/tx-centrifuge/lib/tx-centrifuge/Cardano/Benchmarking/TxCentrifuge/NodeToNode/KeepAlive.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE ImportQualifiedPost #-} + +-------------------------------------------------------------------------------- + +-- TODO TODO TODO: Add support for latency metrics, very useful for benchmarks. + +-- | KeepAlive client for maintaining connection liveness. +-- +-- This module provides a KeepAlive protocol client that sends periodic +-- keepalive messages to prevent idle connection timeouts. +-- +-- == Usage +-- @ +-- client <- mkClient 10 -- 10 seconds between keepalives +-- -- Use client with NodeToNode.connect +-- @ +module Cardano.Benchmarking.TxCentrifuge.NodeToNode.KeepAlive + ( KeepAliveClient + , keepAliveClient + ) where + +-------------------------------------------------------------------------------- + +---------- +-- base -- +---------- +import Data.Proxy (Proxy (..)) +---------------- +-- containers -- +---------------- +import Data.Map.Strict qualified as Map +---------- +-- time -- +---------- +import Data.Time.Clock (DiffTime) +--------------------------- +-- ouroboros-network:api -- +--------------------------- +import Ouroboros.Network.ControlMessage qualified as ControlMsg +----------------------------------------- +-- ouroboros-network:ouroboros-network -- +----------------------------------------- +import Ouroboros.Network.KeepAlive qualified as KeepAlive +--------------------------------- +-- ouroboros-network:protocols -- +--------------------------------- +import Ouroboros.Network.Protocol.KeepAlive.Client qualified as KAClient +------------ +-- random -- +------------ +import System.Random qualified as Random +--------- +-- stm -- +--------- +import Control.Concurrent.Class.MonadSTM.Strict qualified as StrictSTM + +-------------------------------------------------------------------------------- + +-- | KeepAlive client for maintaining connection liveness. +type KeepAliveClient = KAClient.KeepAliveClient IO () + +-- | Create a KeepAlive client that sends periodic keepalive messages. +-- +-- The client runs indefinitely, sending keepalive cookies at the specified +-- interval (in seconds). This keeps the connection alive and allows the remote +-- peer to detect connection failures. +-- +-- Note: This client does not track peer GSV (latency) metrics. For advanced +-- use cases requiring GSV tracking, construct the client directly using +-- 'Ouroboros.Network.KeepAlive.keepAliveClient' with appropriate parameters. +keepAliveClient + -- | Interval between keepalive messages (in seconds). + :: DiffTime + -> IO KeepAliveClient +keepAliveClient interval = do + rng <- Random.newStdGen + dummyGSVMap <- StrictSTM.newTVarIO Map.empty + pure $ KeepAlive.keepAliveClient + mempty -- tracer (no tracing in default client) + rng + (ControlMsg.continueForever (Proxy :: Proxy IO)) + () -- dummy peer address (GSV tracking not used) + dummyGSVMap + (KeepAlive.KeepAliveInterval interval) diff --git a/bench/tx-centrifuge/lib/tx-centrifuge/Cardano/Benchmarking/TxCentrifuge/NodeToNode/TxIdSync.hs b/bench/tx-centrifuge/lib/tx-centrifuge/Cardano/Benchmarking/TxCentrifuge/NodeToNode/TxIdSync.hs new file mode 100644 index 00000000000..98bc205e54e --- /dev/null +++ b/bench/tx-centrifuge/lib/tx-centrifuge/Cardano/Benchmarking/TxCentrifuge/NodeToNode/TxIdSync.hs @@ -0,0 +1,442 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ImportQualifiedPost #-} + +-------------------------------------------------------------------------------- + +-- | Transaction confirmation tracking via ChainSync and BlockFetch +-- (NodeToNode). +-- +-- This is the NodeToNode counterpart of +-- "Cardano.Benchmarking.TxCentrifuge.NodeToClient.TxIdSync". N2N ChainSync +-- delivers only headers, so a separate BlockFetch client is needed to +-- retrieve full block bodies. The two clients share state via +-- @stateHeaders@. +-- +-- @ +-- N2N: ChainSync (headers) -> header queue -> BlockFetch (blocks) -> process +-- N2C: ChainSync (blocks) ----------------------------------------> process +-- @ +-- +-- The purpose of this module is to recycle funds as soon as possible. +-- Without inspecting the nodes' mempools, we follow the chain and +-- broadcast two kinds of events: +-- +-- * @Right@: a transaction reached confirmation depth — its outputs +-- can be recycled. +-- * @Left@: a transaction was in a rolled-back block and did not +-- reappear in the winning fork — its original inputs can be +-- recycled. +-- +-- The @Left@ path recovers the main source of lost funds: in Cardano, +-- a rollback does not re-add the rolled-back block's transactions to +-- the mempool. Without this recovery, those inputs would be permanently +-- leaked from the recycling loop. +-- +-- Rolled-back transactions are not orphaned immediately. They are held +-- in limbo because the winning fork may contain some (but not all) of +-- them, possibly at different block heights. Only transactions that do +-- not reappear within 2×@confirmationDepth@ blocks are broadcast as +-- orphans. +-- +-- The @confirmationDepth@ parameter (D) controls when @Right@ events +-- fire: a block is confirmed after D blocks on top. For orphans, +-- D is applied twice: the rolled-back block's replacement must first +-- be confirmed (D blocks), then the limbo entry waits D more confirmed +-- blocks to allow the tx to reappear at a different height on the +-- winning fork. Total orphan latency: 2×D blocks. +-- +-- == Header Queue (@stateHeaders@) +-- +-- The header queue is written to by ChainSync and read by BlockFetch. +-- Both protocols can remove headers from it: +-- * __ChainSync__ filters out headers children of the rollback point on +-- @MsgRollBackward@. +-- * __BlockFetch__ claims the head on @MsgBlock@ (block received) or filters +-- it out on @MsgNoBlocks@ (block no longer available on the node). +-- +-- == Usage +-- +-- @ +-- state <- emptyState Config { confirmationDepth = 6 } +-- sub <- atomically $ dupTChan (stateBroadcast state) +-- N2N.connect ioManager codecConfig networkMagic tracers addrInfo +-- N2N.emptyClients +-- { N2N.clientChainSync = Just $ chainSyncClient state +-- , N2N.clientBlockFetch = Just $ blockFetchClient state +-- } +-- confirmed <- atomically $ readTChan sub +-- @ +module Cardano.Benchmarking.TxCentrifuge.NodeToNode.TxIdSync + ( -- * Configuration + Config (..) + -- * Client types + , BlockFetchClient + , ChainSyncClient + -- * State + , State, emptyState + -- * Subscription. + , stateBroadcast + -- * Protocol Clients + , chainSyncClient + , blockFetchClient + ) where + +-------------------------------------------------------------------------------- + +---------- +-- base -- +---------- +import Data.Foldable (forM_, toList) +import Numeric.Natural (Natural) +---------------- +-- containers -- +---------------- +import Data.Sequence (Seq) +import Data.Sequence qualified as Seq +import Data.Set qualified as Set +--------------------------------------------- +-- ouroboros-consensus:ouroboros-consensus -- +--------------------------------------------- +import Ouroboros.Consensus.Block qualified as Block +--------------------------- +-- ouroboros-network:api -- +--------------------------- +import Ouroboros.Network.Block qualified as Net +--------------------------------- +-- ouroboros-network:protocols -- +--------------------------------- +import Ouroboros.Network.Protocol.BlockFetch.Client qualified as BF +import Ouroboros.Network.Protocol.BlockFetch.Type qualified as BFType +import Ouroboros.Network.Protocol.ChainSync.Client qualified as CS +--------- +-- stm -- +--------- +import Control.Concurrent.STM qualified as STM +------------------- +-- tx-centrifuge -- +------------------- +import Cardano.Benchmarking.TxCentrifuge.Block qualified as Block + +-------------------------------------------------------------------------------- +-- Types. +-------------------------------------------------------------------------------- + +-- | Configuration for transaction synchronization. +data Config = Config + { -- | Number of blocks to wait before confirming. + -- 0 = immediate (no reorg protection), N = wait for N blocks on top. + confirmationDepth :: !Natural + } + +-- | BlockFetch client for retrieving full block bodies. +type BlockFetchClient = + BF.BlockFetchClient + Block.CardanoBlock + (Net.Point Block.CardanoBlock) + IO + () + +-- | ChainSync client for following the chain tip (receives headers). +type ChainSyncClient = + CS.ChainSyncClient + (Block.Header Block.CardanoBlock) + (Net.Point Block.CardanoBlock) + (Net.Tip Block.CardanoBlock) + IO + () + +-------------------------------------------------------------------------------- +-- Internal State. +-------------------------------------------------------------------------------- + +-- | Shared state between ChainSync and BlockFetch clients. +data State = State + { -- | Configuration. + stateConfig :: !Config + -- | Current chain tip as reported by the node. + , stateCurrentTip :: !(STM.TVar (Net.Tip Block.CardanoBlock)) + -- | Headers received from ChainSync, waiting for BlockFetch. + -- Removed by both ChainSync (rollback filter) and BlockFetch (claim on + -- block received, filter on block unavailable). + -- Uses @TVar (Seq …)@ instead of @TBQueue@ because both removal patterns + -- need filtered access, which TBQueue does not support. + , stateHeaders :: !(STM.TVar (Seq (Block.Header Block.CardanoBlock))) + -- | Blocks fetched but not yet confirmed (ordered by block number). + -- Uses @TVar (Seq …)@ instead of @TBQueue@ because both removal patterns + -- need filtered access, which TBQueue does not support. + , statePendingBlocks :: !(STM.TVar (Seq Block.CardanoBlock)) + -- | Tx IDs from rolled-back blocks awaiting resolution. + -- Resolved when confirmed blocks catch up: entries whose tx ID appears in + -- a confirmed block are removed; entries whose height has been confirmed + -- past are broadcast as orphans (Left). + , stateLimbo :: !(STM.TVar (Seq Block.BlockTx)) + -- | Broadcast channel for confirmed and orphaned transactions. + -- 'Right' = confirmed (recycle output inputs). + -- 'Left' = orphaned (recycle original inputs). + -- Write-only end; subscribers obtain a read-end via + -- @STM.dupTChan . stateBroadcast@. + , stateBroadcast :: !(STM.TChan (Either Block.BlockTx Block.BlockTx)) + } + +-- | Create initial sync state. +emptyState :: Config -> IO State +emptyState config = do + currentTip <- STM.newTVarIO Net.TipGenesis + headerQueue <- STM.newTVarIO Seq.empty + pendingBlocks <- STM.newTVarIO Seq.empty + limbo <- STM.newTVarIO Seq.empty + broadcast <- STM.newBroadcastTChanIO + pure State + { stateConfig = config + , stateCurrentTip = currentTip + , stateHeaders = headerQueue + , statePendingBlocks = pendingBlocks + , stateLimbo = limbo + , stateBroadcast = broadcast + } + +-------------------------------------------------------------------------------- +-- ChainSync Client. +-------------------------------------------------------------------------------- + +-- | ChainSync client that follows the chain and adds headers to a queue. +-- +-- On @MsgRollForward@: queues the header for BlockFetch. +-- On @MsgRollBackward@: discards pending blocks children of the rollback point. +chainSyncClient :: State -> ChainSyncClient +chainSyncClient state = CS.ChainSyncClient $ pure clientStIdle + where + -- Request the next update from the server. + clientStIdle = CS.SendMsgRequestNext + (pure ()) -- Action when server says "await". + clientStNext -- Handler for the roll-forward / roll-backward response. + -- Handle the server's roll-forward or roll-backward response. + clientStNext = CS.ClientStNext + { -- Advance the tip and queue the new header for BlockFetch to use. + CS.recvMsgRollForward = \header tip -> CS.ChainSyncClient $ do + STM.atomically $ do + ---------- STM START ---------- + STM.writeTVar (stateCurrentTip state) tip + -- Function `blockFetchClient` below blocks on `readTVar`. + STM.modifyTVar' (stateHeaders state) + -- Append the new header at the end! + (\q -> q <> Seq.singleton header) + ---------- STM ENDED ---------- + -- Continue following the chain. + pure clientStIdle + , -- Rollback: discard pending blocks that are children of the rollback + -- point and move discarded blocks' txs IDs to limbo. + CS.recvMsgRollBackward = \rollbackPoint tip -> CS.ChainSyncClient $ do + let keepHeader header = case rollbackPoint of + Net.BlockPoint newSlot _ -> Block.blockSlot header <= newSlot + Net.GenesisPoint -> False + keepBlock block = case rollbackPoint of + Net.BlockPoint newSlot _ -> Block.blockSlot block <= newSlot + Net.GenesisPoint -> False + STM.atomically $ do + ---------- STM START ---------- + STM.writeTVar (stateCurrentTip state) tip + STM.modifyTVar' (stateHeaders state) (Seq.filter keepHeader) + pendingBlocks <- STM.readTVar (statePendingBlocks state) + -- spanl: pendingBlocks ordered by slot (appended in chain order). + let (keep, discard) = Seq.spanl keepBlock pendingBlocks + -- Kept blocks: overrides entirely `statePendingBlocks`. + STM.writeTVar (statePendingBlocks state) keep + -- Discarded blocks: Append discarded txs IDs to `stateLimbo`. + let newLimbo = Seq.fromList + [ Block.BlockTx + { Block.blockTxId = txId + , Block.blockTxBlockNo = Block.blockNo block + , Block.blockTxSlotNo = Block.blockSlot block + } + | block <- toList discard + , txId <- Block.extractTxIds block + ] + STM.modifyTVar' (stateLimbo state) (\q -> q <> newLimbo) + ---------- STM ENDED ---------- + pure clientStIdle + } + +-------------------------------------------------------------------------------- +-- BlockFetch Client. +-------------------------------------------------------------------------------- + +-- | BlockFetch client that fetches blocks and processes transactions. +-- +-- Continuously peeks at headers from the queue (without consuming them), +-- fetches their blocks, and processes transactions. Headers stay in +-- @stateHeaders@ until the block body arrives or the node reports the block is +-- unavailable, so that concurrent rollbacks (via ChainSync) can still filter +-- them out. This closes the in-flight gap that would otherwise allow a +-- rolled-back block to be silently inserted into @statePendingBlocks@. +blockFetchClient :: State -> BlockFetchClient +blockFetchClient state = BF.BlockFetchClient $ do + -- Peek at the next header without consuming it. + -- The header stays in stateHeaders so rollbacks can still filter it out. + header <- STM.atomically $ do + ---------- STM START ---------- + headersSeq <- STM.readTVar (stateHeaders state) + if Seq.null headersSeq + then STM.retry + else pure (Seq.index headersSeq 0) + ---------- STM ENDED ---------- + -- We ask for only one block, using a [point..point] range. + let !point = Net.BlockPoint + (Block.blockSlot header) + (Block.blockHash header) + -- The actual request. + pure $ BF.SendMsgRequestRange + (BFType.ChainRange point point) + (BF.BlockFetchResponse + { -- MsgStartBatch: the node has the block and will send it next via + -- MsgBlock, followed by MsgBatchDone. + BF.handleStartBatch = pure BF.BlockFetchReceiver + -- MsgStartBatch → MsgBlock → MsgBatchDone. + { BF.handleBlock = \block -> do + STM.atomically $ do + ---------- STM START ---------- + -- False if a ChainSync rollback already removed this header. + notRolledBack <- claimHeader state point + if notRolledBack + then processNewBlock state block + else pure () + ---------- STM ENDED ---------- + -- Single-block range: no further blocks expected. + pure BF.BlockFetchReceiver + { BF.handleBlock = \_ -> + error "blockFetchClient: unexpected second block." + , BF.handleBatchDone = pure () + } + , BF.handleBatchDone = pure () + } + -- MsgNoBlocks: the node no longer has the requested block (e.g. it + -- was pruned or belongs to a fork that the node has since rolled + -- back). + , BF.handleNoBlocks = STM.atomically $ + ---------- STM START ---------- + -- Filter the peeked header out of stateHeaders (the other removal + -- path is ChainSync's rollback filter; see module header). + STM.modifyTVar' + (stateHeaders state) + (Seq.filter + (\h -> + let headerPoint = Net.BlockPoint + (Block.blockSlot h) + (Block.blockHash h) + in headerPoint /= point + ) + ) + ---------- STM ENDED ---------- + } + ) + -- Recursion. The continuation. Start the peek all over again. + (blockFetchClient state) + +-------------------------------------------------------------------------------- +-- Block Processing. +-------------------------------------------------------------------------------- + +-- | Claim the previously peeked header from the head of @stateHeaders@. +-- +-- Returns @True@ if the header was found and removed (slot and hash match the +-- head of the queue). Returns @False@ if the header is no longer present either +-- because a rollback already filtered it out, or because a previous call +-- already claimed it. +claimHeader :: State -> Net.Point Block.CardanoBlock -> STM.STM Bool +claimHeader state point = do + headersSeq <- STM.readTVar (stateHeaders state) + if Seq.null headersSeq + then do + -- ChainSync rolled back the header. + pure False + else do + -- Get the first header in the sequence (like a queue). + let header = Seq.index headersSeq 0 + headerPoint = Net.BlockPoint + (Block.blockSlot header) + (Block.blockHash header) + -- As new headers are added at the end of the sequence, we check that the + -- first one is still the one we peeked. + if headerPoint == point + then do + -- We can remove it and let BlockFetch process it. + STM.writeTVar (stateHeaders state) (Seq.drop 1 headersSeq) + pure True + else do + -- ChainSync rolled back the header. + pure False + +-- | Add a block to @statePendingBlocks@ and broadcast any transactions that +-- have reached the configured confirmation depth. +-- +-- Must be called inside an @atomically@ block together with 'claimHeader' +-- so that the header consumption and block insertion are a single atomic step. +-- +-- TODO: This is identical to 'NodeToClient.TxIdSync.processNewBlock'. Once +-- recycling of "due" transactions is added to both, extract the shared logic +-- into a common helper (e.g. in Block.hs) parameterised over the common state +-- fields. +processNewBlock :: State -> Block.CardanoBlock -> STM.STM () +processNewBlock state newBlock = do + tip <- STM.readTVar (stateCurrentTip state) + pendingBlocks <- STM.readTVar (statePendingBlocks state) + -- Appends the new block and splits the ordered `Seq` of blocks into two. + let (confirmedBlocks, remainingBlocks) = + let depth = fromIntegral + (confirmationDepth (stateConfig state)) :: Block.BlockNo + isBlockConfirmed block = case tip of + Net.TipGenesis -> False + Net.Tip _ _ tipBlockNo -> tipBlockNo >= Block.blockNo block + depth + in -- spanl: pending ordered by blockNo (appended in chain order). + Seq.spanl isBlockConfirmed (pendingBlocks <> Seq.singleton newBlock) + -- Remove confirmed blocks from state first. + STM.writeTVar (statePendingBlocks state) remainingBlocks + -- Broadcast each confirmed transaction. + forM_ confirmedBlocks $ \block -> do -- No `toList`, skips intermediate list. + forM_ (Block.extractTxIds block) $ \txId -> do + STM.writeTChan + (stateBroadcast state) + (Right Block.BlockTx + { Block.blockTxId = txId + , Block.blockTxBlockNo = Block.blockNo block + , Block.blockTxSlotNo = Block.blockSlot block + } + ) + -- Resolve limbo against confirmed blocks. + -- Tx IDs that reappear in a confirmed block are removed (the `Right` + -- broadcast above already recycles their outputs). + -- Limbo entries whose height has been confirmed past are true orphans + -- (broadcast as `Left` below). + limbo <- STM.readTVar (stateLimbo state) + let (keepLimbo, toOrphan) = + let depth = fromIntegral + (confirmationDepth (stateConfig state)) :: Block.BlockNo + lastConfirmedBlockNo = case confirmedBlocks of + _ Seq.:|> lastConfirmedBlock -> Block.blockNo lastConfirmedBlock + _ -> 0 + -- Extract confirmed txs IDs to a set, more efficient queries. + confirmedTxIdSet = + Set.fromList + [ txId + | block <- toList confirmedBlocks + , txId <- Block.extractTxIds block + ] + blockTxConfirmed e = Block.blockTxId e `Set.member` confirmedTxIdSet + -- Allow confirmationDepth extra blocks for the tx to reappear at a + -- different height on the winning fork. Forks deeper than + -- confirmationDepth already cause permanent fund loss by design. + pastConfirmed e = + lastConfirmedBlockNo >= Block.blockTxBlockNo e + depth + in + -- partition, not spanl! + -- The limbo is unordered (multiple rollbacks at different heights). + Seq.partition + (not . pastConfirmed) + -- First discard from limbo all confirmed tx IDs. + (Seq.filter (not . blockTxConfirmed) limbo) + -- Remove orphaned txs from state first. + STM.writeTVar (stateLimbo state) keepLimbo + -- Broadcast orphaned txs. + forM_ toOrphan $ \entry -> do -- No `toList`, skips intermediate list. + STM.writeTChan (stateBroadcast state) (Left entry) + diff --git a/bench/tx-centrifuge/lib/tx-centrifuge/Cardano/Benchmarking/TxCentrifuge/NodeToNode/TxSubmission.hs b/bench/tx-centrifuge/lib/tx-centrifuge/Cardano/Benchmarking/TxCentrifuge/NodeToNode/TxSubmission.hs new file mode 100644 index 00000000000..51f94a00494 --- /dev/null +++ b/bench/tx-centrifuge/lib/tx-centrifuge/Cardano/Benchmarking/TxCentrifuge/NodeToNode/TxSubmission.hs @@ -0,0 +1,393 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-------------------------------------------------------------------------------- + +module Cardano.Benchmarking.TxCentrifuge.NodeToNode.TxSubmission + ( TxSubmissionClient + , txSubmissionClient + ) where + +-------------------------------------------------------------------------------- + +---------- +-- base -- +---------- +import Data.Foldable (toList) +import Numeric.Natural (Natural) +import Data.List.NonEmpty qualified as NE +---------------- +-- bytestring -- +---------------- +import Data.ByteString qualified as BS +----------------- +-- cardano-api -- +----------------- +import Cardano.Api qualified as Api +---------------- +-- containers -- +---------------- +import Data.Sequence qualified as Seq +import Data.Set qualified as Set +------------------- +-- contra-tracer -- +------------------- +import "contra-tracer" Control.Tracer (Tracer, traceWith) +--------------------------------------------- +-- ouroboros-consensus:ouroboros-consensus -- +--------------------------------------------- +import Ouroboros.Consensus.Ledger.SupportsMempool qualified as Mempool +--------------------------- +-- ouroboros-network:api -- +--------------------------- +import Ouroboros.Network.SizeInBytes qualified as Net +--------------------------------- +-- ouroboros-network:protocols -- +--------------------------------- +import Ouroboros.Network.Protocol.TxSubmission2.Client qualified as TxSub +import Ouroboros.Network.Protocol.TxSubmission2.Type qualified as TxSub +------------------- +-- tx-centrifuge -- +------------------- +import Cardano.Benchmarking.TxCentrifuge.Block qualified as Block +import Cardano.Benchmarking.TxCentrifuge.Tracing qualified as Tracing + +-------------------------------------------------------------------------------- + +-- | TxSubmission2 client for submitting transactions. +type TxSubmissionClient = + TxSub.TxSubmissionClient + (Mempool.GenTxId Block.CardanoBlock) + (Mempool.GenTx Block.CardanoBlock) + IO + () + +-- | A pre-computed entry in the unacknowledged sequence. +-- +-- All protocol-ready values are computed once at entry time (via 'toEntry') +-- rather than re-derived on every protocol round-trip. +data UnAckedEntry = UnAckedEntry + { -- | For protocol announcement ('MsgReplyTxIds') and matching ('MsgRequestTxs'). + uaeGenTxId :: !(Mempool.GenTxId Block.CardanoBlock) + -- | For protocol body delivery ('MsgReplyTxs'). + , uaeGenTx :: !(Mempool.GenTx Block.CardanoBlock) + -- | For protocol announcement ('MsgReplyTxIds'). + , uaeSize :: !Net.SizeInBytes + } + +-- | Internal state: the unacknowledged tx sequence (oldest first, matching the +-- server's FIFO). Acks remove elements from the front; new announcements are +-- appended at the back. +-- Uses 'Seq' for O(1) length and O(log n) take/drop (vs O(n) for lists). +type UnAcked = Seq.Seq UnAckedEntry + +-------------------------------------------------------------------------------- + +-- | Convert a cardano-api Tx to an 'UnAckedEntry', pre-computing all +-- protocol-ready values. This is the single boundary crossing: every subsequent +-- protocol handler works with native consensus types. +toEntry :: Api.Tx Api.ConwayEra -> UnAckedEntry +toEntry tx = + let !genTx = Block.toGenTx tx + !genTxId = Mempool.txId genTx + -- Wire size (CBOR-encoded). How the announced size flows: + -- 1. Network decides whether to request the tx, checking the announced + -- size against in-flight budgets (txsSizeInflightPerPeer / + -- maxTxsSizeInflight in TxSubmission.Inbound.V2.Decision). + -- 2. Transaction is downloaded; the network layer validates that the + -- actual wire size matches the announced size within 32 bytes + -- (const_MAX_TX_SIZE_DISCREPANCY in .TxSubmission.Inbound.V2.State). + -- 3. Network calls addTxs (Consensus.Mempool.Update) to submit the tx to + -- the mempool. The mempool measures the tx using its own size + -- (sizeTxF + perTxOverhead in Consensus.Shelley.Ledger.Mempool), + -- which is smaller (excludes the CBOR wrapper). The announced size is + -- not used at this stage. + -- 4. When the mempool is full, addTxs blocks the consumer thread. The tx + -- stays counted as in-flight in the network layer. + -- 5. Blocked txs accumulate, saturating maxTxsSizeInflight, which stops + -- the network layer from requesting more txs from peers. + !size = Net.SizeInBytes + (fromIntegral (BS.length (Api.serialiseToCBOR tx))) + in UnAckedEntry + { uaeGenTxId = genTxId + , uaeGenTx = genTx + , uaeSize = size + } + +-- | Extract the protocol announcement pair from a pre-computed entry. +entryToIdSize :: UnAckedEntry + -> (Mempool.GenTxId Block.CardanoBlock, Net.SizeInBytes) +entryToIdSize e = (uaeGenTxId e, uaeSize e) + +-------------------------------------------------------------------------------- + +-- | Create a TxSubmission2 client that pulls txs from caller-supplied IO +-- actions. No intermediate queue, the blocking action is called for the first +-- mandatory tx, and the non-blocking action drains the rest up to the requested +-- count, capped by @maxBatchSize@. +txSubmissionClient + -- | Tracer for structured TxSubmission2 events. + :: Tracer IO Tracing.TxSubmission + -- | Target name (remote node identifier). + -> String + -- | Max batch size per request. + -> Natural + -- | Blocking: wait for a token (must not fail). + -> IO (Api.Tx Api.ConwayEra) + -- | NonBlocking: poll for a token. + -> IO (Maybe (Api.Tx Api.ConwayEra)) + -> TxSubmissionClient +txSubmissionClient tracer targetName maxBatchSize blockingFetch nonBlockingFetch = + TxSub.TxSubmissionClient $ pure $ TxSub.ClientStIdle + { TxSub.recvMsgRequestTxIds = + requestTxIds + tracer + targetName maxBatchSize + blockingFetch nonBlockingFetch + Seq.empty + , TxSub.recvMsgRequestTxs = + requestTxs + tracer + targetName maxBatchSize + blockingFetch nonBlockingFetch + Seq.empty + } + +-------------------------------------------------------------------------------- + +-- | Drain up to @n@ tokens without blocking. +-- This is the primary token consumption path for both 'SingBlocking' (after the +-- first mandatory tx) and 'SingNonBlocking' requests. Stops as soon as the +-- callback returns 'Nothing' (rate-limited). +drainUpTo :: Int + -> IO (Maybe (Api.Tx Api.ConwayEra)) + -> IO [Api.Tx Api.ConwayEra] +drainUpTo 0 _ = pure [] +drainUpTo n fetch = fetch >>= \case + Nothing -> pure [] + Just x -> (x :) <$> drainUpTo (n - 1) fetch + +-- | Handle @MsgRequestTxIds@. +-- +-- TxSubmission2 protocol semantics: +-- SingBlocking → must return at least 1 tx; may block. +-- SingNonBlocking → return 0..reqNum txs; must not block. +-- +-- In both cases, after satisfying the minimum (1 for blocking, 0 for +-- non-blocking), 'drainUpTo' fills the rest via non-blocking calls. +-- Under sustained load a Cardano node operates at near-full mempool capacity +-- and almost exclusively issues 'SingNonBlocking' requests, so the +-- non-blocking path is the dominant token consumption path. +-- See the fairness analysis in WorkloadRunner.runWorkload for details. +requestTxIds + :: forall blocking. + -- | Tracer for structured TxSubmission2 events. + Tracer IO Tracing.TxSubmission + -- | Target name (remote node identifier). + -> String + -- | Max batch size per request. + -> Natural + -- | Blocking: wait for a token (must not fail). + -> IO (Api.Tx Api.ConwayEra) + -- | NonBlocking: poll for a token. + -> IO (Maybe (Api.Tx Api.ConwayEra)) + -- | Unacknowledged transactions (oldest first). + -> UnAcked + -- | Blocking style singleton: + -- * 'SingBlocking': (must return >= 1 tx). + -- * 'SingNonBlocking': (may return 0). + -> TxSub.SingBlockingStyle blocking + -- | Number of tx IDs to ACK. + -> TxSub.NumTxIdsToAck + -- | Number of tx IDs requested. + -> TxSub.NumTxIdsToReq + -> IO ( TxSub.ClientStTxIds + blocking + (Mempool.GenTxId Block.CardanoBlock) + (Mempool.GenTx Block.CardanoBlock) + IO + () + ) +requestTxIds + tracer + targetName maxBatchSize + blockingFetch nonBlockingFetch + unacked + blocking + (TxSub.NumTxIdsToAck ackNum) + (TxSub.NumTxIdsToReq reqNum) + = do + -- Trace: node asked for tx id announcements. + --------------------------------------------- + traceWith tracer $ + Tracing.RequestTxIds + targetName + -- TxIds not yet acknowledged. + (map (Block.fromGenTxId . uaeGenTxId) (toList unacked)) + -- How many the node is ACKing. + (fromIntegral ackNum) + -- How many new TxIds it wants. + (fromIntegral reqNum) + -- Pull txs from the callbacks, capped by maxBatchSize. + ------------------------------------------------------- + newTxs <- do + let !effectiveReq + | maxBatchSize == 0 = fromIntegral reqNum + | otherwise = min + (fromIntegral reqNum) + (fromIntegral maxBatchSize :: Int) + case blocking of + TxSub.SingBlocking -> do + -- Block for exactly one tx (protocol minimum), then remaining up to + -- effectiveReq-1 without blocking. + tx1 <- blockingFetch + rest <- drainUpTo (effectiveReq - 1) nonBlockingFetch + pure (tx1 : rest) + TxSub.SingNonBlocking -> do + -- Return whatever is available up to effectiveReq. + drainUpTo effectiveReq nonBlockingFetch + -- Convert to protocol-ready entries (single boundary crossing). + ---------------------------------------------------------------- + let !newEntries = map toEntry newTxs + -- Drop acknowledged entries. + ----------------------------- + -- Drop acknowledged entries from the front (oldest first, matching the + -- server's FIFO), then append new announcements at the back. + let !unacked' = + let !remaining = Seq.drop (fromIntegral ackNum) unacked + in remaining Seq.>< Seq.fromList newEntries + -- Trace: we replied with tx id announcements. + ---------------------------------------------- + traceWith tracer $ + Tracing.ReplyTxIds + targetName + -- How many the node was ACKing. + (fromIntegral ackNum) + -- How many new TxIds it wanted. + (fromIntegral reqNum) + -- updated unacked after ACK + new. + (map (Block.fromGenTxId . uaeGenTxId) (toList unacked')) + -- TxIds we announced in this reply. + (map + (\entry -> + ( -- Tx ID. + Block.fromGenTxId . uaeGenTxId $ entry + -- Tx size. + , fromEnum $ uaeSize entry + ) + ) + newEntries + ) + -- Build the protocol continuation. + ----------------------------------- + let nextIdle = TxSub.ClientStIdle + -- Continues the protocol loop with the updated unacked list. + { TxSub.recvMsgRequestTxIds = + requestTxIds + tracer + targetName maxBatchSize + blockingFetch nonBlockingFetch + unacked' + , TxSub.recvMsgRequestTxs = + requestTxs + tracer + targetName maxBatchSize + blockingFetch nonBlockingFetch + unacked' + } + -- Answer with what we obtained from the callbacks. + --------------------------------------------------- + case blocking of + TxSub.SingBlocking -> do + case NE.nonEmpty newEntries of + Nothing -> error "requestTxIds: blocking fetch returned empty list!" + Just entries -> do + pure $ TxSub.SendMsgReplyTxIds + (TxSub.BlockingReply $ fmap entryToIdSize entries) + nextIdle + TxSub.SingNonBlocking -> do + pure $ TxSub.SendMsgReplyTxIds + (TxSub.NonBlockingReply $ fmap entryToIdSize newEntries) + nextIdle + +-- | Handle @MsgRequestTxs@: look up requested tx ids in the unacked list and +-- send back the matching transactions. +requestTxs + -- | Tracer for structured TxSubmission2 events. + :: Tracer IO Tracing.TxSubmission + -- | Target name (remote node identifier). + -> String + -- | Max batch size per request. + -> Natural + -- | Blocking: wait for a token (must not fail). + -> IO (Api.Tx Api.ConwayEra) + -- | NonBlocking: poll for a token. + -> IO (Maybe (Api.Tx Api.ConwayEra)) + -- | Unacknowledged transactions (oldest first). + -> UnAcked + -- | Transaction IDs the node is requesting full bodies for. + -> [Mempool.GenTxId Block.CardanoBlock] + -> IO ( TxSub.ClientStTxs + (Mempool.GenTxId Block.CardanoBlock) + (Mempool.GenTx Block.CardanoBlock) + IO + () + ) +requestTxs + tracer + targetName maxBatchSize + blockingFetch nonBlockingFetch + unacked + requestedTxIds + = do + -- Trace: node asked for full transactions by TxId. + --------------------------------------------------- + traceWith tracer $ + Tracing.RequestTxs + targetName + -- TxIds the node requested. + (map Block.fromGenTxId requestedTxIds) + -- Build response. + ------------------ + -- Match directly on consensus GenTxId (native protocol type). + let requestedSet = Set.fromList requestedTxIds + entriesToSend = toList $ Seq.filter + (\e -> uaeGenTxId e `Set.member` requestedSet) + unacked + -- Trace: we replied with the matching transactions. + ---------------------------------------------------- + traceWith tracer $ + Tracing.ReplyTxs + targetName + -- TxIds the node requested. + (map Block.fromGenTxId requestedTxIds) + -- TxIds we actually sent. + (map + (\entry -> + ( -- Tx ID. + Block.fromGenTxId . uaeGenTxId $ entry + -- Tx size. + , fromEnum $ uaeSize entry + ) + ) + entriesToSend + ) + + -- Response and protocol continuation. + -------------------------------------- + pure $ TxSub.SendMsgReplyTxs (map uaeGenTx entriesToSend) $ TxSub.ClientStIdle + -- Continues the protocol loop with no changes to the unacked list. + { TxSub.recvMsgRequestTxIds = + requestTxIds tracer targetName + maxBatchSize blockingFetch nonBlockingFetch + unacked + , TxSub.recvMsgRequestTxs = + requestTxs tracer targetName + maxBatchSize blockingFetch nonBlockingFetch + unacked + } + diff --git a/bench/tx-centrifuge/lib/tx-centrifuge/Cardano/Benchmarking/TxCentrifuge/Tracing.hs b/bench/tx-centrifuge/lib/tx-centrifuge/Cardano/Benchmarking/TxCentrifuge/Tracing.hs new file mode 100644 index 00000000000..fc6f4bcc184 --- /dev/null +++ b/bench/tx-centrifuge/lib/tx-centrifuge/Cardano/Benchmarking/TxCentrifuge/Tracing.hs @@ -0,0 +1,862 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-------------------------------------------------------------------------------- + +-- | Tracer setup for the tx-centrifuge. Creates configured contra-tracers +-- backed by trace-dispatcher and reads optional @TraceOptions@ from the +-- generator config file. +module Cardano.Benchmarking.TxCentrifuge.Tracing + ( -- * Configure. + Tracers (..) + , setupTracers, nullTracers + -- * Traces. + , BuilderTrace (..) + , PipeTrace (..) + , RecyclerTrace (..) + , ObserverTrace (..) + , TxSubmission (..) + -- * Re-exports. + , traceWith + ) where + +-------------------------------------------------------------------------------- + +---------- +-- base -- +---------- +import Control.Exception (SomeException, try) +import Numeric.Natural (Natural) +----------- +-- aeson -- +----------- +import Data.Aeson (Value (String), (.=), object) +----------------- +-- cardano-api -- +----------------- +import Cardano.Api qualified as Api +---------------- +-- containers -- +---------------- +import Data.Map.Strict qualified as Map +------------------- +-- contra-tracer -- +------------------- +import "contra-tracer" Control.Tracer (Tracer (..), traceWith) +--------------------------------- +-- ouroboros-consensus:cardano -- +--------------------------------- +import Ouroboros.Consensus.Cardano qualified as Consensus (CardanoBlock) +import Ouroboros.Consensus.Shelley.Eras qualified as Eras +--------------------------------------------- +-- ouroboros-consensus:ouroboros-consensus -- +--------------------------------------------- +import Ouroboros.Consensus.Ledger.SupportsMempool qualified as Mempool +--------------------------------- +-- ouroboros-network:framework -- +--------------------------------- +import Ouroboros.Network.Driver.Simple qualified as Simple +----------------------------------------- +-- ouroboros-network:framework-tracing -- +----------------------------------------- +-- For the MetaTrace and LogFormatting instances of: +-- - Simple.TraceSendRecv +-- - Stateful.TraceSendRecv +import Ouroboros.Network.Tracing () +--------------------------------- +-- ouroboros-network:protocols -- +--------------------------------- +import Ouroboros.Network.Protocol.KeepAlive.Type qualified as KA +import Ouroboros.Network.Protocol.TxSubmission2.Type qualified as STX +---------- +-- text -- +---------- +import Data.Text qualified as Text +---------------------- +-- trace-dispatcher -- +---------------------- +import Cardano.Logging qualified as Logging +------------------- +-- tx-centrifuge -- +------------------- +import Cardano.Benchmarking.TxCentrifuge.Fund qualified as Fund +-- Imported for its orphan LogFormatting / MetaTrace instances. +import Cardano.Benchmarking.TxCentrifuge.Tracing.Orphans () + +-------------------------------------------------------------------------------- +-- Tracers +-------------------------------------------------------------------------------- + +type CardanoBlock = Consensus.CardanoBlock Eras.StandardCrypto + +data Tracers = Tracers + { -- tx-centrifuge traces. + ------------------------ + -- | Builder trace: new-transaction construction events. + trBuilder :: !(Tracer IO BuilderTrace) + -- | Pipe trace: payload/input queue add and remove events, with the + -- relevant queue depth. Purely about queue mechanics. + , trPipe :: !(Tracer IO PipeTrace) + -- | Recycler trace: payloads added to the backlog ('AddToBacklog'), + -- recycled inputs added back onto a pipe's input queue ('AddToPipe') and + -- input queue resets ('Reset'). Every event emits the backlog size + -- ('backlog'), adds counts at DDetailed and above, and the full inputs at + -- DMaximum. + , trRecycler :: !(Tracer IO RecyclerTrace) + -- | Observer trace: on-chain transaction confirmation/rollback events. + , trObserver :: !(Tracer IO ObserverTrace) + -- | Clean, structured TxSubmission2 trace emitted by TxSubmission.hs. + , trTxSubmission :: !(Tracer IO TxSubmission) + -- ouroboros-network traces. + ---------------------------- + -- | Low-level protocol trace from ouroboros-network's Driver.runPeer. + , trTxSubmission2 + :: !( Tracer + IO + ( Simple.TraceSendRecv + ( STX.TxSubmission2 + (Mempool.GenTxId CardanoBlock) + (Mempool.GenTx CardanoBlock) + ) + ) + ) + -- | Low-level protocol trace from ouroboros-network. + , trKeepAlive + :: !( Tracer + IO + (Simple.TraceSendRecv KA.KeepAlive) + ) + + } + +-- | All-silent tracers. +nullTracers :: Tracers +nullTracers = Tracers + { trBuilder = Tracer (\_ -> pure ()) + , trPipe = Tracer (\_ -> pure ()) + , trRecycler = Tracer (\_ -> pure ()) + , trObserver = Tracer (\_ -> pure ()) + , trTxSubmission = Tracer (\_ -> pure ()) + , trTxSubmission2 = Tracer (\_ -> pure ()) + , trKeepAlive = Tracer (\_ -> pure ()) + } + +-------------------------------------------------------------------------------- +-- Tracer setup +-------------------------------------------------------------------------------- + +-- | Create configured tracers from the tx-centrifuge config file. If the file +-- contains a @TraceOptions@ section, those settings are used. Otherwise falls +-- back to a sensible default (stdout, machine format, severity Debug). +setupTracers :: FilePath -> IO Tracers +setupTracers configFile = do + trConfig <- + either + (\(_ :: SomeException) -> defaultTraceConfig) + id + <$> try (Logging.readConfiguration configFile) + configReflection <- Logging.emptyConfigReflection + stdoutTrace <- Logging.standardTracer + let trForward = mempty + mbTrEkg = Nothing + -- tx-centrifuge traces. + ------------------------ + -- Builder (TxCentrifuge.Builder.NewTx). + !builderTr <- Logging.mkCardanoTracer stdoutTrace trForward mbTrEkg + ["TxCentrifuge", "Builder"] + Logging.configureTracers configReflection trConfig [builderTr] + -- Pipe (TxCentrifuge.Pipe.*). + !pipeTr <- Logging.mkCardanoTracer stdoutTrace trForward mbTrEkg + ["TxCentrifuge", "Pipe"] + Logging.configureTracers configReflection trConfig [pipeTr] + -- Recycler (TxCentrifuge.Recycler.*). + !recyclerTr <- Logging.mkCardanoTracer stdoutTrace trForward mbTrEkg + ["TxCentrifuge", "Recycler"] + Logging.configureTracers configReflection trConfig [recyclerTr] + -- Observer (TxCentrifuge.Observer.Announce). + !observerTr <- Logging.mkCardanoTracer stdoutTrace trForward mbTrEkg + ["TxCentrifuge", "Observer"] + Logging.configureTracers configReflection trConfig [observerTr] + -- TxSubmission (TxCentrifuge.TxSubmission.*). + !txSubTraceTr <- Logging.mkCardanoTracer stdoutTrace trForward mbTrEkg + ["TxCentrifuge", "TxSubmission"] + Logging.configureTracers configReflection trConfig [txSubTraceTr] + -- ouroboros-network traces. + ---------------------------- + -- TxSubmission2 (low-level protocol trace). + !txSub2Trace <- Logging.mkCardanoTracer stdoutTrace trForward mbTrEkg + ["TxSubmission2"] + Logging.configureTracers configReflection trConfig [txSub2Trace] + -- KeepAlive. + !keepAliveTr <- Logging.mkCardanoTracer stdoutTrace trForward mbTrEkg + ["KeepAlive"] + Logging.configureTracers configReflection trConfig [keepAliveTr] + pure Tracers + { trBuilder = Tracer $ Logging.traceWith builderTr + , trPipe = Tracer $ Logging.traceWith pipeTr + , trRecycler = Tracer $ Logging.traceWith recyclerTr + , trObserver = Tracer $ Logging.traceWith observerTr + , trTxSubmission = Tracer $ Logging.traceWith txSubTraceTr + , trTxSubmission2 = Tracer $ Logging.traceWith txSub2Trace + , trKeepAlive = Tracer $ Logging.traceWith keepAliveTr + } + +-- | Default config: stdout machine format, severity Debug for all namespaces. +defaultTraceConfig :: Logging.TraceConfig +defaultTraceConfig = Logging.emptyTraceConfig + { Logging.tcOptions = Map.fromList + [ ( [] + , [ Logging.ConfSeverity + (Logging.SeverityF (Just Logging.Debug)) + , Logging.ConfBackend + [Logging.Stdout Logging.MachineFormat] + ] + ) + ] + } + +-------------------------------------------------------------------------------- +-- Builder trace messages +-------------------------------------------------------------------------------- + +-- | Trace messages emitted by the payload builder. +-- +-- == Builder pipeline +-- +-- The builder consumes input UTxOs (unspent funds) from the input queue, builds +-- and signs a transaction, and results are enqueued for workers to submit. Each +-- transaction produces new output UTxOs. After submission, these outputs can be +-- recycled at different points back to the input queue, forming a closed loop: +-- +-- @ +-- inputs --> [builder: build & sign tx] --> (tx, outputs) --> [do something] +-- ^ | +-- +---------------------maybe recycle outputs --------------------+ +-- @ +-- +-- == Cardano identifiers +-- +-- The Cardano ledger uses a UTxO (Unspent Transaction Output) model. Every +-- transaction consumes existing UTxOs as /inputs/ and produces new UTxOs as +-- /outputs/. Three types from @cardano-api@ identify these objects: +-- +-- === 'Api.TxId' — transaction identifier +-- +-- A Blake2b-256 hash of the serialised transaction body ('Api.TxBody'). +-- Uniquely identifies a transaction on the blockchain. Rendered as a +-- 64-character hex string via 'Api.serialiseToRawBytesHexText'. +-- +-- === 'Api.TxIx' — output index +-- +-- A zero-based index selecting one output within a transaction. +-- +-- === 'Api.TxIn' — UTxO reference +-- +-- A @('Api.TxId', 'Api.TxIx')@ pair that uniquely identifies a single UTxO on +-- the ledger. The standard display format is @\"\#\\"@, +-- produced by 'Api.renderTxIn'. +-- +-- A transaction's /input/ 'Api.TxIn's reference existing UTxOs being spent. Its +-- /output/ 'Api.TxIn's are derived from the new 'Api.TxId' paired with +-- sequential indices (0, 1, 2, ...). +-- +-- In the tx-centrifuge, each 'Fund' record wraps a 'Api.TxIn' (the UTxO +-- reference), its Lovelace value, and the signing key needed to spend it. +data BuilderTrace + = -- | A new transaction was built. This is purely about transaction + -- construction and nothing about the pipe or the queues (see 'PipeTrace'). + -- + -- * 'String': builder name (the workload name, see 'Runtime.builderName'). + -- * 'Api.TxId': Blake2b-256 hash identifying the new transaction. + -- Obtain via @'Api.getTxId' ('Api.getTxBody' signedTx)@. + -- * 'Api.AddressInEra': the destination address this transaction pays to + -- (the builder's own address, from 'destination_signing_key'). Rendered + -- as bech32 only at 'Logging.DMaximum'. + -- * @['Fund.Fund']@ (inputs): funds consumed by this transaction. Each + -- fund's 'Fund.fundTxIn' is a 'Api.TxIn' pointing to an existing UTxO + -- on the ledger. + -- * @['Fund.Fund']@ (outputs): funds produced by this transaction. Each + -- fund's 'Fund.fundTxIn' is derived from the new 'Api.TxId' and a + -- sequential 'Api.TxIx' index (0, 1, 2, ...). + BuilderNewTx + !String !Api.TxId !(Api.AddressInEra Api.ConwayEra) [Fund.Fund] [Fund.Fund] + | -- | A dust batch was dropped: its total input value did not cover the fee, + -- so 'TxAssembly.buildTx' produced no valid change output. The inputs are + -- abandoned (dropped from the builder loop, not recycled) and the service + -- stays up. + -- + -- * 'String': builder name (the workload name). + -- * @['Fund.Fund']@: the dropped input funds. + -- * 'String': the reason (the 'TxAssembly.buildTx' error string). + BuilderInputsDropped !String [Fund.Fund] !String + +-- | Namespace: @TxCentrifuge.Builder.NewTx@. The outer prefix +-- @[\"TxCentrifuge\", \"Builder\"]@ is set when creating the tracer via +-- 'Logging.mkCardanoTracer' in 'setupTracers'. +instance Logging.MetaTrace BuilderTrace where + namespaceFor BuilderNewTx{} = Logging.Namespace [] ["NewTx"] + namespaceFor BuilderInputsDropped{} = Logging.Namespace [] ["InputsDropped"] + severityFor (Logging.Namespace _ ["NewTx"]) _ = Just Logging.Info + severityFor (Logging.Namespace _ ["InputsDropped"]) _ = Just Logging.Warning + severityFor _ _ = Nothing + documentFor (Logging.Namespace _ ["NewTx"]) = Just + "A new transaction was built from input UTxOs, producing output UTxOs." + documentFor (Logging.Namespace _ ["InputsDropped"]) = Just + "A dust batch was dropped: its total input value did not cover the fee, so no valid change output could be produced. The inputs are abandoned, not recycled." + documentFor _ = Nothing + allNamespaces = + [ Logging.Namespace [] ["NewTx"] + , Logging.Namespace [] ["InputsDropped"] + ] + +-- | Machine-readable ('forMachine') and human-readable ('forHuman') rendering +-- of 'BuilderTrace' messages. +-- +-- Machine format ('Logging.DNormal'): +-- +-- @ +-- { \"builder\": \"workload-name\" +-- , \"txId\": \"\<64-char hex\>\" +-- } +-- @ +-- +-- Machine format ('Logging.DDetailed'): adds the consumed and produced UTxO +-- references as strings. +-- +-- @ +-- { \"builder\": \"workload-name\" +-- , \"txId\": \"\<64-char hex\>\" +-- , \"inputs\": [\"\#\\", ...] +-- , \"outputs\": [\"\#\\", ...] +-- } +-- @ +-- +-- Machine format ('Logging.DMaximum'): renders each fund in full (a JSON +-- object with its @\"utxo\"@ reference and @\"lovelace\"@ value) and adds the +-- @\"destination\"@ address the transaction pays to. +-- +-- @ +-- { \"builder\": \"workload-name\" +-- , \"txId\": \"\<64-char hex\>\" +-- , \"destination\": \"addr...\" +-- , \"inputs\": [{\"utxo\": \"\#\\", \"lovelace\": 1000000}, ...] +-- , \"outputs\": [{\"utxo\": \"\#\\", \"lovelace\": 500000}, ...] +-- } +-- @ +-- +-- Human format: +-- +-- @ +-- NewTx [workload-name] \ inputs=[...] outputs=[...] +-- @ +instance Logging.LogFormatting BuilderTrace where + forMachine dtal (BuilderNewTx name txId dest inputs outputs) = mconcat $ + [ "builder" .= name + , "txId" .= String (Api.serialiseToRawBytesHexText txId) + ] + ++ [ "destination" .= Api.serialiseAddress dest + | dtal >= Logging.DMaximum + ] + ++ [ "inputs" .= map (renderFund dtal) inputs + | dtal >= Logging.DDetailed + ] + ++ [ "outputs" .= map (renderFund dtal) outputs + | dtal >= Logging.DDetailed + ] + forMachine dtal (BuilderInputsDropped name inputs reason) = mconcat $ + [ "builder" .= name + , "reason" .= reason + ] + ++ [ "inputs" .= map (renderFund dtal) inputs + | dtal >= Logging.DDetailed + ] + forHuman (BuilderNewTx name txId _dest inputs outputs) = + "NewTx [" <> Text.pack name <> "] " + <> Api.serialiseToRawBytesHexText txId + <> " inputs=[" <> renderFundTxIns inputs <> "]" + <> " outputs=[" <> renderFundTxIns outputs <> "]" + forHuman (BuilderInputsDropped name inputs reason) = + "InputsDropped [" <> Text.pack name <> "] " + <> "reason=" <> Text.pack reason + <> " inputs=[" <> renderFundTxIns inputs <> "]" + +-- | Render a single fund for 'forMachine' output. +-- +-- * Below 'Logging.DMaximum': just the UTxO reference as a string +-- (@\"\#\\"@). +-- * 'Logging.DMaximum': a JSON object with @\"utxo\"@ and @\"lovelace\"@ fields. +renderFund :: Logging.DetailLevel -> Fund.Fund -> Value +renderFund dtal fund + | dtal >= Logging.DMaximum = + object [ "utxo" .= Api.renderTxIn (Fund.fundTxIn fund) + , "lovelace" .= Fund.fundValue fund + ] + | otherwise = + String (Api.renderTxIn (Fund.fundTxIn fund)) + +-- | Render a list of funds as comma-separated @\"\#\\"@ references. +renderFundTxIns :: [Fund.Fund] -> Text.Text +renderFundTxIns = Text.intercalate "," . map (Api.renderTxIn . Fund.fundTxIn) + +-------------------------------------------------------------------------------- +-- Pipe trace messages +-------------------------------------------------------------------------------- + +-- | Pipe queue events. The pipe reports depth changes on its two queues as +-- items are added or removed but nothing about how a transaction was built or +-- confirmed. The 'String' is the pipe name (the JSON key is @\"pipe\"@ that is +-- currently one pipe per workload, so it is 'Runtime.builderName', but that is +-- not guaranteed to stay one-to-one). +data PipeTrace + = -- | Inputs were added to the input queue. 'Natural' is the input-queue + -- depth right after. @[Fund.Fund]@ is the inputs added (their count is + -- emitted at 'Logging.DDetailed' and above, their full data at + -- 'Logging.DMaximum'). + PipeInputsEnqueued !String !Natural [Fund.Fund] + -- | Inputs were removed from the input queue (taken by the builder). + -- 'Natural' is the input-queue depth right after. @[Fund.Fund]@ is the + -- inputs removed (count at 'Logging.DDetailed' and above, full data at + -- 'Logging.DMaximum'). + | PipeInputsDequeued !String !Natural [Fund.Fund] + -- | A payload was added to the payload queue. 'Natural' is the + -- payload-queue depth right after the write. 'Api.TxId' is the payload's + -- tx id (emitted only at 'Logging.DMaximum'). + | PipePayloadEnqueued !String !Natural !Api.TxId + -- | A payload was removed from the payload queue (pulled by a worker). + -- 'Natural' is the payload-queue depth observed shortly after the pull + -- (this is read outside the pull transaction, so under concurrency it is a + -- close approximation, not an exact post-pull snapshot). 'Api.TxId' is the + -- payload's tx id (emitted only at 'Logging.DMaximum'). + | PipePayloadDequeued !String !Natural !Api.TxId + +-- | Namespaces: @TxCentrifuge.Pipe.{InputsEnqueued, InputsDequeued, +-- PayloadEnqueued, PayloadDequeued}@. Outer prefix +-- @[\"TxCentrifuge\", \"Pipe\"]@ is set in 'setupTracers'. +instance Logging.MetaTrace PipeTrace where + namespaceFor PipeInputsEnqueued{} = Logging.Namespace [] ["InputsEnqueued"] + namespaceFor PipeInputsDequeued{} = Logging.Namespace [] ["InputsDequeued"] + namespaceFor PipePayloadEnqueued{} = Logging.Namespace [] ["PayloadEnqueued"] + namespaceFor PipePayloadDequeued{} = Logging.Namespace [] ["PayloadDequeued"] + severityFor (Logging.Namespace _ ["InputsEnqueued"]) _ = Just Logging.Info + severityFor (Logging.Namespace _ ["InputsDequeued"]) _ = Just Logging.Info + severityFor (Logging.Namespace _ ["PayloadEnqueued"]) _ = Just Logging.Info + severityFor (Logging.Namespace _ ["PayloadDequeued"]) _ = Just Logging.Info + severityFor _ _ = Nothing + documentFor (Logging.Namespace _ ["InputsEnqueued"]) = Just + "Inputs were added to the input queue (count at DDetailed, data at DMaximum)." + documentFor (Logging.Namespace _ ["InputsDequeued"]) = Just + "Inputs were removed from the input queue for the builder (count at DDetailed, data at DMaximum)." + documentFor (Logging.Namespace _ ["PayloadEnqueued"]) = Just + "A payload was added to the payload queue (its txId is included at DMaximum)." + documentFor (Logging.Namespace _ ["PayloadDequeued"]) = Just + "A payload was removed from the payload queue for a worker (txId at DMaximum)." + documentFor _ = Nothing + allNamespaces = + [ Logging.Namespace [] ["InputsEnqueued"] + , Logging.Namespace [] ["InputsDequeued"] + , Logging.Namespace [] ["PayloadEnqueued"] + , Logging.Namespace [] ["PayloadDequeued"] + ] + +-- | Machine format: every Pipe event always carries @pipe@ + @depth@ (the +-- namespace already says which queue). Input events add @count@ at +-- 'Logging.DDetailed' and above and an @inputs@ array of rendered funds at +-- 'Logging.DMaximum' (see 'renderFund'). Payload events add a @txId@ at +-- 'Logging.DMaximum'. Human format shows just the depth (and, for inputs, the +-- count). +instance Logging.LogFormatting PipeTrace where + forMachine dtal (PipeInputsEnqueued name depth inputs) = mconcat $ + [ "pipe" .= name + , "depth" .= depth + ] + ++ [ "count" .= length inputs + | dtal >= Logging.DDetailed + ] + ++ [ "inputs" .= map (renderFund dtal) inputs + | dtal >= Logging.DMaximum + ] + forMachine dtal (PipeInputsDequeued name depth inputs) = mconcat $ + [ "pipe" .= name + , "depth" .= depth + ] + ++ [ "count" .= length inputs + | dtal >= Logging.DDetailed + ] + ++ [ "inputs" .= map (renderFund dtal) inputs + | dtal >= Logging.DMaximum + ] + forMachine dtal (PipePayloadEnqueued name depth txId) = mconcat $ + [ "pipe" .= name + , "depth" .= depth + ] + ++ [ "txId" .= String (Api.serialiseToRawBytesHexText txId) + | dtal >= Logging.DMaximum + ] + forMachine dtal (PipePayloadDequeued name depth txId) = mconcat $ + [ "pipe" .= name + , "depth" .= depth + ] + ++ [ "txId" .= String (Api.serialiseToRawBytesHexText txId) + | dtal >= Logging.DMaximum + ] + forHuman (PipeInputsEnqueued name depth inputs) = + "InputsEnqueued [" <> Text.pack name <> "]" + <> " depth=" <> Text.pack (show depth) + <> " count=" <> Text.pack (show (length inputs)) + forHuman (PipeInputsDequeued name depth inputs) = + "InputsDequeued [" <> Text.pack name <> "]" + <> " depth=" <> Text.pack (show depth) + <> " count=" <> Text.pack (show (length inputs)) + forHuman (PipePayloadEnqueued name depth _txId) = + "PayloadEnqueued [" <> Text.pack name <> "]" + <> " depth=" <> Text.pack (show depth) + forHuman (PipePayloadDequeued name depth _txId) = + "PayloadDequeued [" <> Text.pack name <> "]" + <> " depth=" <> Text.pack (show depth) + +-------------------------------------------------------------------------------- +-- Recycler trace messages +-------------------------------------------------------------------------------- + +-- | Recycler events. The recycler holds a payload's recyclable input UTxOs +-- until a release picks a set, then adds it back onto a pipe's input queue +-- (closing the loop). It reports each add of a payload's entry to its +-- backlog ('RecyclerAddToBacklog': the key and both input sets), each add of +-- inputs to a pipe ('RecyclerAddToPipe': which inputs were added, by which +-- recycler, into which pipe) and each reset of a pipe ('RecyclerReset'). The +-- 'String' names are the recycler and (on 'RecyclerAddToPipe' and +-- 'RecyclerReset') the pipe (currently both the workload name, but recorded +-- separately as that mapping is not guaranteed to stay one-to-one). The +-- 'Natural' is the resulting backlog size. +data RecyclerTrace + = -- | A payload's entry was added to the backlog: its key and its two + -- input sets, held until a release picks one. 'String' is the recycler + -- name, 'Natural' the resulting backlog size, 'Api.TxId' the payload's + -- key, first @[Fund.Fund]@ the consumed inputs, second the produced + -- outputs (counts at 'Logging.DDetailed' and above, txId and full data + -- at 'Logging.DMaximum'). + RecyclerAddToBacklog !String !Natural !Api.TxId [Fund.Fund] [Fund.Fund] + -- | Recycled inputs were added back onto a pipe's input queue. First + -- 'String' is the recycler name, second 'String' the pipe name, 'Natural' + -- the resulting backlog size, @[Fund.Fund]@ the added inputs (count at + -- 'Logging.DDetailed' and above, full data at 'Logging.DMaximum'). + | RecyclerAddToPipe !String !String !Natural [Fund.Fund] + -- | The recycler reset a pipe's input queue: the queued inputs were + -- discarded, the payloads built from them were dropped from the payload + -- queue, and the input queue was reseeded with fresh inputs (a builder's + -- recovery). First 'String' is the recycler name, second 'String' the + -- pipe name, 'Natural' the resulting backlog size (always @0@, + -- a reset clears the backlog), @[Api.TxId]@ the dropped queued payloads + -- by txId, first @[Fund.Fund]@ the dropped inputs, second the fresh ones + -- added to the queue (counts at 'Logging.DDetailed' and above, full data + -- at 'Logging.DMaximum'). + | RecyclerReset !String !String !Natural [Api.TxId] [Fund.Fund] [Fund.Fund] + +-- | Namespaces: @TxCentrifuge.Recycler.{AddToBacklog, AddToPipe, Reset}@. +-- Outer prefix @[\"TxCentrifuge\", \"Recycler\"]@ is set in 'setupTracers'. +instance Logging.MetaTrace RecyclerTrace where + namespaceFor RecyclerAddToBacklog{} = Logging.Namespace [] ["AddToBacklog"] + namespaceFor RecyclerAddToPipe{} = Logging.Namespace [] ["AddToPipe"] + namespaceFor RecyclerReset{} = Logging.Namespace [] ["Reset"] + severityFor (Logging.Namespace _ ["AddToBacklog"]) _ = Just Logging.Info + severityFor (Logging.Namespace _ ["AddToPipe"]) _ = Just Logging.Info + severityFor (Logging.Namespace _ ["Reset"]) _ = Just Logging.Warning + severityFor _ _ = Nothing + documentFor (Logging.Namespace _ ["AddToBacklog"]) = Just $ + "The recycler added a payload's entry to its backlog: the key and both " + <> "input sets, held until a release picks one. The backlog count is " + <> "the number of held payloads, not a pipe queue depth." + documentFor (Logging.Namespace _ ["AddToPipe"]) = Just + "The recycler added a payload's recycled inputs back onto a pipe's input queue (count at DDetailed, full inputs at DMaximum)." + documentFor (Logging.Namespace _ ["Reset"]) = Just $ + "The recycler reset a pipe for a builder's recovery: the queued inputs " + <> "and the queued payloads built from them were dropped, and the input " + <> "queue was reseeded with fresh inputs (counts at DDetailed, full " + <> "inputs at DMaximum)." + documentFor _ = Nothing + allNamespaces = + [ Logging.Namespace [] ["AddToBacklog"] + , Logging.Namespace [] ["AddToPipe"] + , Logging.Namespace [] ["Reset"] + ] + +-- | Machine format: every event emits @recycler@ and @backlog@ (the +-- resulting backlog size, not a queue depth). 'RecyclerAddToBacklog' +-- carries the added entry: @consumed_count@ and @outputs_count@ at +-- 'Logging.DDetailed', the payload's @txId@ and the @consumed@ and +-- @outputs@ fund arrays (see 'renderFund') at 'Logging.DMaximum'. +-- 'RecyclerAddToPipe' (which also emits @pipe@) adds a @count@ at +-- 'Logging.DDetailed' and an @inputs@ array of the recycled funds at +-- 'Logging.DMaximum'. 'RecyclerReset' (also with @pipe@) adds @count@ for +-- the fresh inputs, @dropped_inputs_count@ and @dropped_payloads_count@ at +-- 'Logging.DDetailed', plus the @inputs@ (fresh), @dropped_inputs@ and +-- @dropped_payloads@ (txIds) arrays at 'Logging.DMaximum'. +-- Human format shows the backlog size and the counts. +instance Logging.LogFormatting RecyclerTrace where + forMachine dtal (RecyclerAddToBacklog recyclerName backlog txId consumed outputs) = + mconcat $ + [ "recycler" .= recyclerName + , "backlog" .= backlog + ] + ++ [ "consumed_count" .= length consumed + | dtal >= Logging.DDetailed + ] + ++ [ "outputs_count" .= length outputs + | dtal >= Logging.DDetailed + ] + ++ [ "txId" .= String (Api.serialiseToRawBytesHexText txId) + | dtal >= Logging.DMaximum + ] + ++ [ "consumed" .= map (renderFund dtal) consumed + | dtal >= Logging.DMaximum + ] + ++ [ "outputs" .= map (renderFund dtal) outputs + | dtal >= Logging.DMaximum + ] + forMachine dtal (RecyclerAddToPipe recyclerName pipeName backlog inputs) = mconcat $ + [ "recycler" .= recyclerName + , "pipe" .= pipeName + , "backlog" .= backlog + ] + ++ [ "count" .= length inputs + | dtal >= Logging.DDetailed + ] + ++ [ "inputs" .= map (renderFund dtal) inputs + | dtal >= Logging.DMaximum + ] + forMachine dtal (RecyclerReset recyclerName pipeName backlog droppedPayloads droppedInputs fresh) = + mconcat $ + [ "recycler" .= recyclerName + , "pipe" .= pipeName + , "backlog" .= backlog + ] + ++ [ "count" .= length fresh + | dtal >= Logging.DDetailed + ] + ++ [ "dropped_inputs_count" .= length droppedInputs + | dtal >= Logging.DDetailed + ] + ++ [ "dropped_payloads_count" .= length droppedPayloads + | dtal >= Logging.DDetailed + ] + ++ [ "inputs" .= map (renderFund dtal) fresh + | dtal >= Logging.DMaximum + ] + ++ [ "dropped_inputs" .= map (renderFund dtal) droppedInputs + | dtal >= Logging.DMaximum + ] + ++ [ "dropped_payloads" .= + map (String . Api.serialiseToRawBytesHexText) droppedPayloads + | dtal >= Logging.DMaximum + ] + forHuman (RecyclerAddToBacklog recyclerName backlog _txId consumed outputs) = + "AddToBacklog [" <> Text.pack recyclerName <> "]" + <> " backlog=" <> Text.pack (show backlog) + <> " consumed_count=" <> Text.pack (show (length consumed)) + <> " outputs_count=" <> Text.pack (show (length outputs)) + forHuman (RecyclerAddToPipe recyclerName pipeName backlog inputs) = + "AddToPipe [" <> Text.pack recyclerName <> "]" + <> " pipe=" <> Text.pack pipeName + <> " backlog=" <> Text.pack (show backlog) + <> " count=" <> Text.pack (show (length inputs)) + forHuman (RecyclerReset recyclerName pipeName backlog droppedPayloads droppedInputs fresh) = + "Reset [" <> Text.pack recyclerName <> "]" + <> " pipe=" <> Text.pack pipeName + <> " backlog=" <> Text.pack (show backlog) + <> " count=" <> Text.pack (show (length fresh)) + <> " dropped_inputs_count=" <> Text.pack (show (length droppedInputs)) + <> " dropped_payloads_count=" <> Text.pack (show (length droppedPayloads)) + +-------------------------------------------------------------------------------- +-- Observer trace messages +-------------------------------------------------------------------------------- + +-- | Observer events. Logged entirely in @Main.hs@ from the observer's on-chain +-- confirmation stream, decoupled from the pipe and from recycling. +data ObserverTrace + = -- | The observer saw a transaction confirmed or orphaned (rolled back). + -- + -- * 'String': observer name (from the config's @\"observers\"@ object). + -- * 'Api.TxId': the confirmed/orphaned transaction's id. + -- * 'Bool': @True@ if orphaned (rolled back), @False@ if confirmed. + ObserverAnnounce !String !Api.TxId !Bool + +-- | Namespace: @TxCentrifuge.Observer.Announce@. Outer prefix +-- @[\"TxCentrifuge\", \"Observer\"]@ is set in 'setupTracers'. +instance Logging.MetaTrace ObserverTrace where + namespaceFor ObserverAnnounce{} = Logging.Namespace [] ["Announce"] + severityFor (Logging.Namespace _ ["Announce"]) _ = Just Logging.Info + severityFor _ _ = Nothing + documentFor (Logging.Namespace _ ["Announce"]) = Just + "The observer saw a transaction confirmed or orphaned (rolled back)." + documentFor _ = Nothing + allNamespaces = + [ Logging.Namespace [] ["Announce"] + ] + +instance Logging.LogFormatting ObserverTrace where + forMachine _ (ObserverAnnounce observer txId isOrphan) = mconcat + [ "observer" .= observer + , "txId" .= String (Api.serialiseToRawBytesHexText txId) + , "isOrphan" .= isOrphan + ] + forHuman (ObserverAnnounce observer txId isOrphan) = + "Announce [" <> Text.pack observer <> "]" + <> " txId=" <> Api.serialiseToRawBytesHexText txId + <> (if isOrphan then " (orphan)" else " (confirmed)") + +-------------------------------------------------------------------------------- +-- TxSubmission trace messages +-------------------------------------------------------------------------------- + +-- | Clean, structured trace of the TxSubmission2 protocol as seen from the +-- generator side. Replaces the verbose @Show@-based tracing in +-- @ouroboros-network@'s @TraceSendRecv@ with fields that are easy to parse and +-- verify. +-- +-- Every constructor carries a @target@ field identifying the remote node (the +-- 'Runtime.targetName' of the 'Runtime.Target'). +data TxSubmission + = -- | The node asked for transaction identifiers (@MsgRequestTxIds@). + -- + -- * 'String': target node name. + -- * @['Api.TxId']@: TxIds we have not yet received an ACK for. + -- * 'Int': number of TxIds the node is acknowledging (ACK). + -- * 'Int': number of new TxIds the node is requesting (REQ). + RequestTxIds !String [Api.TxId] !Int !Int + -- | We replied to @MsgRequestTxIds@ with TxId\/size pairs. + -- + -- * 'String': target node name. + -- * 'Int': number of TxIds the node is acknowledging (ACK). + -- * 'Int': number of new TxIds the node is requesting (REQ). + -- * @['Api.TxId']@: updated unacked TxIds (after ACK + new announcements). + -- * @[('Api.TxId','Int')]@: TxIds we announced in this reply with its sizes in bytes. + | ReplyTxIds !String !Int !Int [Api.TxId] [(Api.TxId,Int)] + -- | The node asked for full transactions by TxId (@MsgRequestTxs@). + -- + -- * 'String': target node name. + -- * @['Api.TxId']@: TxIds the node requested. + | RequestTxs !String [Api.TxId] + -- | We replied to @MsgRequestTxs@ with the requested transactions. + -- + -- * 'String': target node name. + -- * @['Api.TxId']@: TxIds the node requested. + -- * @[('Api.TxId','Int')]@: TxIds we actually sent (subset of requested; a + -- TxId is missing if it wasn't in the unacked list). + | ReplyTxs !String [Api.TxId] [(Api.TxId,Int)] + +-- | Namespace: @TxCentrifuge.TxSubmission.*@. The outer prefix is set via +-- 'Logging.mkCardanoTracer' in 'setupTracers'. +instance Logging.MetaTrace TxSubmission where + namespaceFor RequestTxIds{} = Logging.Namespace [] ["RequestTxIds"] + namespaceFor ReplyTxIds{} = Logging.Namespace [] ["ReplyTxIds"] + namespaceFor RequestTxs{} = Logging.Namespace [] ["RequestTxs"] + namespaceFor ReplyTxs{} = Logging.Namespace [] ["ReplyTxs"] + severityFor (Logging.Namespace _ ["RequestTxIds"]) _ = Just Logging.Info + severityFor (Logging.Namespace _ ["ReplyTxIds"]) _ = Just Logging.Info + severityFor (Logging.Namespace _ ["RequestTxs"]) _ = Just Logging.Info + severityFor (Logging.Namespace _ ["ReplyTxs"]) _ = Just Logging.Info + severityFor _ _ = Nothing + documentFor (Logging.Namespace _ ["RequestTxIds"]) = Just + "Node requested tx id announcements (blocking or non-blocking)." + documentFor (Logging.Namespace _ ["ReplyTxIds"]) = Just + "We replied with tx id announcements and sizes." + documentFor (Logging.Namespace _ ["RequestTxs"]) = Just + "Node requested full transactions by TxId." + documentFor (Logging.Namespace _ ["ReplyTxs"]) = Just + "We sent the requested transactions." + documentFor _ = Nothing + allNamespaces = + [ Logging.Namespace [] ["RequestTxIds"] + , Logging.Namespace [] ["ReplyTxIds"] + , Logging.Namespace [] ["RequestTxs"] + , Logging.Namespace [] ["ReplyTxs"] + ] + +-- | Machine-readable and human-readable rendering. All TxId lists are omitted +-- below 'Logging.DDetailed' to avoid the cost of hex-encoding every transaction +-- identifier on every protocol round-trip. +-- +-- Machine format ('Logging.DNormal'): +-- +-- @ +-- { \"target\": \"n\", \"ack\": 0, \"req\": 3 } +-- { \"target\": \"n\" } +-- { \"target\": \"n\" } +-- { \"target\": \"n\" } +-- @ +-- +-- Machine format ('Logging.DDetailed' and above): +-- +-- @ +-- { \"target\": \"n\", \"ack\": 0, \"req\": 3, \"unacked\": [\"ab..\"] } +-- { \"target\": \"n\", \"ack\": 0, \"req\": 3, \"txs\": [{\"id\":\"ab..\",\"size\":9}], \"unacked\": [\"ab..\"] } +-- { \"target\": \"n\", \"txIds\": [\"ab..\"] } +-- { \"target\": \"n\", \"txs\": [{\"id\":\"ab..\",\"size\":9}], \"requested\": [\"ab..\"] } +-- @ +instance Logging.LogFormatting TxSubmission where + forMachine dtal (RequestTxIds target unacked ack req) = mconcat $ + [ "target" .= target + , "ack" .= ack + , "req" .= req + ] + ++ [ "unacked" .= map Api.serialiseToRawBytesHexText unacked + | dtal >= Logging.DDetailed + ] + forMachine dtal (ReplyTxIds target ack req unacked announced) = mconcat $ + [ "target" .= target ] + ++ [ "ack" .= ack + | dtal >= Logging.DDetailed + ] + ++ [ "req" .= req + | dtal >= Logging.DDetailed + ] + ++ [ "txs" .= map + (\(txId,txSize) -> + object + [ "id" .= Api.serialiseToRawBytesHexText txId + , "size" .= txSize + ] + ) + announced + | dtal >= Logging.DDetailed + ] + ++ [ "unacked" .= map Api.serialiseToRawBytesHexText unacked + | dtal >= Logging.DDetailed + ] + forMachine dtal (RequestTxs target txIds) = mconcat $ + [ "target" .= target ] + ++ [ "txIds" .= map Api.serialiseToRawBytesHexText txIds + | dtal >= Logging.DDetailed + ] + forMachine dtal (ReplyTxs target requested sent) = mconcat $ + [ "target" .= target ] + ++ [ "txs" .= map + (\(txId,txSize) -> + object + [ "id" .= Api.serialiseToRawBytesHexText txId + , "size" .= txSize + ] + ) + sent + | dtal >= Logging.DDetailed + ] + ++ [ "requested" .= map Api.serialiseToRawBytesHexText requested + | dtal >= Logging.DDetailed + ] + forHuman (RequestTxIds target _unacked ack req) = + "RequestTxIds [" <> Text.pack target <> "]" + <> " ack=" <> Text.pack (show ack) + <> " req=" <> Text.pack (show req) + forHuman (ReplyTxIds target ack req _unacked _announced) = + "ReplyTxIds [" <> Text.pack target <> "]" + <> " ack=" <> Text.pack (show ack) + <> " req=" <> Text.pack (show req) + forHuman (RequestTxs target _txIds) = + "RequestTxs [" <> Text.pack target <> "]" + forHuman (ReplyTxs target _requested _sent) = + "ReplyTxs [" <> Text.pack target <> "]" + diff --git a/bench/tx-centrifuge/lib/tx-centrifuge/Cardano/Benchmarking/TxCentrifuge/Tracing/Orphans.hs b/bench/tx-centrifuge/lib/tx-centrifuge/Cardano/Benchmarking/TxCentrifuge/Tracing/Orphans.hs new file mode 100644 index 00000000000..5727668bb7e --- /dev/null +++ b/bench/tx-centrifuge/lib/tx-centrifuge/Cardano/Benchmarking/TxCentrifuge/Tracing/Orphans.hs @@ -0,0 +1,258 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_GHC -Wno-orphans #-} + +-------------------------------------------------------------------------------- + +-- | Orphan 'LogFormatting' and 'MetaTrace' instances copied from @cardano-node@ +-- @NodeToClient.hs@ so that trace-dispatcher can format TxSubmission2 and +-- KeepAlive messages. +module Cardano.Benchmarking.TxCentrifuge.Tracing.Orphans () where + +-------------------------------------------------------------------------------- + +----------- +-- aeson -- +----------- +import Data.Aeson (Value (String), (.=)) +---------- +-- text -- +---------- +import Data.Text (pack) +--------------------------------- +-- ouroboros-network:protocols -- +--------------------------------- +import Ouroboros.Network.Protocol.KeepAlive.Type qualified as KA +import Ouroboros.Network.Protocol.TxSubmission2.Type qualified as STX +---------------------- +-- trace-dispatcher -- +---------------------- +-- We prefer the qualified import above but used to copy instances unmmodified. +import Cardano.Logging + ( LogFormatting (..) + , MetaTrace (..) + , Namespace (..) + , SeverityS (..) + ) +--------------------- +-- typed-protocols -- +--------------------- +-- First one to copy unmodified the instance definition of `TxSubmissionNode2`. +import Network.TypedProtocol.Codec (AnyMessage (AnyMessageAndAgency)) + +-- Copied instances: from cardano-node NodeToNode.hs +-------------------------------------------------------------------------------- +-- TxSubmissionNode2 Tracer +-------------------------------------------------------------------------------- + +instance (Show txid, Show tx) + => LogFormatting (AnyMessage (STX.TxSubmission2 txid tx)) where + forMachine _dtal (AnyMessageAndAgency stok STX.MsgInit) = + mconcat + [ "kind" .= String "MsgInit" + , "agency" .= String (pack $ show stok) + ] + forMachine _dtal (AnyMessageAndAgency stok STX.MsgRequestTxIds {}) = + mconcat + [ "kind" .= String "MsgRequestTxIds" + , "agency" .= String (pack $ show stok) + ] + forMachine _dtal (AnyMessageAndAgency stok (STX.MsgReplyTxIds _)) = + mconcat + [ "kind" .= String "MsgReplyTxIds" + , "agency" .= String (pack $ show stok) + ] + forMachine _dtal (AnyMessageAndAgency stok (STX.MsgRequestTxs txids)) = + mconcat + [ "kind" .= String "MsgRequestTxs" + , "agency" .= String (pack $ show stok) + , "txIds" .= String (pack $ show txids) + ] + forMachine _dtal (AnyMessageAndAgency stok (STX.MsgReplyTxs txs)) = + mconcat + [ "kind" .= String "MsgReplyTxs" + , "agency" .= String (pack $ show stok) + , "txs" .= String (pack $ show txs) + ] + forMachine _dtal (AnyMessageAndAgency stok STX.MsgDone) = + mconcat + [ "kind" .= String "MsgDone" + , "agency" .= String (pack $ show stok) + ] + +instance MetaTrace (AnyMessage (STX.TxSubmission2 txid tx)) where + namespaceFor (AnyMessageAndAgency _stok STX.MsgInit {}) = + Namespace [] ["MsgInit"] + namespaceFor (AnyMessageAndAgency _stok STX.MsgRequestTxIds {}) = + Namespace [] ["RequestTxIds"] + namespaceFor (AnyMessageAndAgency _stok STX.MsgReplyTxIds {}) = + Namespace [] ["ReplyTxIds"] + namespaceFor (AnyMessageAndAgency _stok STX.MsgRequestTxs {}) = + Namespace [] ["RequestTxs"] + namespaceFor (AnyMessageAndAgency _stok STX.MsgReplyTxs {}) = + Namespace [] ["ReplyTxs"] + namespaceFor (AnyMessageAndAgency _stok STX.MsgDone {}) = + Namespace [] ["Done"] + + severityFor (Namespace _ ["MsgInit"]) _ = Just Debug + severityFor (Namespace _ ["RequestTxIds"]) _ = Just Debug + severityFor (Namespace _ ["ReplyTxIds"]) _ = Just Debug + severityFor (Namespace _ ["RequestTxs"]) _ = Just Debug + severityFor (Namespace _ ["ReplyTxs"]) _ = Just Debug + severityFor (Namespace _ ["Done"]) _ = Just Debug + severityFor _ _ = Nothing + + documentFor (Namespace _ ["MsgInit"]) = Just + "Client side hello message." + documentFor (Namespace _ ["RequestTxIds"]) = Just $ mconcat + [ "Request a non-empty list of transaction identifiers from the client, " + , "and confirm a number of outstanding transaction identifiers. " + , "\n " + , "With 'TokBlocking' this is a a blocking operation: the response will " + , "always have at least one transaction identifier, and it does not expect " + , "a prompt response: there is no timeout. This covers the case when there " + , "is nothing else to do but wait. For example this covers leaf nodes that " + , "rarely, if ever, create and submit a transaction. " + , "\n " + , "With 'TokNonBlocking' this is a non-blocking operation: the response " + , "may be an empty list and this does expect a prompt response. This " + , "covers high throughput use cases where we wish to pipeline, by " + , "interleaving requests for additional transaction identifiers with " + , "requests for transactions, which requires these requests not block. " + , "\n " + , "The request gives the maximum number of transaction identifiers that " + , "can be accepted in the response. This must be greater than zero in the " + , "'TokBlocking' case. In the 'TokNonBlocking' case either the numbers " + , "acknowledged or the number requested must be non-zero. In either case, " + , "the number requested must not put the total outstanding over the fixed " + , "protocol limit. " + , "\n" + , "The request also gives the number of outstanding transaction " + , "identifiers that can now be acknowledged. The actual transactions " + , "to acknowledge are known to the peer based on the FIFO order in which " + , "they were provided. " + , "\n " + , "There is no choice about when to use the blocking case versus the " + , "non-blocking case, it depends on whether there are any remaining " + , "unacknowledged transactions (after taking into account the ones " + , "acknowledged in this message): " + , "\n " + , "* The blocking case must be used when there are zero remaining " + , " unacknowledged transactions. " + , "\n " + , "* The non-blocking case must be used when there are non-zero remaining " + , " unacknowledged transactions." + ] + documentFor (Namespace _ ["ReplyTxIds"]) = Just $ mconcat + [ "Reply with a list of transaction identifiers for available " + , "transactions, along with the size of each transaction. " + , "\n " + , "The list must not be longer than the maximum number requested. " + , "\n " + , "In the 'StTxIds' 'StBlocking' state the list must be non-empty while " + , "in the 'StTxIds' 'StNonBlocking' state the list may be empty. " + , "\n " + , "These transactions are added to the notional FIFO of outstanding " + , "transaction identifiers for the protocol. " + , "\n " + , "The order in which these transaction identifiers are returned must be " + , "the order in which they are submitted to the mempool, to preserve " + , "dependent transactions." + ] + documentFor (Namespace _ ["RequestTxs"]) = Just $ mconcat + [ "Request one or more transactions corresponding to the given " + , "transaction identifiers. " + , "\n " + , "While it is the responsibility of the replying peer to keep within " + , "pipelining in-flight limits, the sender must also cooperate by keeping " + , "the total requested across all in-flight requests within the limits. " + , "\n" + , "It is an error to ask for transaction identifiers that were not " + , "previously announced (via 'MsgReplyTxIds'). " + , "\n" + , "It is an error to ask for transaction identifiers that are not " + , "outstanding or that were already asked for." + ] + documentFor (Namespace _ ["ReplyTxs"]) = Just $ mconcat + [ "Reply with the requested transactions, or implicitly discard." + , "\n" + , "Transactions can become invalid between the time the transaction " + , "identifier was sent and the transaction being requested. Invalid " + , "(including committed) transactions do not need to be sent." + , "\n" + , "Any transaction identifiers requested but not provided in this reply " + , "should be considered as if this peer had never announced them. (Note " + , "that this is no guarantee that the transaction is invalid, it may still " + , "be valid and available from another peer)." + ] + documentFor (Namespace _ ["Done"]) = Just $ mconcat + [ "Termination message, initiated by the client when the server is " + , "making a blocking call for more transaction identifiers." + ] + documentFor _ = Nothing + + allNamespaces = [ + Namespace [] ["MsgInit"] + , Namespace [] ["RequestTxIds"] + , Namespace [] ["ReplyTxIds"] + , Namespace [] ["RequestTxs"] + , Namespace [] ["ReplyTxs"] + , Namespace [] ["Done"] + ] + +-- Copied instances: from cardano-node NodeToNode.hs +-------------------------------------------------------------------------------- +-- KeepAlive Tracer +-------------------------------------------------------------------------------- + +instance LogFormatting (AnyMessage KA.KeepAlive) where + forMachine _dtal (AnyMessageAndAgency stok KA.MsgKeepAlive {}) = + mconcat + [ "kind" .= String "KeepAlive" + , "agency" .= String (pack $ show stok) + ] + forMachine _dtal (AnyMessageAndAgency stok KA.MsgKeepAliveResponse {}) = + mconcat + [ "kind" .= String "KeepAliveResponse" + , "agency" .= String (pack $ show stok) + ] + forMachine _dtal (AnyMessageAndAgency stok KA.MsgDone) = + mconcat + [ "kind" .= String "Done" + , "agency" .= String (pack $ show stok) + ] + +instance MetaTrace (AnyMessage KA.KeepAlive) where + namespaceFor (AnyMessageAndAgency _stok KA.MsgKeepAlive {}) = + Namespace [] ["KeepAlive"] + namespaceFor (AnyMessageAndAgency _stok KA.MsgKeepAliveResponse {}) = + Namespace [] ["KeepAliveResponse"] + namespaceFor (AnyMessageAndAgency _stok KA.MsgDone) = + Namespace [] ["Done"] + + severityFor (Namespace _ ["KeepAlive"]) _ = Just Debug + severityFor (Namespace _ ["KeepAliveResponse"]) _ = Just Debug + severityFor (Namespace _ ["Done"]) _ = Just Debug + severityFor _ _ = Nothing + + documentFor (Namespace _ ["KeepAlive"]) = Just + "Client side message to keep the connection alive." + documentFor (Namespace _ ["KeepAliveResponse"]) = Just $ mconcat + [ "Server side response to a previous client KeepAlive message." + ] + documentFor (Namespace _ ["Done"]) = Just $ mconcat + [ "Termination message, initiated by the client." + ] + documentFor _ = Nothing + + allNamespaces = [ + Namespace [] ["KeepAlive"] + , Namespace [] ["KeepAliveResponse"] + , Namespace [] ["Done"] + ] diff --git a/bench/tx-centrifuge/lib/tx-centrifuge/Cardano/Benchmarking/TxCentrifuge/TxAssembly.hs b/bench/tx-centrifuge/lib/tx-centrifuge/Cardano/Benchmarking/TxCentrifuge/TxAssembly.hs new file mode 100644 index 00000000000..06fb7efdff7 --- /dev/null +++ b/bench/tx-centrifuge/lib/tx-centrifuge/Cardano/Benchmarking/TxCentrifuge/TxAssembly.hs @@ -0,0 +1,192 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-------------------------------------------------------------------------------- + +module Cardano.Benchmarking.TxCentrifuge.TxAssembly + ( buildTx + , BuildError (..) + ) where + +-------------------------------------------------------------------------------- + +---------- +-- base -- +---------- +import Data.Function ((&)) +import Data.List (nubBy) +import Numeric.Natural (Natural) +----------------- +-- cardano-api -- +----------------- +import Cardano.Api qualified as Api +------------------------- +-- cardano-ledger-core -- +------------------------- +import Cardano.Ledger.Coin qualified as L +------------------- +-- tx-centrifuge -- +------------------- +import Cardano.Benchmarking.TxCentrifuge.Fund ( Fund(..) ) + +-------------------------------------------------------------------------------- + +-- | Why 'buildTx' could not produce a transaction. The caller uses the +-- distinction to decide whether to recover or fail. 'InsufficientValue' is a +-- per-batch condition (these particular inputs are too small), so dropping the +-- batch and trying the next is correct. 'InvalidInput' (a bad argument) and +-- 'LedgerFailure' (an opaque ledger rejection) do not depend on the inputs, so +-- they are constant across batches and must surface loudly instead of retried. +data BuildError + = -- | The function was called with invalid arguments: no input funds, zero + -- outputs, or a negative fee. Precondition violations known immediately + -- from the arguments (and guarded upstream in 'interpretBuilder'), so + -- reaching one is a caller or config bug, not a recoverable per-batch + -- condition. + InvalidInput !String + | -- | The input funds cannot cover the fee plus one valid (non-zero) output + -- each: the change is at or below zero, or too small to split into + -- @numOutputs@ outputs. A per-batch condition that depends on the specific + -- inputs, so the caller can drop this batch and try the next. + InsufficientValue !String + | -- | The ledger rejected the transaction in 'Api.createTransactionBody'. + -- Internal to cardano-api and opaque to us, and constant across batches for + -- our fixed tx shape, so it must surface loudly rather than be retried. + LedgerFailure !String + deriving Show + +-- | Build and sign a transaction consuming the given funds and producing +-- @numOutputs@ outputs to @destAddr@. Returns the signed transaction and +-- recycled funds (one per output, keyed with @outKey@ for future spending). +-- +-- Signing keys are extracted from the input funds. If inputs belong to +-- different keys, all unique keys are used as witnesses. +-- +-- Era-generic: the caller passes the target 'Api.ShelleyBasedEra', so the same +-- code builds transactions in any Shelley-based era. +-- No Plutus, no metadata, fixed fee. +buildTx + -- | Target era (also fixes the address and output transaction types). + :: forall era. Api.ShelleyBasedEra era + -- | Destination address for outputs (embeds the network identifier). + -> Api.AddressInEra era + -- | Signing key for recycled output funds. + -> Api.SigningKey Api.PaymentKey + -- | Input funds. + -> [Fund] + -- | Number of outputs. + -> Natural + -- | Fee. + -> L.Coin + -> Either BuildError (Api.Tx era, [Fund]) +buildTx sbe destAddr outKey inFunds numOutputs fee + | null inFunds = Left (InvalidInput "no input funds") + | numOutputs == 0 = Left (InvalidInput "outputs_per_tx must be >= 1") + | feeLovelace < 0 = Left (InvalidInput "fee must be >= 0") + | changeTotal <= 0 = Left $ InsufficientValue $ + "total inputs (" ++ show totalIn ++ " lovelace) do not cover fee (" + ++ show feeLovelace ++ " lovelace)" + -- Guard against outputs that would be below the Cardano minimum UTxO + -- value. We cannot check the actual protocol-parameter minimum here (it + -- depends on the serialised output size and the current coinsPerUTxOByte), + -- but we can catch the obviously-invalid case where integer division + -- produces zero-value or negative outputs. A real minimum UTxO check + -- should be added once the protocol parameters are threaded through to this + -- function. + | minOutputLovelace <= 0 = Left $ InsufficientValue $ + show numOutputs ++ " outputs from " ++ show changeTotal + ++ " lovelace change yields " ++ show minOutputLovelace + ++ " lovelace per output" + | otherwise = + let maybeTxBody = Api.createTransactionBody sbe txBodyContent + in case maybeTxBody of + Left err -> + Left (LedgerFailure ("createTransactionBody: " ++ show err)) + Right txBody -> + let signedTx = Api.signShelleyTransaction + sbe + txBody + (map Api.WitnessPaymentKey uniqueKeys) + txId = Api.getTxId txBody + outFunds = [ Fund { fundTxIn = Api.TxIn txId (Api.TxIx ix) + , fundValue = amt + , fundSignKey = outKey + } + | (ix, amt) <- zip [0..] outAmounts + ] + in Right (signedTx, outFunds) + where + + totalIn :: Integer + totalIn = sum (map fundValue inFunds) + + feeLovelace :: Integer + feeLovelace = let L.Coin c = fee in c + + changeTotal :: Integer + changeTotal = totalIn - feeLovelace + + -- Minimum per-output lovelace amount (used for the zero-value guard above). + minOutputLovelace :: Integer + minOutputLovelace = changeTotal `div` fromIntegral numOutputs + + -- Split change evenly; first output absorbs the remainder. + outAmounts :: [Integer] + outAmounts = + let base = changeTotal `div` fromIntegral numOutputs + remainder = changeTotal `mod` fromIntegral numOutputs + in (base + remainder) : replicate (fromIntegral numOutputs - 1) base + + -- Unique signing keys from input funds (deduplicated by verification key + -- hash). After recycling, all inputs share the builder's single key, so + -- this produces 1 witness instead of N, making steady-state transactions + -- smaller than the initial batch (e.g. 270 vs 371 bytes for 2-in/2-out). + uniqueKeys :: [Api.SigningKey Api.PaymentKey] + uniqueKeys = nubBy sameKey (map fundSignKey inFunds) + where + sameKey + :: Api.SigningKey Api.PaymentKey + -> Api.SigningKey Api.PaymentKey + -> Bool + sameKey a b = Api.verificationKeyHash (Api.getVerificationKey a) + == Api.verificationKeyHash (Api.getVerificationKey b) + + txIns + :: [ ( Api.TxIn + , Api.BuildTxWith Api.BuildTx + (Api.Witness Api.WitCtxTxIn era) + ) + ] + txIns = map + (\f -> + ( fundTxIn f + , Api.BuildTxWith + (Api.KeyWitness Api.KeyWitnessForSpending) + ) + ) inFunds + + mkTxOut :: Integer -> Api.TxOut Api.CtxTx era + mkTxOut lovelace = Api.TxOut + destAddr + (Api.lovelaceToTxOutValue sbe (Api.Coin lovelace)) + Api.TxOutDatumNone + Api.ReferenceScriptNone + + txBodyContent :: Api.TxBodyContent Api.BuildTx era + txBodyContent = Api.defaultTxBodyContent sbe + & Api.setTxIns txIns + & Api.setTxInsCollateral Api.TxInsCollateralNone + & Api.setTxOuts (map mkTxOut outAmounts) + & Api.setTxFee + ( Api.TxFeeExplicit + sbe + (Api.Coin feeLovelace) + ) + & Api.setTxValidityLowerBound Api.TxValidityNoLowerBound + & Api.setTxValidityUpperBound + ( Api.defaultTxValidityUpperBound sbe ) + & Api.setTxMetadata Api.TxMetadataNone + -- We are using an explicit fee! + -- Using `Nothing` instead of `ledgerPP :: Api.LedgerProtocolParameters era`. + -- TODO: Will need something else for plutus scripts! + & Api.setTxProtocolParams (Api.BuildTxWith Nothing) diff --git a/bench/tx-centrifuge/test/lib/Test/PullFiction/Harness.hs b/bench/tx-centrifuge/test/lib/Test/PullFiction/Harness.hs new file mode 100644 index 00000000000..42871986cd4 --- /dev/null +++ b/bench/tx-centrifuge/test/lib/Test/PullFiction/Harness.hs @@ -0,0 +1,524 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE NumericUnderscores #-} + + +-------------------------------------------------------------------------------- + +module Test.PullFiction.Harness + ( -- * Test results + TestResult(..) + -- * Naming helpers + , targetName + , nodeName + -- * Running tests + , resolveConfig + , loadConfig + , runTest + , runTpsTest + , runPipelineIsolationTest + -- * Metrics & formatting + , getDuration + , formatMetrics + , formatDuration + -- * Assertions (pure) + , checkElapsedTolerance + , checkTpsTolerance + , checkTargetFairness + ) where + +-------------------------------------------------------------------------------- + +---------- +-- base -- +---------- +import Control.Concurrent (threadDelay) +import Control.Exception (onException, throwIO) +import Control.Monad (forever, when) +import Data.IORef qualified as IORef +import Data.List (intercalate) +import Data.List.NonEmpty qualified as NE +import System.Environment (lookupEnv) +import Text.Read (readMaybe) +----------- +-- aeson -- +----------- +import Data.Aeson qualified as Aeson +----------- +-- async -- +----------- +import Control.Concurrent.Async qualified as Async +----------- +-- clock -- +----------- +-- NOTE: System.Clock is used directly here (rather than PullFiction.Clock) +-- intentionally. The harness measures overall test wall-clock time, which is +-- independent of the rate-limiter's internal clock. Keeping them separate +-- ensures that test timing cannot be influenced by any future changes to +-- PullFiction.Clock. +import System.Clock qualified as Clock +---------------- +-- containers -- +---------------- +import Data.Map.Strict qualified as Map +--------------------- +-- pull-fiction -- +--------------------- +import Cardano.Benchmarking.PullFiction.Config.Runtime qualified as Runtime +import Cardano.Benchmarking.PullFiction.Config.Validated qualified as Validated +import Cardano.Benchmarking.PullFiction.WorkloadRunner (runWorkload) + +-------------------------------------------------------------------------------- + +-- | Aggregate results from a TPS test run. +data TestResult = TestResult + { -- | Wall-clock time the test actually ran. + elapsedSeconds :: !Double + -- | Actual token count per target, keyed by target name. + , targetCounts :: !(Map.Map String Int) + } deriving (Show) + +-------------------------------------------------------------------------------- +-- Naming helpers +-------------------------------------------------------------------------------- + +-- | Qualified target name: @\"workload\/target\"@. This is the key format used +-- by 'runTpsTest' for per-target counters. +targetName :: String -> String -> String +targetName workload target = workload ++ "/" ++ target + +-- | Node name matching the config's @\"node-NN\"@ zero-padded naming scheme +-- (e.g. @\"node-01\"@, @\"node-50\"@). +nodeName :: Int -> String +nodeName i = "node-" ++ (if i < 10 then "0" else "") ++ show i + +-------------------------------------------------------------------------------- +-- Running tests +-------------------------------------------------------------------------------- + +-- | Decode a JSON config with pre-built inputs and resolve into a +-- 'Runtime.Runtime'. +-- +-- This is the common entry point for tests that need a resolved pipeline. +-- Uses a trivial builder (1 input per batch; the input itself is the payload) +-- so the pipeline exercises rate limiting and recycling without real +-- transaction building. 'loadConfig' is a thin wrapper for the common case +-- of @()@ inputs. +resolveConfig :: FilePath -> NE.NonEmpty input -> IO (Runtime.Runtime Int input input) +resolveConfig path inputs = do + raw <- Aeson.eitherDecodeFileStrict path >>= either fail pure + validated <- either fail pure $ Validated.validate raw inputs + -- Unique per-payload key (a plain counter). The recycler keys its backlog + -- by it, so each in-flight payload must have a distinct key (see the + -- INVARIANT on 'Internal.Recycler'); one shared atomic counter keeps them + -- unique. + keyCounter <- IORef.newIORef (0 :: Int) + Runtime.resolve + -- mkBuilder: 1 input per batch; input IS the payload; recycle the same + -- input as output. Each payload gets a fresh, unique key from the counter. + (\_ _ _ -> pure $ Runtime.BuilderHandle $ \api -> forever $ do + is <- Runtime.baTakeInputs api 1 + key <- IORef.atomicModifyIORef' keyCounter (\n -> (n + 1, n)) + Runtime.baAddPayload api key (head is) is is) + -- mkPipeHandle: no-op trace handlers. + (\_ _ -> pure Runtime.PipeHandle + { Runtime.phOnInputsEnqueued = \_ _ -> pure () + , Runtime.phOnInputsDequeued = \_ _ -> pure () + , Runtime.phOnPayloadEnqueued = \_ _ -> pure () + , Runtime.phOnPayloadDequeued = \_ _ -> pure () + }) + -- mkRecyclerHandle: no-op recycle handler. + (\_ _ -> pure Runtime.RecyclerHandle + { Runtime.rhOnAddToBacklog = \_ _ _ _ -> pure () + , Runtime.rhOnAddToPipe = \_ _ -> pure () + , Runtime.rhOnReset = \_ _ _ _ -> pure () + , Runtime.rhRecover = Nothing + }) + -- mkObserver: no test config uses observers. + (\_ name _ -> fail $ "resolveConfig: unexpected observer: " ++ name) + validated + +-- | Load a generator config from a JSON file with dummy inputs and resolve into +-- a 'Runtime.Runtime'. +-- +-- Useful for tests that only need config metadata (rate limits, targets) and do +-- not use the input pipeline. +loadConfig :: FilePath -> IO (Runtime.Runtime Int () ()) +loadConfig path = resolveConfig path (() NE.:| []) + +-- | Run the pipeline scaffolding shared by all test runners. +-- +-- 'Runtime.resolve' has already spawned a builder async per workload (each +-- reads from the input queue, produces payloads, and enqueues them) and loaded +-- initial inputs. This function spawns workers via 'runWorkload', races +-- them against the configured duration, then cancels all asyncs (builders and +-- workers). +-- +-- @payload = input@ — the builder treats the input itself as the payload. +runTest + :: Runtime.Runtime Int input input + -> Double -- ^ Duration in seconds. + -> (Runtime.Workload Int input input -- ^ Workload the worker belongs to. + -> Runtime.Target Int input input -- ^ Target the worker serves. + -> IO input -- ^ Blocking fetch (rate-limited). + -> IO (Maybe input) -- ^ Non-blocking fetch. + -> IO () -- ^ Worker body. + ) + -> IO Double -- ^ Elapsed wall-clock seconds. +runTest runtime durationSecs workerBody = do + let allWorkloads = Map.elems (Runtime.workloads runtime) + -- Start time. + start <- Clock.getTime Clock.MonotonicRaw + -- Spawn workers via runWorkload, passing the caller-supplied callbacks. + -- Runtime asyncs (builders, recyclers) are already running. + workers <- concat <$> mapM + (\workload -> runWorkload workload $ + \target fetchPayload tryFetchPayload -> workerBody workload target fetchPayload tryFetchPayload + ) + allWorkloads + -- Race the test duration against any async dying. Exceptions are thrown + -- synchronously (not via Async.link) so Tasty's withResource can properly + -- cache and propagate them to all test cases in the group. + let allAsyncs = Runtime.asyncs runtime ++ workers + cancelAll = mapM_ Async.cancel allAsyncs + winner <- Async.race + (threadDelay (round (durationSecs * 1_000_000))) + (Async.waitAnyCatch allAsyncs) + `onException` cancelAll + -- End time. + end <- Clock.getTime Clock.MonotonicRaw + cancelAll + case winner of + Right (_, Left ex) -> throwIO ex + _ -> pure () + -- Return with the elapsed time. + pure $ fromIntegral (Clock.toNanoSecs (end - start)) / 1e9 + +-- | Decode a JSON config, create @()@ inputs, resolve into a +-- 'Runtime.Runtime', then run the pipeline, collecting per-target token +-- counts. +-- +-- The pipeline is trivial: a builder thread reads @()@ from the input queue +-- and writes @((), [()])@ to the payload queue; 'runWorkload' handles rate +-- limiting and input recycling; the worker callback just increments a +-- per-target counter. +-- +-- The caller is responsible for checking the returned 'TestResult' against its +-- own expected TPS map via 'checkTpsTolerance', 'checkTargetFairness', etc. +runTpsTest + -- | Path to the JSON config file. + :: FilePath + -- | Test duration in seconds. + -> Double + -> IO TestResult +runTpsTest configPath durationSecs = do + runtime <- resolveConfig configPath (() NE.:| replicate 99_999 ()) + -- Per-target counters keyed by "workloadName/targetName". + let allTargets = concatMap + (\wl -> map + (\rt -> + targetName (Runtime.workloadName wl) (Runtime.targetName rt) + ) + (Map.elems (Runtime.targets wl)) + ) + (Map.elems (Runtime.workloads runtime)) + counters <- Map.fromList <$> mapM + (\key -> do + ref <- IORef.newIORef (0 :: Int) + pure (key, ref) + ) + allTargets + -- Each worker calls fetchPayload in a loop, increments its counter, and + -- recycles the input back to the pipe for the builder to reuse. + elapsed <- runTest runtime durationSecs $ + \workload target fetchPayload _tryFetchPayload -> do + let key = targetName (Runtime.workloadName workload) + (Runtime.targetName target) + ref = counters Map.! key + forever $ do + _ <- fetchPayload + IORef.atomicModifyIORef' ref (\c -> (c + 1, ())) + -- Collect results. + perTarget <- Map.fromList <$> mapM + (\(key, ref) -> do + c <- IORef.readIORef ref + pure (key, c) + ) + (Map.toList counters) + -- Returns the map with the tokens per target. + pure TestResult + { elapsedSeconds = elapsed + , targetCounts = perTarget + } + +-- | Run a pipeline isolation test that verifies each workload's input recycling +-- loop is closed: inputs tagged for workload N are only ever observed by +-- workload N's workers, never by another workload. +-- +-- Inputs are @(Int, Int)@ tuples where the first element is the workload index +-- and the second is an input identifier within that workload. +-- 'Runtime.resolve' partitions inputs in ascending workload-key order, so +-- workload @i@ (0-based by key order) receives only inputs whose first element +-- is @i@. This also tests the partition logic itself. +-- +-- If any worker observes an input with a foreign workload tag, the test fails +-- immediately. Both 'fetchPayload' (blocking) and 'tryFetchPayload' +-- (non-blocking) paths are exercised on every iteration. +runPipelineIsolationTest + -- | Path to the JSON config file. + :: FilePath + -- | Number of workloads (must match config). + -> Int + -- | Test duration in seconds. + -> Double + -> IO () +runPipelineIsolationTest configPath nWorkloads durationSecs = do + let inputsPerWorkload = 2000 + taggedInputs = + [ (i, j) + | i <- [0 :: Int .. nWorkloads - 1] + , j <- [0 :: Int .. inputsPerWorkload - 1] + ] + inputs <- case taggedInputs of + (t:ts) -> pure (t NE.:| ts) + [] -> fail "runPipelineIsolationTest: nWorkloads must be >= 1" + runtime <- resolveConfig configPath inputs + -- Workloads are stored in a Map, so keys are ascending. + -- resolve partitions contiguous chunks in the same order. + let nameToTag = Map.fromList $ + zip (Map.keys (Runtime.workloads runtime)) [0 :: Int ..] + -- Workers: fetch payload (= input tag), assert it matches the workload. + -- fetchPayload and tryFetchPayload recycle consumed inputs automatically + -- (see 'TargetWorker'); the worker only checks the tag. Both blocking and + -- non-blocking paths are exercised on every iteration, verifying closed-loop + -- recycling in both code paths. + _ <- runTest runtime durationSecs $ + \workload _target fetchPayload tryFetchPayload -> do + let wlName = Runtime.workloadName workload + expectedTag = nameToTag Map.! wlName + check (wlIdx, _) = + when (wlIdx /= expectedTag) $ + fail $ "Input leakage: workload " ++ wlName + ++ " (tag " ++ show expectedTag + ++ ") received input tagged " ++ show wlIdx + forever $ do + tag <- fetchPayload + check tag + mTag <- tryFetchPayload + case mTag of + Nothing -> pure () + Just tag' -> check tag' + pure () + +-------------------------------------------------------------------------------- +-- Metrics & formatting +-------------------------------------------------------------------------------- + +-- | Default test duration in seconds +-- (overridable via PULL_FICTION_TEST_DURATION_SECS). +defaultDuration :: Double +defaultDuration = 60.0 + +-- | Read test duration from the @PULL_FICTION_TEST_DURATION_SECS@ environment +-- variable, falling back to 'defaultDuration' (60 s). +getDuration :: IO Double +getDuration = do + env <- lookupEnv "PULL_FICTION_TEST_DURATION_SECS" + pure $ maybe defaultDuration + (\s -> maybe defaultDuration id (readMaybe s)) env + +-- | Format a duration as a compact string for test group titles (e.g. @60.0@ +-- becomes @\"60s\"@, @5.0@ becomes @\"5s\"@). +formatDuration :: Double -> String +formatDuration d = show (round d :: Int) ++ "s" + +-- | Format a full metrics summary as a string. +-- Suitable for use as the result description in 'testCaseInfo'. +formatMetrics + :: Double -- ^ Configured test duration in seconds. + -> Map.Map String Double -- ^ Expected TPS per target. + -> TestResult -> String +formatMetrics cfgDuration expectedTps r = intercalate "\n" + [ "Global" + , " targets: " ++ show (Map.size (targetCounts r)) + , " duration: " ++ formatFixed 2 dur ++ " s" + ++ " (target " ++ formatFixed 0 cfgDuration + ++ " s, " ++ formatSignedPct durErr ++ "%)" + , " configured TPS: " ++ show (round cfgTps :: Int) + , " actual TPS: " ++ show (round actualTps :: Int) + ++ " (" ++ formatSignedPct tpsErr ++ "%)" + , " total tokens: " ++ show totalTokens + ++ " (expected " ++ show expected + ++ ", " ++ formatSignedPct tokenErr ++ "%)" + , "Per-target tokens" + , " mean: " ++ show (round tMean :: Int) + ++ biasT (round tMean :: Int) + , " min: " ++ show tMin ++ biasT tMin + , " max: " ++ show tMax ++ biasT tMax + , " spread (max-min): " ++ show tSpread + ++ " (" ++ formatFixed 1 tSpreadPct ++ "% of ideal)" + , " worst deviation: " ++ formatFixed 1 tWorstDev ++ "% from mean" + , " std deviation: " ++ show (round tStddev :: Int) + , " CV: " ++ formatFixed 2 tCv ++ "%" + , "Per-target TPS" + , " mean: " ++ formatFixed tpsDp sMean ++ biasS sMean + , " min: " ++ formatFixed tpsDp sMin ++ biasS sMin + , " max: " ++ formatFixed tpsDp sMax ++ biasS sMax + , " spread (max-min): " ++ formatFixed tpsDp sSpread + ++ " (" ++ formatFixed 1 sSpreadPct ++ "% of ideal)" + , " worst deviation: " ++ formatFixed 1 sWorstDev ++ "% from mean" + , " std deviation: " ++ formatFixed tpsDp sStddev + , " CV: " ++ formatFixed 2 sCv ++ "%" + ] + where + durErr = (elapsedSeconds r - cfgDuration) + / cfgDuration * 100 + totalTokens = sum (Map.elems (targetCounts r)) + cfgTps = sum (Map.elems expectedTps) + actualTps = fromIntegral totalTokens / elapsedSeconds r + tpsErr = (actualTps - cfgTps) / cfgTps * 100 + expected = round (cfgTps * elapsedSeconds r) :: Int + tokenErr = (fromIntegral totalTokens - fromIntegral expected) + / fromIntegral expected * 100 :: Double + counts = Map.elems (targetCounts r) + dur = elapsedSeconds r + n = fromIntegral (length counts) :: Double + -- Ideal per-target values (mean of expectedTps). + idealTps = sum (Map.elems expectedTps) + / fromIntegral (Map.size expectedTps) + idealTokens = idealTps * dur + -- Token stats + tMean = fromIntegral (sum counts) / n + tMin = minimum counts + tMax = maximum counts + tSpread = tMax - tMin + tSpreadPct = fromIntegral tSpread / idealTokens * 100 + tWorstDev = maximum + (map (\c -> abs (fromIntegral c - tMean) + / tMean) counts) * 100 + tVariance = sum (map (\c -> (fromIntegral c - tMean) ** 2) counts) / n + tStddev = sqrt tVariance + tCv = tStddev / tMean * 100 + biasT v = let d = fromIntegral v - idealTokens + p' = d / idealTokens * 100 + in " (ideal " ++ show (round idealTokens :: Int) + ++ ", " ++ formatSignedPct p' ++ "%)" + -- TPS stats (tokens / duration per target) + tpsList = map (\c -> fromIntegral c / dur) counts :: [Double] + sMean = sum tpsList / n + sMin = minimum tpsList + sMax = maximum tpsList + sSpread = sMax - sMin + sSpreadPct = sSpread / idealTps * 100 + sWorstDev = maximum (map (\s -> abs (s - sMean) / sMean) tpsList) * 100 + sVariance = sum (map (\s -> (s - sMean) ** 2) tpsList) / n + sStddev = sqrt sVariance + sCv = sStddev / sMean * 100 + -- Decimal places: use 0 when per-target TPS >= 1, otherwise enough to show + -- the leading significant digit plus one extra for resolution (e.g. 0.2 + -- TPS -> 2 dp so min/max/spread are distinguishable). + tpsDp = if idealTps >= 1 then 0 + else max 1 (ceiling (negate (logBase 10 idealTps)) + 1 :: Int) + biasS v = let d = v - idealTps + p' = d / idealTps * 100 + in " (ideal " ++ formatFixed tpsDp idealTps + ++ ", " ++ formatSignedPct p' ++ "%)" + +-- | Format a 'Double' with exactly @n@ decimal places, rounding half-up. +-- +-- >>> formatFixed 2 3.1415 +-- "3.14" +-- >>> formatFixed 0 99.7 +-- "100" +formatFixed :: Int -> Double -> String +formatFixed 0 x = show (round x :: Int) +formatFixed decimals x = + let factor = 10 ^ decimals :: Int + scaled = round (x * fromIntegral factor) :: Int + (whole, frac) = scaled `quotRem` factor + fracStr = let s = show (abs frac) + in replicate (decimals - length s) '0' ++ s + in (if x < 0 && whole == 0 then "-" else "") ++ show whole ++ "." ++ fracStr + +-- | Format a percentage value with a leading sign (@+@ or @-@) and one decimal +-- place. Used in metrics output to show relative deviations. +-- +-- >>> formatSignedPct 3.14 +-- "+3.1" +-- >>> formatSignedPct (-0.5) +-- "-0.5" +formatSignedPct :: Double -> String +formatSignedPct x = (if x >= 0 then "+" else "") ++ formatFixed 1 x + +-------------------------------------------------------------------------------- +-- Assertions (pure) +-------------------------------------------------------------------------------- + +-- | Check that the elapsed wall-clock time is within the given relative +-- tolerance of the configured duration. Returns 'Nothing' on success, or 'Just' +-- an error message on failure. +-- +-- A test that overshoots significantly (e.g. 231s vs 60s) indicates that the +-- rate-limiting mechanism cannot keep up: the feeder loop overhead exceeds the +-- target inter-tick delay. +checkElapsedTolerance + :: Double -- ^ Tolerance (e.g. 0.05 for 5%). + -> Double -- ^ Configured test duration in seconds. + -> TestResult -> Maybe String +checkElapsedTolerance tolerance cfgDuration result + | abs pctErr / 100 <= tolerance = Nothing + | otherwise = Just $ + "elapsed " ++ formatFixed 1 actual ++ " s (" + ++ (if pctErr >= 0 then "+" else "") ++ show (round pctErr :: Int) + ++ "%) vs target " ++ formatFixed 0 cfgDuration ++ " s" + where + actual = elapsedSeconds result + pctErr = (actual - cfgDuration) / cfgDuration * 100 + +-- | Check that actual TPS is within the given relative tolerance of configured +-- TPS. Returns 'Nothing' on success, or 'Just' an error message on failure. +checkTpsTolerance + :: Double -- ^ Tolerance (e.g. 0.05 for 5%). + -> Map.Map String Double -- ^ Expected TPS per target. + -> TestResult -> Maybe String +checkTpsTolerance tolerance expectedTps result + | abs pctErr / 100 <= tolerance = Nothing + | otherwise = Just $ + "actual " ++ show (round actualTps :: Int) ++ " TPS (" + ++ (if pctErr >= 0 then "+" else "") ++ show (round pctErr :: Int) + ++ "%) vs target " ++ show (round cfgTps :: Int) + where + totalTokens = sum (Map.elems (targetCounts result)) + cfgTps = sum (Map.elems expectedTps) + actualTps = fromIntegral totalTokens / elapsedSeconds result + pctErr = (actualTps - cfgTps) / cfgTps * 100 + +-- | Check a single target's token count against its expected TPS. Returns +-- 'Nothing' on success, or 'Just' an error message on failure. +-- +-- Applies a per-target discrete-distribution continuity correction: the actual +-- token count is an integer, so even a perfect system deviates from a +-- non-integer expected count by at least the rounding distance. We subtract +-- this /quantization floor/ so that the tolerance measures only the /excess/ +-- deviation attributable to the scheduling algorithm, not to integer +-- arithmetic. +checkTargetFairness + :: Double -- ^ Tolerance (e.g. 0.10 for 10%). + -> Map.Map String Double -- ^ Expected TPS per target. + -> TestResult -> String -> Maybe String +checkTargetFairness tolerance expectedTps result name + | excessDev <= tolerance = Nothing + | otherwise = Just $ + show (round (dev * 100) :: Int) ++ "% from expected " + ++ show (round expectedCount :: Int) + ++ " (actual " ++ show actual ++ ")" + where + actual = Map.findWithDefault 0 name (targetCounts result) + elapsed = elapsedSeconds result + eTps = Map.findWithDefault 0 name expectedTps + expectedCount = eTps * elapsed + dev = abs (fromIntegral actual - expectedCount) / expectedCount + frac = expectedCount - fromIntegral (floor expectedCount :: Int) + qFloor + | frac == 0 = 0 + | otherwise = min frac (1 - frac) / expectedCount + excessDev = max 0 (dev - qFloor) diff --git a/bench/tx-centrifuge/test/pull-fiction/Main.hs b/bench/tx-centrifuge/test/pull-fiction/Main.hs new file mode 100644 index 00000000000..94717d6e689 --- /dev/null +++ b/bench/tx-centrifuge/test/pull-fiction/Main.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE ImportQualifiedPost #-} + +module Main where + +----------- +-- tasty -- +----------- +import Test.Tasty qualified as Tasty +import Test.Tasty.Runners qualified as Tasty +--------------------- +-- pull-fiction -- +--------------------- +import Test.PullFiction.GeneratorTest qualified as GeneratorTest +import Test.PullFiction.Harness qualified as Harness +import Test.PullFiction.PipelineTest qualified as PipelineTest + +main :: IO () +main = do + dur <- Harness.getDuration + Tasty.defaultMain + $ Tasty.localOption (Tasty.NumThreads 1) + $ Tasty.testGroup "pull-fiction" + [ GeneratorTest.generatorTests dur + , PipelineTest.pipelineTests dur + ] diff --git a/bench/tx-centrifuge/test/pull-fiction/Test/PullFiction/GeneratorTest.hs b/bench/tx-centrifuge/test/pull-fiction/Test/PullFiction/GeneratorTest.hs new file mode 100644 index 00000000000..2a29d181916 --- /dev/null +++ b/bench/tx-centrifuge/test/pull-fiction/Test/PullFiction/GeneratorTest.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE NumericUnderscores #-} + +-------------------------------------------------------------------------------- + +module Test.PullFiction.GeneratorTest + ( generatorTests + ) where + +-------------------------------------------------------------------------------- + +---------------- +-- containers -- +---------------- +import Data.Map.Strict qualified as Map +----------- +-- tasty -- +----------- +import Test.Tasty qualified as Tasty +----------------- +-- tasty-hunit -- +----------------- +import Test.Tasty.HUnit qualified as HUnit +--------------------- +-- pull-fiction -- +--------------------- +import Paths_tx_centrifuge qualified as Paths +import Test.PullFiction.Harness qualified as Harness + +-------------------------------------------------------------------------------- + +generatorTests :: Double -> Tasty.TestTree +generatorTests duration = Tasty.testGroup "TPS" + [ -- A "shared" global rate limiter. + tpsTestGroup "Shared-limiter mode (50 targets, 10 TPS)" + "data/config-shared-10.json" + (Map.fromList + [ (Harness.targetName "default" (Harness.nodeName i), 0.2) + | i <- [1..50] + ] + ) + duration + 0.05 + 0.15 + , tpsTestGroup "Shared-limiter mode (50 targets, 100k TPS)" + "data/config-shared-100k.json" + (Map.fromList + [ (Harness.targetName "default" (Harness.nodeName i), 2_000) + | i <- [1..50] + ] + ) + duration + 0.05 + 0.15 + -- A "per_target" scoped rate limiter. Lower per-target tolerance. + , tpsTestGroup "Per-target-limiter mode (50 targets, 0.2 TPS/target)" + "data/config-per-target-0_2.json" + (Map.fromList + [ (Harness.targetName "default" (Harness.nodeName i), 0.20) + | i <- [1..50] + ] + ) + duration + 0.05 + 0.05 + , tpsTestGroup "Per-target-limiter mode (50 targets, 2k TPS/target)" + "data/config-per-target-2k.json" + (Map.fromList + [(Harness.targetName "default" (Harness.nodeName i), 2_000) + | i <- [1..50] + ] + ) + duration + 0.05 + 0.05 + ] + +tpsTestGroup + :: String -- ^ Test group label (duration is appended). + -> String -- ^ Data-file config name. + -> Map.Map String Double -- ^ Expected TPS per target, keyed by name. + -> Double -- ^ Test duration in seconds. + -> Double -- ^ Global TPS tolerance. + -> Double -- ^ Per-target fairness tolerance. + -> Tasty.TestTree +tpsTestGroup label configName expectedMap duration globalTol fairnessTol = + Tasty.withResource + (do path <- Paths.getDataFileName configName + Harness.runTpsTest path duration + ) + (const $ pure ()) + $ \getResult -> + Tasty.testGroup + (label ++ " " ++ Harness.formatDuration duration) + [ -- Total elapsed time. + HUnit.testCase + ("Elapsed time within " + ++ show (round (globalTol * 100) :: Int) ++ "% of target" + ) $ do + result <- getResult + case Harness.checkElapsedTolerance globalTol duration result of + Nothing -> pure () + Just err -> HUnit.assertFailure err + -- Total TPS. + , HUnit.testCaseInfo + ("Global TPS within " + ++ show (round (globalTol * 100) :: Int) ++ "% tolerance" + ) $ do + result <- getResult + let metrics = Harness.formatMetrics duration expectedMap result + case Harness.checkTpsTolerance globalTol expectedMap result of + Nothing -> pure metrics + Just err -> HUnit.assertFailure + (err ++ "\n" ++ metrics) + -- TPS per target. + , Tasty.testGroup + ("Per-target TPS within " + ++ show (round (fairnessTol * 100) :: Int) ++ "% of expected" + ) + [ HUnit.testCase name $ do + result <- getResult + case Harness.checkTargetFairness fairnessTol expectedMap result name of + Nothing -> pure () + Just err -> HUnit.assertFailure err + | name <- Map.keys expectedMap + ] + ] diff --git a/bench/tx-centrifuge/test/pull-fiction/Test/PullFiction/PipelineTest.hs b/bench/tx-centrifuge/test/pull-fiction/Test/PullFiction/PipelineTest.hs new file mode 100644 index 00000000000..6140aa30a86 --- /dev/null +++ b/bench/tx-centrifuge/test/pull-fiction/Test/PullFiction/PipelineTest.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE ImportQualifiedPost #-} + +-------------------------------------------------------------------------------- + +module Test.PullFiction.PipelineTest + ( pipelineTests + ) where + +-------------------------------------------------------------------------------- + +----------- +-- tasty -- +----------- +import Test.Tasty qualified as Tasty +----------------- +-- tasty-hunit -- +----------------- +import Test.Tasty.HUnit qualified as HUnit +--------------------- +-- pull-fiction -- +--------------------- +import Paths_tx_centrifuge qualified as Paths +import Test.PullFiction.Harness qualified as Harness + +-------------------------------------------------------------------------------- + +pipelineTests :: Double -> Tasty.TestTree +pipelineTests dur = Tasty.testGroup "pipeline" + [ + -- Pipeline test 1: single-group, per-group input queue. + -- ------------------------------------------------- + -- + -- 1 workload with 50 targets sharing one input queue. Recycled inputs + -- return to the same queue. Exercises Runtime.resolve with 1 workload, + -- verifying that closed-loop recycling delivers tokens to every target and + -- inputs stay within the workload. + + HUnit.testCase + ("Single-group pipeline (50 targets, " ++ Harness.formatDuration dur ++ ")") $ do + path <- Paths.getDataFileName "data/config-per-target-0_2.json" + Harness.runPipelineIsolationTest path 1 dur + + -- Pipeline test 2: multi-group, per-group input queues. + -- ---------------------------------------------------- + -- + -- 50 workloads, each with 1 target at 1 TPS (50 TPS aggregate). + -- Each workload has its own input queue; recycled inputs must return to the + -- originating workload's queue and never leak to another group. + -- + -- Inputs are tagged with (workloadIndex, inputIndex) tuples. If any worker + -- ever observes an input with a foreign workload tag, the test fails + -- immediately. This also exercises resolve's partition logic. + + , HUnit.testCase + "Multi-group pipeline isolation (50 groups x 1 TPS, 10s)" $ do + path <- Paths.getDataFileName "data/config-multi-group.json" + Harness.runPipelineIsolationTest path 50 10 + + ] diff --git a/bench/tx-centrifuge/test/tx-centrifuge/Main.hs b/bench/tx-centrifuge/test/tx-centrifuge/Main.hs new file mode 100644 index 00000000000..3c0c71bd929 --- /dev/null +++ b/bench/tx-centrifuge/test/tx-centrifuge/Main.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE ImportQualifiedPost #-} + +module Main where + +----------- +-- tasty -- +----------- +import Test.Tasty qualified as Tasty +--------------------- +-- tx-centrifuge -- +--------------------- +import Test.TxCentrifuge.TxTest qualified as TxTest + +main :: IO () +main = Tasty.defaultMain $ Tasty.testGroup "tx-centrifuge" + [ TxTest.txTests + ] diff --git a/bench/tx-centrifuge/test/tx-centrifuge/Test/TxCentrifuge/TxTest.hs b/bench/tx-centrifuge/test/tx-centrifuge/Test/TxCentrifuge/TxTest.hs new file mode 100644 index 00000000000..7af14d48987 --- /dev/null +++ b/bench/tx-centrifuge/test/tx-centrifuge/Test/TxCentrifuge/TxTest.hs @@ -0,0 +1,223 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +-------------------------------------------------------------------------------- + +module Test.TxCentrifuge.TxTest + ( txTests + , testSetup + , mkDummyFund + ) where + +-------------------------------------------------------------------------------- + +---------- +-- base -- +---------- +import System.IO (hFlush, hPutStrLn, stderr) +----------- +-- aeson -- +----------- +import Data.Aeson qualified as Aeson +----------------- +-- cardano-api -- +----------------- +import Cardano.Api qualified as Api +------------------------- +-- cardano-ledger-core -- +------------------------- +import Cardano.Ledger.Coin qualified as L +----------- +-- clock -- +----------- +import System.Clock qualified as Clock +----------- +-- tasty -- +----------- +import Test.Tasty qualified as Tasty +----------------- +-- tasty-hunit -- +----------------- +import Test.Tasty.HUnit ((@?=)) +import Test.Tasty.HUnit qualified as HUnit +------------------ +-- tx-generator -- +------------------ +import Cardano.TxGenerator.ProtocolParameters qualified as PP +--------------------- +-- tx-centrifuge -- +--------------------- +import Cardano.Benchmarking.TxCentrifuge.Fund qualified as Fund +import Cardano.Benchmarking.TxCentrifuge.TxAssembly qualified as TxAssembly +import Paths_tx_centrifuge qualified as Paths + +-------------------------------------------------------------------------------- + +txTests :: Tasty.TestTree +txTests = Tasty.testGroup "node" + [ HUnit.testCase "buildTx: simple 1-in-1-out transaction" $ do + (_ledgerPP, signKey, addr) <- testSetup + let fund = mkDummyFund signKey 0 10_000_000 + fee = L.Coin 200_000 + case TxAssembly.buildTx Api.ShelleyBasedEraConway {-- ledgerPP --} addr signKey [fund] 1 fee of + Left err -> + HUnit.assertFailure $ "buildTx failed: " ++ show err + Right (tx, outFunds) -> do + -- One output fund recycled. + length outFunds @?= 1 + -- Output value = input - fee. + Fund.fundValue (head outFunds) @?= (10_000_000 - 200_000) + -- The recycled fund's TxIn references the new tx. + let txId = Api.getTxId (Api.getTxBody tx) + Fund.fundTxIn (head outFunds) + @?= Api.TxIn txId (Api.TxIx 0) + + , HUnit.testCase "buildTx: 2-in-3-out transaction" $ do + (_ledgerPP, signKey, addr) <- testSetup + let fund1 = mkDummyFund signKey 0 5_000_000 + fund2 = mkDummyFund signKey 1 5_000_000 + fee = L.Coin 200_000 + case TxAssembly.buildTx Api.ShelleyBasedEraConway {-- ledgerPP --} addr signKey + [fund1, fund2] 3 fee of + Left err -> + HUnit.assertFailure $ "buildTx failed: " ++ show err + Right (_tx, outFunds) -> do + -- Three output funds. + length outFunds @?= 3 + -- Total output = total input - fee. + let totalOut = sum (map Fund.fundValue outFunds) + totalOut @?= (10_000_000 - 200_000) + + , HUnit.testCase "buildTx: insufficient funds" $ do + (_ledgerPP, signKey, addr) <- testSetup + let fund = mkDummyFund signKey 0 100_000 + fee = L.Coin 200_000 + case TxAssembly.buildTx Api.ShelleyBasedEraConway {-- ledgerPP --} addr signKey [fund] 1 fee of + Left _ -> pure () -- expected + Right _ -> + HUnit.assertFailure + "buildTx should fail when funds < fee" + + , HUnit.testCase "buildTx: no input funds" $ do + (_ledgerPP, signKey, addr) <- testSetup + let fee = L.Coin 200_000 + case TxAssembly.buildTx Api.ShelleyBasedEraConway {-- ledgerPP --} addr signKey [] 1 fee of + Left _ -> pure () -- expected + Right _ -> + HUnit.assertFailure + "buildTx should fail with no inputs" + + , HUnit.testCase "buildTx: zero outputs" $ do + (_ledgerPP, signKey, addr) <- testSetup + let fund = mkDummyFund signKey 0 10_000_000 + fee = L.Coin 200_000 + case TxAssembly.buildTx Api.ShelleyBasedEraConway {-- ledgerPP --} addr signKey [fund] 0 fee of + Left _ -> pure () -- expected + Right _ -> + HUnit.assertFailure + "buildTx should fail with 0 outputs" + + , HUnit.testCase + "buildTx: signing throughput (single-threaded)" $ do + (ledgerPP, signKey, addr) <- testSetup + -- Build N transactions sequentially and measure wall-clock + -- time. This quantifies the single-threaded builder bottleneck. + let n = 10_000 :: Int + fee = L.Coin 200_000 + -- Use a large initial fund so recycling doesn't deplete it. + initialFund = mkDummyFund signKey 0 1_000_000_000_000 + + start <- Clock.getTime Clock.MonotonicRaw + go n initialFund ledgerPP addr signKey fee + end <- Clock.getTime Clock.MonotonicRaw + + let elapsedNs = Clock.toNanoSecs (end - start) + elapsedS = fromIntegral elapsedNs / 1e9 :: Double + tps = fromIntegral n / elapsedS + + hPutStrLn stderr "" + hPutStrLn stderr + " --- Single-threaded buildTx throughput ---" + hPutStrLn stderr $ " txs built: " ++ show n + hPutStrLn stderr $ " elapsed: " ++ show elapsedS ++ " s" + hPutStrLn stderr $ + " throughput: " ++ show (round tps :: Int) ++ " tx/s" + hFlush stderr + + -- Sanity: we should be able to sign at least 1000 tx/s on any + -- reasonable hardware. This is not a hard performance target, + -- just a smoke test that buildTx isn't catastrophically slow. + HUnit.assertBool + ("buildTx throughput too low: " + ++ show (round tps :: Int) ++ " tx/s") + (tps > 1000) + ] + where + -- Build N txs sequentially, recycling the first output each time. + go :: Int -> Fund.Fund + -> Api.LedgerProtocolParameters Api.ConwayEra + -> Api.AddressInEra Api.ConwayEra + -> Api.SigningKey Api.PaymentKey -> L.Coin -> IO () + go 0 _ _ _ _ _ = pure () + go remaining fund ledgerPP addr signKey fee = + case TxAssembly.buildTx Api.ShelleyBasedEraConway {-- ledgerPP --} addr signKey [fund] 1 fee of + Left err -> + error $ "throughput test: buildTx failed at iteration " + ++ show remaining ++ ": " ++ show err + Right (_, outFunds) -> + go (remaining - 1) (head outFunds) + ledgerPP addr signKey fee + +-------------------------------------------------------------------------------- +-- Test helpers +-------------------------------------------------------------------------------- + +-- | Load protocol parameters and create common test fixtures. +testSetup + :: IO ( Api.LedgerProtocolParameters Api.ConwayEra + , Api.SigningKey Api.PaymentKey + , Api.AddressInEra Api.ConwayEra + ) +testSetup = do + -- Load protocol parameters from the CI test file. + ppPath <- Paths.getDataFileName "data/protocol-parameters.ci-test.json" + protocolParameters <- + Aeson.eitherDecodeFileStrict' ppPath >>= either fail pure + ledgerPP <- + case PP.convertToLedgerProtocolParameters + Api.ShelleyBasedEraConway protocolParameters of + Left err -> + fail $ "convertToLedgerProtocolParameters: " ++ show err + Right pp -> pure pp + + -- Generate a fresh signing key and derive its address. + signKey <- Api.generateSigningKey Api.AsPaymentKey + let networkId = Api.Testnet (Api.NetworkMagic 42) + addr = Api.shelleyAddressInEra + (Api.shelleyBasedEra @Api.ConwayEra) + $ Api.makeShelleyAddress networkId + (Api.PaymentCredentialByKey + (Api.verificationKeyHash + (Api.getVerificationKey signKey))) + Api.NoStakeAddress + + pure (ledgerPP, signKey, addr) + +-- | Create a dummy fund with a synthetic TxIn. Uses the signing key's +-- verification key hash to derive a deterministic TxId (via +-- 'Api.genesisUTxOPseudoTxIn') and the caller-supplied @index@ as the +-- 'Api.TxIx'. Each distinct @index@ produces a unique 'Api.TxIn', so +-- multi-input tests can create several funds from the same key without +-- accidentally producing duplicate inputs. +mkDummyFund :: Api.SigningKey Api.PaymentKey -> Word -> Integer -> Fund.Fund +mkDummyFund signKey index lovelace = Fund.Fund + { Fund.fundTxIn = + let Api.TxIn txId _ = Fund.genesisTxIn + (Api.Testnet (Api.NetworkMagic 42)) + signKey + in Api.TxIn txId (Api.TxIx index) + , Fund.fundValue = lovelace + , Fund.fundSignKey = signKey + } diff --git a/bench/tx-centrifuge/tx-centrifuge.cabal b/bench/tx-centrifuge/tx-centrifuge.cabal new file mode 100644 index 00000000000..faee611a656 --- /dev/null +++ b/bench/tx-centrifuge/tx-centrifuge.cabal @@ -0,0 +1,218 @@ +cabal-version: 3.0 + +name: tx-centrifuge +version: 0.2.0.0 +synopsis: Standalone transaction generator for Cardano benchmarking +description: Pull-based transaction generator targeting the higher TPS + rates and workload isolation that Leios benchmarking requires. + Built from scratch so that tx-generator's historical baselines + remain untouched. +category: Cardano, + Benchmark, +copyright: 2026 Intersect MBO. +author: Federico Mastellone (210034+fmaste@users.noreply.github.com) +license: Apache-2.0 +license-files: LICENSE + NOTICE +build-type: Simple + +extra-doc-files: README.md +data-files: data/config-shared-10.json + data/config-shared-100k.json + data/config-per-target-0_2.json + data/config-per-target-2k.json + data/config-per-target-200.json + data/config-multi-group.json + data/protocol-parameters.ci-test.json + +-------------------------------------------------------------------------------- + +common project-config + default-language: Haskell2010 + +common ghc-warnings + ghc-options: -Wall + -Wcompat + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wno-prepositive-qualified-module + -Wno-unticked-promoted-constructors + -Wpartial-fields + -Wredundant-constraints + -fobject-code -fno-ignore-interface-pragmas + -fno-omit-interface-pragmas + +-- -N: multicore runtime capabilities (critical for high-TPS CPU load). +-- -A64m: larger nursery to reduce minor-GC frequency in the hot path. +-- -T: RTS stats available for tuning/regression checks. +common rts-defaults + ghc-options: -threaded + -rtsopts + "-with-rtsopts=-N -A64m -T" + +-------------------------------------------------------------------------------- + +executable tx-centrifuge + import: project-config, ghc-warnings, rts-defaults + hs-source-dirs: app + main-is: Main.hs + build-depends: base >=4.12 && <5 + , aeson + , async + , bytestring + , cardano-api + , cardano-ledger-core + , cardano-node + , containers + , network + , ouroboros-consensus:{ouroboros-consensus,cardano} + , ouroboros-network:{framework} + , stm + , text + , transformers + , tx-centrifuge:pull-fiction + , tx-centrifuge:tx-centrifuge-lib + +-------------------------------------------------------------------------------- + +-- | Domain-independent, pull-based load generation engine. +-- +-- Provides rate-limited pipeline management (input queue, payload queue, +-- closed-loop recycling), GCRA-based admission control, and workload +-- orchestration. Zero Cardano dependencies — the library is parameterised over +-- abstract input and payload types so it can drive any pull-based protocol +-- (e.g. Cardano's TxSubmission2 mini-protocol). +library pull-fiction + import: project-config, ghc-warnings + hs-source-dirs: lib/pull-fiction + visibility: public + exposed-modules: Cardano.Benchmarking.PullFiction.Config.Raw + Cardano.Benchmarking.PullFiction.Config.Runtime + Cardano.Benchmarking.PullFiction.Config.Validated + Cardano.Benchmarking.PullFiction.Clock + Cardano.Benchmarking.PullFiction.WorkloadRunner + other-modules: Cardano.Benchmarking.PullFiction.Internal.Pipe + Cardano.Benchmarking.PullFiction.Internal.RateLimiter + Cardano.Benchmarking.PullFiction.Internal.Recycler + build-depends: base >=4.12 && <5 + , aeson + , async + , clock + , containers + -- avoid stm-2.5.2 https://github.com/haskell/stm/issues/76 + -- (Pipe.dropPayloads uses the affected flushTBQueue) + , stm <2.5.2 || >=2.5.3 + , text + +-- Sub-library with node functionality decoupled from the core library above. +library tx-centrifuge-lib + import: project-config, ghc-warnings + hs-source-dirs: lib/tx-centrifuge + visibility: public + exposed-modules: Cardano.Benchmarking.TxCentrifuge.Block + Cardano.Benchmarking.TxCentrifuge.Fund + Cardano.Benchmarking.TxCentrifuge.NodeToClient + Cardano.Benchmarking.TxCentrifuge.NodeToClient.TxIdSync + Cardano.Benchmarking.TxCentrifuge.NodeToClient.TxSubmission + Cardano.Benchmarking.TxCentrifuge.NodeToClient.UTxOQuery + Cardano.Benchmarking.TxCentrifuge.NodeToNode + Cardano.Benchmarking.TxCentrifuge.NodeToNode.KeepAlive + Cardano.Benchmarking.TxCentrifuge.NodeToNode.TxIdSync + Cardano.Benchmarking.TxCentrifuge.NodeToNode.TxSubmission + Cardano.Benchmarking.TxCentrifuge.Tracing + Cardano.Benchmarking.TxCentrifuge.Tracing.Orphans + Cardano.Benchmarking.TxCentrifuge.TxAssembly + build-depends: base >=4.12 && <5 + , aeson + , bytestring + , cardano-api + , cardano-diffusion + , cardano-ledger-api + , cardano-ledger-core + , containers + , contra-tracer + , io-classes:{io-classes, strict-stm} + , network + , network-mux + , ouroboros-consensus:{ouroboros-consensus, cardano, diffusion} + -- TODO: Modules from lib "framework-tracing" will be in lib "tracing" on the next release of ouroboros-network. + -- See commit 12896145d1626ce98e7c85623316e5e3e05e8dc1 of ouroboros-network. + , ouroboros-network:{ouroboros-network, api, framework, framework-tracing, protocols} + , random + , serialise + -- avoid stm-2.5.2 https://github.com/haskell/stm/issues/76 + , stm <2.5.2 || >=2.5.3 + , text + , time + , trace-dispatcher + , typed-protocols:{typed-protocols, stateful} + +-------------------------------------------------------------------------------- + +-- Test suites import rts-defaults so performance/fairness behavior matches +-- production runtime defaults instead of a different RTS profile. + +test-suite pull-fiction-test + import: project-config, ghc-warnings, rts-defaults + type: exitcode-stdio-1.0 + hs-source-dirs: test/pull-fiction + main-is: Main.hs + other-modules: Test.PullFiction.GeneratorTest + Test.PullFiction.PipelineTest + Paths_tx_centrifuge + autogen-modules: Paths_tx_centrifuge + build-depends: base >=4.12 && <5 + , containers + , tasty + , tasty-hunit + , tx-centrifuge:pull-fiction + , tx-centrifuge:test-harness + +test-suite tx-centrifuge-test + import: project-config, ghc-warnings, rts-defaults + type: exitcode-stdio-1.0 + hs-source-dirs: test/tx-centrifuge + main-is: Main.hs + other-modules: Test.TxCentrifuge.TxTest + Paths_tx_centrifuge + autogen-modules: Paths_tx_centrifuge + build-depends: base >=4.12 && <5 + , aeson + , cardano-api + , cardano-ledger-core + , clock + , tasty + , tasty-hunit + , tx-centrifuge:tx-centrifuge-lib + , tx-generator + +library test-harness + import: project-config, ghc-warnings + visibility: private + hs-source-dirs: test/lib + exposed-modules: Test.PullFiction.Harness + build-depends: base >=4.12 && <5 + , aeson + , async + , clock + , containers + , tx-centrifuge:pull-fiction + +-- Bench imports rts-defaults so benchmark numbers are measured with the same +-- RTS configuration used by the executable and tests. +-------------------------------------------------------------------------------- + +benchmark core-bench + import: project-config, ghc-warnings, rts-defaults + type: exitcode-stdio-1.0 + hs-source-dirs: bench + main-is: Bench.hs + other-modules: Paths_tx_centrifuge + autogen-modules: Paths_tx_centrifuge + build-depends: base >=4.12 && <5 + , containers + , criterion + , deepseq + , tx-centrifuge:pull-fiction + , tx-centrifuge:test-harness + diff --git a/bench/tx-generator/src/Cardano/Benchmarking/Wallet.hs b/bench/tx-generator/src/Cardano/Benchmarking/Wallet.hs index bf5739208ef..8ba0c542372 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/Wallet.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/Wallet.hs @@ -18,6 +18,7 @@ import Cardano.TxGenerator.Tx import Cardano.TxGenerator.Types import Cardano.TxGenerator.UTxO +import Data.List (foldl') import Prelude import Control.Concurrent.MVar @@ -64,13 +65,13 @@ askWalletRef r f = do -- | This does an insertion into the `MVar` contents. walletRefInsertFund :: WalletRef -> Fund -> IO () -walletRefInsertFund ref fund = modifyMVar_ ref $ \w -> return $ FundQueue.insertFund w fund +walletRefInsertFund ref fund = modifyMVar_ ref $ \w -> return $! FundQueue.insertFund w fund -- | 'mkWalletFundStoreList' hides its second argument in -- 'FundToStoreList'. This is not used anywhere. mkWalletFundStoreList :: WalletRef -> FundToStoreList IO mkWalletFundStoreList walletRef funds = modifyMVar_ walletRef - $ \wallet -> return (foldl FundQueue.insertFund wallet funds) + $ \wallet -> return $! foldl' FundQueue.insertFund wallet funds -- | 'mkWalletFundStore' hides its second argument in 'FundToStore'. -- This is only ever called in tandem with 'createAndStore' in @@ -79,16 +80,16 @@ mkWalletFundStoreList walletRef funds = modifyMVar_ walletRef -- 'WalletRef' 'MVar' by side effect. mkWalletFundStore :: WalletRef -> FundToStore IO mkWalletFundStore walletRef fund = modifyMVar_ walletRef - $ \wallet -> return $ FundQueue.insertFund wallet fund + $ \wallet -> return $! FundQueue.insertFund wallet fund -- | 'walletSource' is only ever used in -- 'Cardano.Benchmarking.Script.Core.evalGenerator' to pass -- to 'Cardano.TxGenerator.Tx.sourceToStoreTransaction' and -- its associated functions. walletSource :: WalletRef -> Int -> FundSource IO -walletSource ref munch = modifyMVar ref $ \fifo -> return $ case removeFunds munch fifo of - Nothing -> (fifo, Left $ TxGenError "WalletSource: out of funds") - Just (newFifo, funds) -> (newFifo, Right funds) +walletSource ref munch = modifyMVar ref $ \fifo -> case removeFunds munch fifo of + Nothing -> return (fifo, Left $ TxGenError "WalletSource: out of funds") + Just (newFifo, funds) -> return (newFifo, Right funds) -- | Just a preview of the wallet's funds; wallet remains unmodified. walletPreview :: WalletRef -> Int -> IO [Fund] diff --git a/bench/tx-generator/src/Cardano/TxGenerator/Fund.hs b/bench/tx-generator/src/Cardano/TxGenerator/Fund.hs index a2235ac3b5a..d1d6443e132 100644 --- a/bench/tx-generator/src/Cardano/TxGenerator/Fund.hs +++ b/bench/tx-generator/src/Cardano/TxGenerator/Fund.hs @@ -36,7 +36,7 @@ import Data.Function (on) -- use of lenses. data FundInEra era = FundInEra { _fundTxIn :: !TxIn - , _fundWitness :: Witness WitCtxTxIn era + , _fundWitness :: !(Witness WitCtxTxIn era) , _fundVal :: !(TxOutValue era) , _fundSigningKey :: !(Maybe (SigningKey PaymentKey)) } diff --git a/bench/tx-generator/src/Cardano/TxGenerator/Internal/Fifo.hs b/bench/tx-generator/src/Cardano/TxGenerator/Internal/Fifo.hs index eaa0b9f27df..a04ceec7cb0 100644 --- a/bench/tx-generator/src/Cardano/TxGenerator/Internal/Fifo.hs +++ b/bench/tx-generator/src/Cardano/TxGenerator/Internal/Fifo.hs @@ -1,4 +1,3 @@ -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {-| Module : Cardano.TxGenerator.Internal.Fifo Description : FIFO/queue data structure. @@ -48,7 +47,9 @@ remove :: Fifo a -> Maybe (Fifo a, a) remove fifo = case fifo of Fifo [] [] -> Nothing Fifo (h:t) y -> Just (Fifo t y, h) - Fifo [] y -> let ~(h:t) = reverse y in Just (Fifo t [], h) + Fifo [] y -> case reverse y of + (h:t) -> Just (Fifo t [], h) + [] -> Nothing -- | Dequeueing /n/ items just iterates calling remove within the -- `Maybe` monad. Removing n from a Fifo of length k when k < n is diff --git a/cabal.project b/cabal.project index 3d18d880d86..21f9e72b328 100644 --- a/cabal.project +++ b/cabal.project @@ -43,6 +43,7 @@ packages: bench/cardano-topology bench/locli bench/plutus-scripts-bench + bench/tx-centrifuge bench/tx-generator bench/cardano-recon-framework bench/cardano-timeseries-io diff --git a/nix/workbench/backend/nomad-job.nix b/nix/workbench/backend/nomad-job.nix index 7d84ebcb404..5aaffb17630 100644 --- a/nix/workbench/backend/nomad-job.nix +++ b/nix/workbench/backend/nomad-job.nix @@ -895,7 +895,7 @@ let in # Recreate the "run-script.json" with IPs and ports that are # nomad template variables. - (runScriptToGoTemplate + (runScriptToGoTemplate2 runScript # Just the node names. (lib.attrsets.mapAttrsToList @@ -1394,6 +1394,32 @@ let '' ; + runScriptToGoTemplate2 = runScript: _: builtins.replaceStrings + ( + (builtins.genList + (i: ''__addr_${toString i}__'') + 100 + ) + ++ + (builtins.genList + (i: ''"__port_${toString i}__"'') + 100 + ) + ) + ( + (builtins.genList + (i: ''{{range nomadService "${(nodeNameToServicePortName "node-${toString i}")}"}}{{.Address}}{{end}}'') + 100 + ) + ++ + (builtins.genList + (i: ''{{range nomadService "${(nodeNameToServicePortName "node-${toString i}")}"}}{{.Port}}{{end}}'') + 100 + ) + ) + (lib.generators.toJSON {} runScript) + ; + # Convert from generator's "run-script.json" with all addresses being # "127.0.0.01" to one with all addresses being a placeholder like # "{{NOMAD_IP_node-X}}". diff --git a/nix/workbench/backend/nomad.nix b/nix/workbench/backend/nomad.nix index 9b272b86b29..38111f5abb5 100644 --- a/nix/workbench/backend/nomad.nix +++ b/nix/workbench/backend/nomad.nix @@ -176,6 +176,12 @@ let # Avoid nix cache misses on every commit because of `set-git-rev`. flake-output = "cardanoNodePackages.tx-generator.passthru.noGitRev"; }; + tx-centrifuge = rec { + # Local reference only used if not "cloud". + nix-store-path = haskellProject.exes.tx-centrifuge; + flake-reference = "github:intersectmbo/cardano-node"; + flake-output = "cardanoNodePackages.tx-centrifuge"; + }; } ; diff --git a/nix/workbench/service/generator.nix b/nix/workbench/service/generator.nix index 2f4a294edc3..743f23a2a9f 100644 --- a/nix/workbench/service/generator.nix +++ b/nix/workbench/service/generator.nix @@ -147,6 +147,169 @@ let let serviceConfig = generatorServiceConfig nodeSpecs; service = generatorServiceConfigService serviceConfig; + genesisFunds = + (let + # create-testnet-data distributes non-delegated supply across utxo-keys + # using integer division. utxo1 gets the remainder. + nonDelegated = (profile.derived.supply_total - profile.derived.supply_delegated) * 9 / 10; + nKeys = profile.genesis.utxo_keys; + valuePerKey = nonDelegated / nKeys; + remainder = nonDelegated - valuePerKey * nKeys; + in +__toJSON + (builtins.genList + (i: + { signing_key = "../genesis/utxo-keys/utxo${toString (i+1)}.skey"; # Key index is not zero based =) + value = valuePerKey + (if i == 0 then remainder else 0); + } + ) + nKeys + ) + ) + ; + txCentrifugeConfig = + { # pull-fiction parameters. + ########################## + initial_inputs = + { type = "genesis_utxo_keys"; + params = + { network_magic = profile.genesis.network_magic; + signing_keys_file = "./funds.json"; + } + ; + } + ; + observers = + { local-follower = + { type = "nodetoclient"; + params = + { socket_path = "../${runningNode}/node.socket"; + confirmation_depth = 2; + } + ; + } + ; + } + ; + builder = + { type = "value"; + params = + { inputs_per_tx = 2; + outputs_per_tx = 2; + fee = 1000000; + } + ; + recycle = {type = "on_confirm"; params = "local-follower";}; + } + ; + rate_limit = + { scope = "shared"; + type = "token_bucket"; + params = { tps = 108; }; + } + ; + max_batch_size = null; + on_exhaustion = "error"; + # One node per-workload. + workloads = + # One workload per target. + #builtins.listToAttrs + # (builtins.genList + # (i: + # { name = "node-${toString i}"; + # value = + # { targets = + # { "${toString i}" = + # { addr = "127.0.0.1"; + # port = (30000 + i); + # } + # # { addr = "__addr_${toString i}__"; + # # port = "__port_${toString i}__"; + # # } + # ; + # } + # ; + # } + # ; + # } + # ) + # profile.composition.n_pool_hosts + # ) + # All targets in one workload. + { my-workload = + { targets = + builtins.listToAttrs + (builtins.genList + (i: + { name = "node-${toString i}"; + value = + { addr = "127.0.0.1"; + port = (30000 + i); + } + # { addr = "__addr_${toString i}__"; + # port = "__port_${toString i}__"; + # } + ; + } + ) + profile.composition.n_pool_hosts + ) + ; + } + ; + } + ; + # tx-centrifuge parameters. + ########################### + nodeConfig = "../${runningNode}/config.json"; + protocol_parameters = + { epoch_length = profile.genesis.shelley.epochLength; + min_fee_a = profile.genesis.shelley.protocolParams.minFeeA; + min_fee_b = profile.genesis.shelley.protocolParams.minFeeB; + } + ; + # Tracing parameters. + ##################### + TraceOptions = + { "" = + { backends = [ "Stdout MachineFormat" ]; + detail = "DNormal"; + severity = "Debug"; + }; + # ouroboros-network traces. + "KeepAlive" = { severity="Silence";}; + "KeepAlive.Receive.KeepAliveResponse" = { severity="Silence";}; + "KeepAlive.Send.KeepAlive" = { severity="Silence";}; + "TxSubmission2" = { severity="Silence";}; + "TxSubmission2.Receive" = { severity="Silence";}; + "TxSubmission2.Receive.MsgInit" = { severity="Silence";}; + "TxSubmission2.Receive.RequestTxIds" = { severity="Silence";}; + "TxSubmission2.Receive.RequestTxs" = { severity="Silence";}; + "TxSubmission2.Receive.Done" = { severity="Silence";}; + "TxSubmission2.Send" = { severity="Silence";}; + "TxSubmission2.Send.MsgInit" = { severity="Silence";}; + "TxSubmission2.Send.ReplyTxIds" = { severity="Silence";}; + "TxSubmission2.Send.ReplyTxs" = { severity="Silence";}; + "TxSubmission2.Send.Done" = { severity="Silence";}; + # tx-centrifuge traces. + "TxCentrifuge.Builder.NewTx" = { severity="Debug";detail="DMaximum";}; + "TxCentrifuge.Pipe.PayloadEnqueued" = { severity="Debug";detail="DMaximum";}; + "TxCentrifuge.Pipe.PayloadDequeued" = { severity="Debug";detail="DMaximum";}; + "TxCentrifuge.Pipe.InputsEnqueued" = { severity="Debug";detail="DMaximum";}; + "TxCentrifuge.Pipe.InputsDequeued" = { severity="Debug";detail="DMaximum";}; + "TxCentrifuge.Recycler.Pending" = { severity="Debug";detail="DMaximum";}; + "TxCentrifuge.Recycler.AddToPipe" = { severity="Debug";detail="DMaximum";}; + "TxCentrifuge.Observer.Announce" = { severity="Debug";detail="DDetailed";}; + "TxCentrifuge.TxSubmission.RequestTxIds" = { severity="Debug";detail="DDetailed";}; + "TxCentrifuge.TxSubmission.ReplyTxIds" = { severity="Debug";detail="DDetailed";}; + "TxCentrifuge.TxSubmission.RequestTxs" = { severity="Debug";detail="DDetailed";}; + "TxCentrifuge.TxSubmission.ReplyTxs" = { severity="Debug";detail="DDetailed";}; + }; + TurnOnLogMetrics = false; + TurnOnLogging = true; + TraceOptionNodeName = "leios-generator"; + } + ; in { start = '' @@ -189,11 +352,12 @@ let # Extra workloads end ####################### ############################################# - ${service.script} + echo ${__toJSON genesisFunds} > ./funds.json + ${haskellProject.exes.tx-centrifuge}/bin/tx-centrifuge run-script.json '' ; - config = (service.decideRunScript service); + config = txCentrifugeConfig; # Not present on every profile. # Don't create a derivation to a file containing "null" !!! diff --git a/nix/workbench/service/nodes.nix b/nix/workbench/service/nodes.nix index 22e5a5f85cd..ade305ae331 100644 --- a/nix/workbench/service/nodes.nix +++ b/nix/workbench/service/nodes.nix @@ -112,6 +112,16 @@ let ChainSyncIdleTimeout = 0; PeerSharing = false; + # Lower bound, 2 * maxEBClosure (12.5MB) + MempoolCapacityBytesOverride = 25000000; + # Aggregate. Mempool-wide capacity dimension. + MempoolTimeoutCapacity = 20.0; # (default: 5.0s). + # Mempool timeouts must be either all set or all unset. + # Per-tx. Silently rejects the tx, keeps the peer. + MempoolTimeoutSoft = 1.0; # (default: 1.0s). + # Per-tx. Kills the peer connection. + MempoolTimeoutHard = 1.5; # (default: 1.5s). + ## defaults taken from: ouroboros-network/src/Ouroboros/Network/Diffusion/Configuration.hs ## NB. the following inequality must hold: known >= established >= active >= 0 SyncTargetNumberOfActivePeers = max 15 valency; # set to same value as TargetNumberOfActivePeers