From bc758499839201e7c9b100284e8124a3787bed3b Mon Sep 17 00:00:00 2001 From: Sebastian Nagel Date: Sun, 5 Jul 2026 22:59:11 +0200 Subject: [PATCH 01/12] Add tx-firehose: N2C push-based tx load generator MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit A minimal single-node load generator driven over node-to-client. Discovers its own UTxO via QueryUTxOByAddress, submits transactions with a persistent LocalTxSubmission session, and reacts to accept/reject on every tx. Contrast with tx-centrifuge: N2C means stop/start on demand works (rejects surface directly), rejection reasons are logged, and there is no "optimistic recycle" divergence between the local fund set and ledger truth — a periodic UTxO requery replaces the local set to bound drift. Currently Conway-only. --- bench/tx-firehose/LICENSE | 177 ++++++++++ bench/tx-firehose/NOTICE | 13 + bench/tx-firehose/app/Main.hs | 303 ++++++++++++++++++ .../Cardano/Benchmarking/TxFirehose/Config.hs | 61 ++++ .../src/Cardano/Benchmarking/TxFirehose/Tx.hs | 101 ++++++ bench/tx-firehose/tx-firehose.cabal | 56 ++++ cabal.project | 1 + 7 files changed, 712 insertions(+) create mode 100644 bench/tx-firehose/LICENSE create mode 100644 bench/tx-firehose/NOTICE create mode 100644 bench/tx-firehose/app/Main.hs create mode 100644 bench/tx-firehose/src/Cardano/Benchmarking/TxFirehose/Config.hs create mode 100644 bench/tx-firehose/src/Cardano/Benchmarking/TxFirehose/Tx.hs create mode 100644 bench/tx-firehose/tx-firehose.cabal diff --git a/bench/tx-firehose/LICENSE b/bench/tx-firehose/LICENSE new file mode 100644 index 00000000000..f433b1a53f5 --- /dev/null +++ b/bench/tx-firehose/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-firehose/NOTICE b/bench/tx-firehose/NOTICE new file mode 100644 index 00000000000..7b16053c55e --- /dev/null +++ b/bench/tx-firehose/NOTICE @@ -0,0 +1,13 @@ +Copyright 2019-2023 Input Output Global Inc (IOG), 2023-2026 Intersect. + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. diff --git a/bench/tx-firehose/app/Main.hs b/bench/tx-firehose/app/Main.hs new file mode 100644 index 00000000000..16987a3f4bd --- /dev/null +++ b/bench/tx-firehose/app/Main.hs @@ -0,0 +1,303 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -Wno-deprecations #-} + +module Main (main) where + +import Control.Concurrent (threadDelay) +import Control.Concurrent.Async qualified as Async +import Control.Concurrent.STM (TMVar, TQueue, TVar) +import Control.Concurrent.STM qualified as STM +import Control.Monad (forever, when) +import Control.Monad.Trans.Except (runExceptT) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import System.Environment (getArgs) +import System.Exit (die) +import System.IO (hPutStrLn, stderr) + +import Cardano.Api + ( AddressAny + , AddressInEra + , AnyCardanoEra (..) + , CardanoEra (ConwayEra) + , ConsensusModeParams (CardanoModeParams) + , File (File) + , FromSomeType (FromSomeType) + , LocalNodeClientProtocols + ( LocalNodeClientProtocols + , localChainSyncClient + , localStateQueryClient + , localTxMonitoringClient + , localTxSubmissionClient + ) + , LocalChainSyncClient (NoLocalChainSyncClient) + , LocalNodeConnectInfo (LocalNodeConnectInfo) + , NetworkId (Testnet) + , NetworkMagic (NetworkMagic) + , PaymentCredential (PaymentCredentialByKey) + , QueryInEra (QueryInShelleyBasedEra) + , QueryInMode (QueryCurrentEra, QueryInEra) + , QueryInShelleyBasedEra (QueryUTxO) + , QueryUTxOFilter (QueryUTxOByAddress) + , SigningKey + , StakeAddressReference (NoStakeAddress) + , SubmitResult (SubmitFail, SubmitSuccess) + , Target (VolatileTip) + , TxInMode (TxInMode) + , TxValidationErrorInCardanoMode + , UTxO (UTxO) + ) +import Cardano.Api qualified as Api + +import Cardano.Ledger.Coin qualified as L + +import Ouroboros.Network.Protocol.LocalTxSubmission.Client + ( LocalTxClientStIdle (SendMsgSubmitTx) + , LocalTxSubmissionClient (LocalTxSubmissionClient) + ) + +import Cardano.Benchmarking.TxFirehose.Config + ( Config (..) + , loadConfig + ) +import Cardano.Benchmarking.TxFirehose.Tx (Fund (Fund, fundTxIn, fundValue)) +import Cardano.Benchmarking.TxFirehose.Tx qualified as Tx + +-------------------------------------------------------------------------------- + +-- | Byron epoch length passed in ConsensusModeParams — only used to decode +-- Byron EBBs, which we never do. Matches every historical Cardano network +-- and is what cardano-cli hardcodes. +byronEpochSlots :: Api.EpochSlots +byronEpochSlots = Api.EpochSlots 21600 + +-- | An outstanding submission: the tx to submit, and a reply slot the +-- persistent client fills once the node responds. +data Pending = Pending + !TxInMode + !(TMVar (SubmitResult TxValidationErrorInCardanoMode)) + +main :: IO () +main = do + cfgPath <- getArgs >>= \case + [p] -> pure p + _ -> die "usage: tx-firehose " + cfg <- loadConfig cfgPath + + signingKey <- loadSigningKey (cfgSigningKeyFile cfg) + + let networkId = Testnet (NetworkMagic (fromIntegral (cfgNetworkMagic cfg))) + addrInEra = deriveAddress networkId signingKey + addrAny = case addrInEra of + Api.AddressInEra _ addr -> Api.toAddressAny addr + connInfo = LocalNodeConnectInfo + { Api.localConsensusModeParams = CardanoModeParams byronEpochSlots + , Api.localNodeNetworkId = networkId + , Api.localNodeSocketPath = File (cfgSocketPath cfg) + } + + ensureConway connInfo + + hPutStrLn stderr $ "tx-firehose: querying UTxO for " ++ show addrAny + initialFunds <- queryFunds connInfo addrAny + when (Map.null initialFunds) $ + die "tx-firehose: no UTxO found at derived address — fund it first" + hPutStrLn stderr $ "tx-firehose: seeded with " + ++ show (Map.size initialFunds) ++ " UTxO(s), total " + ++ show (sum (Map.elems initialFunds)) ++ " lovelace" + + fundsVar <- STM.newTVarIO initialFunds + pendingQueue <- STM.newTQueueIO + + let clientThread = runSubmissionClient connInfo pendingQueue + submitter = submitLoop cfg addrInEra signingKey fundsVar pendingQueue + reconciler + | cfgReconcileEvery cfg <= 0 = forever (threadDelay maxBound) + | otherwise = reconcileLoop cfg connInfo addrAny fundsVar + + -- The submission client owns the wire; if it dies (socket closed, node + -- restarted, protocol error) we want to die with it. Link so the exception + -- propagates. race_ ties the submitter and reconciler together so the + -- first to fail brings the other down. + Async.withAsync clientThread $ \clientA -> do + Async.link clientA + Async.race_ submitter reconciler + +-------------------------------------------------------------------------------- +-- Signing key & address +-------------------------------------------------------------------------------- + +loadSigningKey :: FilePath -> IO (SigningKey Api.PaymentKey) +loadSigningKey path = do + result <- Api.readFileTextEnvelopeAnyOf accepted (File path) + case result of + Left err -> die $ "tx-firehose: cannot read signing key " + ++ show path ++ ": " ++ show err + Right sk -> pure sk + where + accepted :: [FromSomeType Api.HasTextEnvelope (SigningKey Api.PaymentKey)] + accepted = + [ FromSomeType (Api.AsSigningKey Api.AsGenesisUTxOKey) Api.castSigningKey + , FromSomeType (Api.AsSigningKey Api.AsPaymentKey) id + ] + +deriveAddress + :: NetworkId -> SigningKey Api.PaymentKey -> AddressInEra Api.ConwayEra +deriveAddress networkId sk = + Api.shelleyAddressInEra (Api.shelleyBasedEra @Api.ConwayEra) $ + Api.makeShelleyAddress networkId + (PaymentCredentialByKey + (Api.verificationKeyHash (Api.getVerificationKey sk))) + NoStakeAddress + +-------------------------------------------------------------------------------- +-- Era sanity check +-------------------------------------------------------------------------------- + +ensureConway :: LocalNodeConnectInfo -> IO () +ensureConway connInfo = do + res <- runExceptT $ Api.queryNodeLocalState connInfo VolatileTip QueryCurrentEra + case res of + Left af -> die $ "tx-firehose: failed to acquire tip: " ++ show af + Right (AnyCardanoEra ConwayEra) -> pure () + Right (AnyCardanoEra other) -> + die $ "tx-firehose: node is in era " ++ show other + ++ ", but this tool only builds Conway-era transactions" + +-------------------------------------------------------------------------------- +-- UTxO query (ephemeral connection) +-------------------------------------------------------------------------------- + +queryFunds + :: LocalNodeConnectInfo -> AddressAny -> IO (Map Api.TxIn Integer) +queryFunds connInfo addrAny = do + let q = QueryInEra + (QueryInShelleyBasedEra + (Api.shelleyBasedEra @Api.ConwayEra) + (QueryUTxO (QueryUTxOByAddress (Set.singleton addrAny)))) + res <- runExceptT $ Api.queryNodeLocalState connInfo VolatileTip q + case res of + Left af -> die $ "tx-firehose: failed to acquire tip: " ++ show af + Right (Left mismatch) -> + die $ "tx-firehose: era mismatch on UTxO query: " ++ show mismatch + Right (Right (UTxO m)) -> pure (Map.map toLovelace m) + where + toLovelace :: Api.TxOut Api.CtxUTxO Api.ConwayEra -> Integer + toLovelace (Api.TxOut _ v _ _) = + let L.Coin c = Api.txOutValueToLovelace v in c + +-------------------------------------------------------------------------------- +-- Persistent submission client +-------------------------------------------------------------------------------- + +-- | Reads pending submissions from the queue and drives them one at a time +-- over a single LocalTxSubmission session. The protocol is inherently +-- request/response so pipelining a queue in front of it is the right shape: +-- multiple producers can enqueue concurrently, this thread serialises them +-- onto the wire and posts each reply back to the caller. +mkPersistentClient + :: TQueue Pending + -> LocalTxSubmissionClient TxInMode TxValidationErrorInCardanoMode IO () +mkPersistentClient q = LocalTxSubmissionClient loop + where + loop :: IO (LocalTxClientStIdle TxInMode TxValidationErrorInCardanoMode IO ()) + loop = do + Pending tx reply <- STM.atomically (STM.readTQueue q) + pure $ SendMsgSubmitTx tx $ \result -> do + STM.atomically $ STM.putTMVar reply result + loop + +runSubmissionClient :: LocalNodeConnectInfo -> TQueue Pending -> IO () +runSubmissionClient connInfo q = + Api.connectToLocalNode connInfo LocalNodeClientProtocols + { localChainSyncClient = NoLocalChainSyncClient + , localStateQueryClient = Nothing + , localTxSubmissionClient = Just (mkPersistentClient q) + , localTxMonitoringClient = Nothing + } + +-- | Enqueue a tx and block until the node replies. +submitViaQueue + :: TQueue Pending + -> TxInMode + -> IO (SubmitResult TxValidationErrorInCardanoMode) +submitViaQueue q tx = do + reply <- STM.newEmptyTMVarIO + STM.atomically $ STM.writeTQueue q (Pending tx reply) + STM.atomically $ STM.takeTMVar reply + +-------------------------------------------------------------------------------- +-- Reconcile loop +-------------------------------------------------------------------------------- + +-- | Periodically replace the local fund set with a fresh UTxO query. +-- Mempool-only outputs are temporarily lost and reappear on the next +-- reconcile once they're on chain. Keeps drift bounded. +reconcileLoop + :: Config -> LocalNodeConnectInfo -> AddressAny + -> TVar (Map Api.TxIn Integer) -> IO () +reconcileLoop cfg connInfo addrAny fundsVar = forever $ do + threadDelay (round (cfgReconcileEvery cfg * 1_000_000)) + fresh <- queryFunds connInfo addrAny + STM.atomically $ STM.writeTVar fundsVar fresh + hPutStrLn stderr $ "tx-firehose: reconciled — " + ++ show (Map.size fresh) ++ " UTxO(s), total " + ++ show (sum (Map.elems fresh)) ++ " lovelace" + +-------------------------------------------------------------------------------- +-- Submit loop +-------------------------------------------------------------------------------- + +-- | Rate-limited loop: take @inputsPerTx@ funds, build a tx, submit via the +-- persistent queue, dispatch on the reply. +submitLoop + :: Config + -> AddressInEra Api.ConwayEra + -> SigningKey Api.PaymentKey + -> TVar (Map Api.TxIn Integer) + -> TQueue Pending + -> IO () +submitLoop cfg addr sk fundsVar pendingQueue = do + let period = round (1_000_000 / cfgTps cfg) :: Int + n = fromIntegral (cfgInputsPerTx cfg) :: Int + forever $ do + inputs <- STM.atomically $ do + m <- STM.readTVar fundsVar + when (Map.size m < n) STM.retry + let taken = take n (Map.toList m) + m' = foldr (Map.delete . fst) m taken + STM.writeTVar fundsVar m' + pure taken + let inFunds = + [ Fund { fundTxIn = tin, fundValue = v } | (tin, v) <- inputs ] + case Tx.buildTx addr sk inFunds (cfgOutputsPerTx cfg) + (L.Coin (cfgFee cfg)) of + Left err -> do + hPutStrLn stderr $ "tx-firehose: buildTx failed: " ++ err + returnFunds fundsVar inputs + threadDelay period + Right (signedTx, outFunds) -> do + let txId = Api.getTxId (Api.getTxBody signedTx) + txInMode = TxInMode (Api.shelleyBasedEra @Api.ConwayEra) signedTx + result <- submitViaQueue pendingQueue txInMode + case result of + SubmitSuccess -> do + hPutStrLn stderr $ "tx-firehose: submitted " ++ show txId + STM.atomically $ STM.modifyTVar' fundsVar $ \m -> + foldr (\f -> Map.insert (fundTxIn f) (fundValue f)) m outFunds + SubmitFail reason -> do + hPutStrLn stderr $ "tx-firehose: rejected " ++ show txId + ++ ": " ++ show reason + returnFunds fundsVar inputs + threadDelay period + +returnFunds :: TVar (Map Api.TxIn Integer) -> [(Api.TxIn, Integer)] -> IO () +returnFunds fundsVar inputs = STM.atomically $ + STM.modifyTVar' fundsVar $ \m -> + foldr (uncurry Map.insert) m inputs diff --git a/bench/tx-firehose/src/Cardano/Benchmarking/TxFirehose/Config.hs b/bench/tx-firehose/src/Cardano/Benchmarking/TxFirehose/Config.hs new file mode 100644 index 00000000000..80bbd5e64f8 --- /dev/null +++ b/bench/tx-firehose/src/Cardano/Benchmarking/TxFirehose/Config.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} + +module Cardano.Benchmarking.TxFirehose.Config + ( Config (..) + , loadConfig + ) where + +import Control.Monad (when) +import Data.Aeson ((.:), (.:?)) +import Data.Aeson qualified as Aeson +import Numeric.Natural (Natural) +import System.Exit (die) + +data Config = Config + { cfgSocketPath :: !FilePath + , cfgNetworkMagic :: !Natural + , cfgSigningKeyFile :: !FilePath + , cfgTps :: !Double + , cfgInputsPerTx :: !Natural + , cfgOutputsPerTx :: !Natural + , cfgFee :: !Integer + , cfgReconcileEvery :: !Double + -- ^ Requery UTxO by address every N seconds. 0 disables periodic + -- reconciliation (still requeries at startup and on sync errors). + } + deriving Show + +instance Aeson.FromJSON Config where + parseJSON = Aeson.withObject "Config" $ \o -> do + socketPath <- o .: "socketPath" + networkMagic <- o .: "networkMagic" + signingKeyFile <- o .: "signingKeyFile" + tps <- o .: "tps" + inputsPerTx <- o .:? "inputsPerTx" Aeson..!= 1 + outputsPerTx <- o .:? "outputsPerTx" Aeson..!= 1 + fee <- o .:? "fee" Aeson..!= 200_000 + reconcileEvery <- o .:? "reconcileEvery" Aeson..!= 60 + pure Config + { cfgSocketPath = socketPath + , cfgNetworkMagic = networkMagic + , cfgSigningKeyFile = signingKeyFile + , cfgTps = tps + , cfgInputsPerTx = inputsPerTx + , cfgOutputsPerTx = outputsPerTx + , cfgFee = fee + , cfgReconcileEvery = reconcileEvery + } + +loadConfig :: FilePath -> IO Config +loadConfig path = do + bytes <- Aeson.eitherDecodeFileStrict path + case bytes of + Left err -> die $ "Config parse error in " ++ path ++ ": " ++ err + Right cfg -> do + when (cfgTps cfg <= 0) $ die "tps must be > 0" + when (cfgInputsPerTx cfg == 0) $ die "inputsPerTx must be >= 1" + when (cfgOutputsPerTx cfg == 0) $ die "outputsPerTx must be >= 1" + when (cfgFee cfg < 0) $ die "fee must be >= 0" + pure cfg diff --git a/bench/tx-firehose/src/Cardano/Benchmarking/TxFirehose/Tx.hs b/bench/tx-firehose/src/Cardano/Benchmarking/TxFirehose/Tx.hs new file mode 100644 index 00000000000..a195df0f846 --- /dev/null +++ b/bench/tx-firehose/src/Cardano/Benchmarking/TxFirehose/Tx.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -Wno-deprecations #-} + +module Cardano.Benchmarking.TxFirehose.Tx + ( Fund (..) + , buildTx + ) where + +import Data.Function ((&)) +import Numeric.Natural (Natural) + +import Cardano.Api qualified as Api + +import Cardano.Ledger.Coin qualified as L + +-- | A spendable UTxO under our signing key: reference + value. +data Fund = Fund + { fundTxIn :: !Api.TxIn + , fundValue :: !Integer + } + deriving (Eq, Ord, Show) + +-- | Build and sign a Conway-era transaction spending the given funds and +-- producing @numOutputs@ new UTxOs at @destAddr@. Returns the signed +-- transaction and the resulting output funds (indexed 0..numOutputs-1). +-- +-- No Plutus, no metadata, explicit fee. Change is split evenly across +-- outputs with any remainder folded into the first output. +buildTx + :: Api.AddressInEra Api.ConwayEra + -- ^ Destination address (also the change address). + -> Api.SigningKey Api.PaymentKey + -- ^ Key witnessing both inputs and (implicitly) future spends of outputs. + -> [Fund] + -> Natural + -- ^ Number of outputs. + -> L.Coin + -- ^ Fee. + -> Either String (Api.Tx Api.ConwayEra, [Fund]) +buildTx destAddr signingKey inFunds numOutputs fee + | null inFunds = Left "buildTx: no input funds" + | numOutputs == 0 = Left "buildTx: outputs_per_tx must be >= 1" + | feeLovelace < 0 = Left "buildTx: fee must be >= 0" + | changeTotal <= 0 = Left $ + "buildTx: insufficient funds — total inputs (" ++ show totalIn + ++ " lovelace) do not cover fee (" ++ show feeLovelace ++ ")" + | minOutputLovelace <= 0 = Left $ + "buildTx: output value too low — " ++ show numOutputs + ++ " outputs from " ++ show changeTotal + ++ " lovelace yields " ++ show minOutputLovelace ++ " per output" + | otherwise = case Api.createTransactionBody sbe txBodyContent of + Left err -> Left $ "buildTx: " ++ show err + Right txBody -> + let signedTx = Api.signShelleyTransaction sbe txBody + [Api.WitnessPaymentKey signingKey] + txId = Api.getTxId txBody + outFunds = + [ Fund { fundTxIn = Api.TxIn txId (Api.TxIx ix) + , fundValue = amt + } + | (ix, amt) <- zip [0..] outAmounts + ] + in Right (signedTx, outFunds) + where + sbe = Api.shelleyBasedEra @Api.ConwayEra + + totalIn = sum (map fundValue inFunds) + feeLovelace = let L.Coin c = fee in c + changeTotal = totalIn - feeLovelace + n = fromIntegral numOutputs :: Integer + minOutputLovelace = changeTotal `div` n + outAmounts = + let base = changeTotal `div` n + remainder = changeTotal `mod` n + in (base + remainder) : replicate (fromIntegral numOutputs - 1) base + + txIns = + [ ( fundTxIn f + , Api.BuildTxWith + (Api.KeyWitness Api.KeyWitnessForSpending) + ) + | f <- inFunds + ] + + mkTxOut lovelace = Api.TxOut + destAddr + (Api.lovelaceToTxOutValue sbe (Api.Coin lovelace)) + Api.TxOutDatumNone + Api.ReferenceScriptNone + + 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 Api.ShelleyBasedEraConway) + & Api.setTxMetadata Api.TxMetadataNone + & Api.setTxProtocolParams (Api.BuildTxWith Nothing) diff --git a/bench/tx-firehose/tx-firehose.cabal b/bench/tx-firehose/tx-firehose.cabal new file mode 100644 index 00000000000..0c45490a6c5 --- /dev/null +++ b/bench/tx-firehose/tx-firehose.cabal @@ -0,0 +1,56 @@ +cabal-version: 3.0 + +name: tx-firehose +version: 0.1.0.0 +synopsis: Push-based, single-node Cardano transaction load generator +description: + A minimal load generator that drives a single cardano-node via the + node-to-client protocol. Discovers its own UTxO by address query, + submits transactions with LocalTxSubmission, and reacts to accept/reject + responses. Contrast with tx-centrifuge, which reacts to N2N pulls. + +license: Apache-2.0 +license-files: LICENSE + NOTICE +author: IOHK +maintainer: operations@iohk.io +copyright: 2026 Intersect +category: Cardano, Test +build-type: Simple + +common project-config + default-language: Haskell2010 + ghc-options: -Wall + -Wcompat + -Wredundant-constraints + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wpartial-fields + -Wunused-packages + +library + import: project-config + hs-source-dirs: src + exposed-modules: Cardano.Benchmarking.TxFirehose.Config + Cardano.Benchmarking.TxFirehose.Tx + build-depends: base >= 4.14 && < 5 + , aeson + , cardano-api + , cardano-ledger-core + +executable tx-firehose + import: project-config + hs-source-dirs: app + main-is: Main.hs + ghc-options: -threaded + -rtsopts + "-with-rtsopts=-N -T" + build-depends: base >= 4.14 && < 5 + , async + , cardano-api + , cardano-ledger-core + , containers + , ouroboros-network:protocols + , stm + , transformers + , tx-firehose diff --git a/cabal.project b/cabal.project index 8e2e4de76f0..2c2d7cdd287 100644 --- a/cabal.project +++ b/cabal.project @@ -42,6 +42,7 @@ packages: bench/locli bench/plutus-scripts-bench bench/tx-generator + bench/tx-firehose bench/cardano-timeseries-io bench/trace-schemas/scripts/schema-gen trace-resources From bb0503db617fc68040b41ee76b94b137fdee9a9a Mon Sep 17 00:00:00 2001 From: Sebastian Nagel Date: Sun, 5 Jul 2026 23:10:38 +0200 Subject: [PATCH 02/12] tx-firehose: build Dijkstra-era transactions MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit The Leios devnet runs in DijkstraEra; ensureConway would refuse to start against it. Switch the hardcoded era from Conway to Dijkstra. The tx body content is otherwise the same shape — no plutus, explicit fee, no metadata — so this is a straight rename of era witnesses. If/when this needs to run against a Conway node again, generalise the tx builder over a ShelleyBasedEra evidence rather than adding a runtime branch. --- bench/tx-firehose/app/Main.hs | 24 +++++++++---------- .../src/Cardano/Benchmarking/TxFirehose/Tx.hs | 10 ++++---- 2 files changed, 17 insertions(+), 17 deletions(-) diff --git a/bench/tx-firehose/app/Main.hs b/bench/tx-firehose/app/Main.hs index 16987a3f4bd..e6921077408 100644 --- a/bench/tx-firehose/app/Main.hs +++ b/bench/tx-firehose/app/Main.hs @@ -25,7 +25,7 @@ import Cardano.Api ( AddressAny , AddressInEra , AnyCardanoEra (..) - , CardanoEra (ConwayEra) + , CardanoEra (DijkstraEra) , ConsensusModeParams (CardanoModeParams) , File (File) , FromSomeType (FromSomeType) @@ -102,7 +102,7 @@ main = do , Api.localNodeSocketPath = File (cfgSocketPath cfg) } - ensureConway connInfo + ensureDijkstra connInfo hPutStrLn stderr $ "tx-firehose: querying UTxO for " ++ show addrAny initialFunds <- queryFunds connInfo addrAny @@ -148,9 +148,9 @@ loadSigningKey path = do ] deriveAddress - :: NetworkId -> SigningKey Api.PaymentKey -> AddressInEra Api.ConwayEra + :: NetworkId -> SigningKey Api.PaymentKey -> AddressInEra Api.DijkstraEra deriveAddress networkId sk = - Api.shelleyAddressInEra (Api.shelleyBasedEra @Api.ConwayEra) $ + Api.shelleyAddressInEra (Api.shelleyBasedEra @Api.DijkstraEra) $ Api.makeShelleyAddress networkId (PaymentCredentialByKey (Api.verificationKeyHash (Api.getVerificationKey sk))) @@ -160,15 +160,15 @@ deriveAddress networkId sk = -- Era sanity check -------------------------------------------------------------------------------- -ensureConway :: LocalNodeConnectInfo -> IO () -ensureConway connInfo = do +ensureDijkstra :: LocalNodeConnectInfo -> IO () +ensureDijkstra connInfo = do res <- runExceptT $ Api.queryNodeLocalState connInfo VolatileTip QueryCurrentEra case res of Left af -> die $ "tx-firehose: failed to acquire tip: " ++ show af - Right (AnyCardanoEra ConwayEra) -> pure () + Right (AnyCardanoEra DijkstraEra) -> pure () Right (AnyCardanoEra other) -> die $ "tx-firehose: node is in era " ++ show other - ++ ", but this tool only builds Conway-era transactions" + ++ ", but this tool only builds Dijkstra-era transactions" -------------------------------------------------------------------------------- -- UTxO query (ephemeral connection) @@ -179,7 +179,7 @@ queryFunds queryFunds connInfo addrAny = do let q = QueryInEra (QueryInShelleyBasedEra - (Api.shelleyBasedEra @Api.ConwayEra) + (Api.shelleyBasedEra @Api.DijkstraEra) (QueryUTxO (QueryUTxOByAddress (Set.singleton addrAny)))) res <- runExceptT $ Api.queryNodeLocalState connInfo VolatileTip q case res of @@ -188,7 +188,7 @@ queryFunds connInfo addrAny = do die $ "tx-firehose: era mismatch on UTxO query: " ++ show mismatch Right (Right (UTxO m)) -> pure (Map.map toLovelace m) where - toLovelace :: Api.TxOut Api.CtxUTxO Api.ConwayEra -> Integer + toLovelace :: Api.TxOut Api.CtxUTxO Api.DijkstraEra -> Integer toLovelace (Api.TxOut _ v _ _) = let L.Coin c = Api.txOutValueToLovelace v in c @@ -258,7 +258,7 @@ reconcileLoop cfg connInfo addrAny fundsVar = forever $ do -- persistent queue, dispatch on the reply. submitLoop :: Config - -> AddressInEra Api.ConwayEra + -> AddressInEra Api.DijkstraEra -> SigningKey Api.PaymentKey -> TVar (Map Api.TxIn Integer) -> TQueue Pending @@ -284,7 +284,7 @@ submitLoop cfg addr sk fundsVar pendingQueue = do threadDelay period Right (signedTx, outFunds) -> do let txId = Api.getTxId (Api.getTxBody signedTx) - txInMode = TxInMode (Api.shelleyBasedEra @Api.ConwayEra) signedTx + txInMode = TxInMode (Api.shelleyBasedEra @Api.DijkstraEra) signedTx result <- submitViaQueue pendingQueue txInMode case result of SubmitSuccess -> do diff --git a/bench/tx-firehose/src/Cardano/Benchmarking/TxFirehose/Tx.hs b/bench/tx-firehose/src/Cardano/Benchmarking/TxFirehose/Tx.hs index a195df0f846..1f92e97bce2 100644 --- a/bench/tx-firehose/src/Cardano/Benchmarking/TxFirehose/Tx.hs +++ b/bench/tx-firehose/src/Cardano/Benchmarking/TxFirehose/Tx.hs @@ -21,14 +21,14 @@ data Fund = Fund } deriving (Eq, Ord, Show) --- | Build and sign a Conway-era transaction spending the given funds and +-- | Build and sign a Dijkstra-era transaction spending the given funds and -- producing @numOutputs@ new UTxOs at @destAddr@. Returns the signed -- transaction and the resulting output funds (indexed 0..numOutputs-1). -- -- No Plutus, no metadata, explicit fee. Change is split evenly across -- outputs with any remainder folded into the first output. buildTx - :: Api.AddressInEra Api.ConwayEra + :: Api.AddressInEra Api.DijkstraEra -- ^ Destination address (also the change address). -> Api.SigningKey Api.PaymentKey -- ^ Key witnessing both inputs and (implicitly) future spends of outputs. @@ -37,7 +37,7 @@ buildTx -- ^ Number of outputs. -> L.Coin -- ^ Fee. - -> Either String (Api.Tx Api.ConwayEra, [Fund]) + -> Either String (Api.Tx Api.DijkstraEra, [Fund]) buildTx destAddr signingKey inFunds numOutputs fee | null inFunds = Left "buildTx: no input funds" | numOutputs == 0 = Left "buildTx: outputs_per_tx must be >= 1" @@ -63,7 +63,7 @@ buildTx destAddr signingKey inFunds numOutputs fee ] in Right (signedTx, outFunds) where - sbe = Api.shelleyBasedEra @Api.ConwayEra + sbe = Api.shelleyBasedEra @Api.DijkstraEra totalIn = sum (map fundValue inFunds) feeLovelace = let L.Coin c = fee in c @@ -96,6 +96,6 @@ buildTx destAddr signingKey inFunds numOutputs fee & Api.setTxFee (Api.TxFeeExplicit sbe (Api.Coin feeLovelace)) & Api.setTxValidityLowerBound Api.TxValidityNoLowerBound & Api.setTxValidityUpperBound - (Api.defaultTxValidityUpperBound Api.ShelleyBasedEraConway) + (Api.defaultTxValidityUpperBound Api.ShelleyBasedEraDijkstra) & Api.setTxMetadata Api.TxMetadataNone & Api.setTxProtocolParams (Api.BuildTxWith Nothing) From d12db95e6e71f00afb308592649ba78e29be8904 Mon Sep 17 00:00:00 2001 From: Sebastian Nagel Date: Sun, 5 Jul 2026 23:24:07 +0200 Subject: [PATCH 03/12] tx-firehose: migrate Tx.hs to Cardano.Api.Experimental MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit The stable Cardano.Api.createTransactionBody path errors out on Dijkstra inside caseShelleyToBabbageOrConwayEraOnwards — the branch that would extract vote / proposal script witnesses hasn't been ported to Dijkstra's cert model yet. See: Cardano.Api.Era.Internal.Case: "TODO Dijkstra: caseShelleyToBabbage OrConwayEraOnwards: Dijkstra requires a separate cert path" makeUnsignedTx from Cardano.Api.Experimental bypasses that path and is already Dijkstra-complete. The rewritten Tx.hs uses it end-to-end: Exp.defaultTxBodyContent |> setTxIns (with AnyKeyWitnessPlaceholder for each key input) |> setTxOuts (Exp.TxOut . toShelleyTxOutAny sbe . Api.TxOut ...) |> setTxFee |> Exp.makeUnsignedTx Exp.DijkstraEra |> Exp.makeKeyWitness + Exp.signTx |> Api.ShelleyTx sbe ledgerTx -- back to old-API Tx era The last step lets Main.hs keep using TxInMode / LocalTxSubmission without any further changes. --- .../src/Cardano/Benchmarking/TxFirehose/Tx.hs | 77 +++++++++---------- 1 file changed, 38 insertions(+), 39 deletions(-) diff --git a/bench/tx-firehose/src/Cardano/Benchmarking/TxFirehose/Tx.hs b/bench/tx-firehose/src/Cardano/Benchmarking/TxFirehose/Tx.hs index 1f92e97bce2..5127bf92454 100644 --- a/bench/tx-firehose/src/Cardano/Benchmarking/TxFirehose/Tx.hs +++ b/bench/tx-firehose/src/Cardano/Benchmarking/TxFirehose/Tx.hs @@ -2,6 +2,18 @@ {-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-deprecations #-} +-- | Dijkstra-era transaction builder. +-- +-- Uses the experimental 'Cardano.Api.Experimental' API because the stable +-- 'Api.createTransactionBody' path is not yet Dijkstra-complete +-- (@caseShelleyToBabbageOrConwayEraOnwards@ errors out on the Dijkstra +-- witness-extraction branch inside 'collectTxBodyScriptWitnessRequirements'). +-- +-- 'Exp.makeUnsignedTx' bypasses that path entirely: it constructs the ledger +-- transaction directly from the experimental 'TxBodyContent (LedgerEra era)'. +-- We wrap the resulting 'Exp.SignedTx' back into an old-style 'Api.Tx' via the +-- 'Api.ShelleyTx' constructor so the caller can hand it to 'TxInMode' / the +-- LocalTxSubmission client without further changes. module Cardano.Benchmarking.TxFirehose.Tx ( Fund (..) , buildTx @@ -12,31 +24,25 @@ import Numeric.Natural (Natural) import Cardano.Api qualified as Api +import Cardano.Api.Experimental qualified as Exp +import Cardano.Api.Experimental.Tx qualified as Exp + import Cardano.Ledger.Coin qualified as L --- | A spendable UTxO under our signing key: reference + value. +-- | A spendable UTxO under our signing key. data Fund = Fund { fundTxIn :: !Api.TxIn , fundValue :: !Integer } deriving (Eq, Ord, Show) --- | Build and sign a Dijkstra-era transaction spending the given funds and --- producing @numOutputs@ new UTxOs at @destAddr@. Returns the signed --- transaction and the resulting output funds (indexed 0..numOutputs-1). --- --- No Plutus, no metadata, explicit fee. Change is split evenly across --- outputs with any remainder folded into the first output. +-- | Build and sign a Dijkstra-era transaction. buildTx :: Api.AddressInEra Api.DijkstraEra - -- ^ Destination address (also the change address). -> Api.SigningKey Api.PaymentKey - -- ^ Key witnessing both inputs and (implicitly) future spends of outputs. -> [Fund] -> Natural - -- ^ Number of outputs. -> L.Coin - -- ^ Fee. -> Either String (Api.Tx Api.DijkstraEra, [Fund]) buildTx destAddr signingKey inFunds numOutputs fee | null inFunds = Left "buildTx: no input funds" @@ -49,12 +55,14 @@ buildTx destAddr signingKey inFunds numOutputs fee "buildTx: output value too low — " ++ show numOutputs ++ " outputs from " ++ show changeTotal ++ " lovelace yields " ++ show minOutputLovelace ++ " per output" - | otherwise = case Api.createTransactionBody sbe txBodyContent of + | otherwise = case Exp.makeUnsignedTx Exp.DijkstraEra bodyContent of Left err -> Left $ "buildTx: " ++ show err - Right txBody -> - let signedTx = Api.signShelleyTransaction sbe txBody - [Api.WitnessPaymentKey signingKey] - txId = Api.getTxId txBody + Right unsigned -> + let keyWit = Exp.makeKeyWitness Exp.DijkstraEra unsigned + (Api.WitnessPaymentKey signingKey) + Exp.SignedTx ledgerTx = Exp.signTx Exp.DijkstraEra [] [keyWit] unsigned + signedTx = Api.ShelleyTx sbe ledgerTx + txId = Api.getTxId (Api.getTxBody signedTx) outFunds = [ Fund { fundTxIn = Api.TxIn txId (Api.TxIx ix) , fundValue = amt @@ -75,27 +83,18 @@ buildTx destAddr signingKey inFunds numOutputs fee remainder = changeTotal `mod` n in (base + remainder) : replicate (fromIntegral numOutputs - 1) base - txIns = - [ ( fundTxIn f - , Api.BuildTxWith - (Api.KeyWitness Api.KeyWitnessForSpending) - ) - | f <- inFunds - ] - - mkTxOut lovelace = Api.TxOut - destAddr - (Api.lovelaceToTxOutValue sbe (Api.Coin lovelace)) - Api.TxOutDatumNone - Api.ReferenceScriptNone + mkOut :: Integer -> Exp.TxOut (Exp.LedgerEra Api.DijkstraEra) + mkOut lovelace = + let apiOut = Api.TxOut + destAddr + (Api.lovelaceToTxOutValue sbe (Api.Coin lovelace)) + Api.TxOutDatumNone + Api.ReferenceScriptNone + in Exp.TxOut (Api.toShelleyTxOutAny sbe apiOut) - 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 Api.ShelleyBasedEraDijkstra) - & Api.setTxMetadata Api.TxMetadataNone - & Api.setTxProtocolParams (Api.BuildTxWith Nothing) + bodyContent = + Exp.defaultTxBodyContent + & Exp.setTxIns + [ (fundTxIn f, Exp.AnyKeyWitnessPlaceholder) | f <- inFunds ] + & Exp.setTxOuts (map mkOut outAmounts) + & Exp.setTxFee fee From 3901b3d6514a7ff66209f95d1b73404b61dd6ead Mon Sep 17 00:00:00 2001 From: Sebastian Nagel Date: Sun, 5 Jul 2026 23:36:05 +0200 Subject: [PATCH 04/12] tx-firehose: ASCII-only log messages, UTF-8 stderr Under LANG=C (the default in the nix sandbox / process-compose) GHC gives stderr a locale encoder that can't encode em-dashes ('\8212'). The first non-ASCII byte throws 'hPutChar: invalid argument' mid-write, which garbles the log line and drops the message. Two belt-and-braces fixes: * Replace em-dashes with '-' in runtime strings so the ASCII-only stderr encoder is happy regardless of locale. * Force stderr to UTF-8 + LineBuffering at the top of main so any future non-ASCII messages don't repeat the problem, and each log line flushes on its own. --- bench/tx-firehose/app/Main.hs | 22 +++++++++++++++---- .../src/Cardano/Benchmarking/TxFirehose/Tx.hs | 4 ++-- 2 files changed, 20 insertions(+), 6 deletions(-) diff --git a/bench/tx-firehose/app/Main.hs b/bench/tx-firehose/app/Main.hs index e6921077408..fbadfef530e 100644 --- a/bench/tx-firehose/app/Main.hs +++ b/bench/tx-firehose/app/Main.hs @@ -19,7 +19,14 @@ import Data.Map.Strict qualified as Map import Data.Set qualified as Set import System.Environment (getArgs) import System.Exit (die) -import System.IO (hPutStrLn, stderr) +import System.IO + ( BufferMode (LineBuffering) + , hPutStrLn + , hSetBuffering + , hSetEncoding + , stderr + , utf8 + ) import Cardano.Api ( AddressAny @@ -71,7 +78,7 @@ import Cardano.Benchmarking.TxFirehose.Tx qualified as Tx -------------------------------------------------------------------------------- --- | Byron epoch length passed in ConsensusModeParams — only used to decode +-- | Byron epoch length passed in ConsensusModeParams -- only used to decode -- Byron EBBs, which we never do. Matches every historical Cardano network -- and is what cardano-cli hardcodes. byronEpochSlots :: Api.EpochSlots @@ -85,6 +92,13 @@ data Pending = Pending main :: IO () main = do + -- Force stderr to UTF-8 + line buffering so log messages don't get + -- garbled or merged when the process runs under `LANG=C` (the default + -- inside process-compose / nix sandbox), and each hPutStrLn appears + -- on its own line. + hSetEncoding stderr utf8 + hSetBuffering stderr LineBuffering + cfgPath <- getArgs >>= \case [p] -> pure p _ -> die "usage: tx-firehose " @@ -107,7 +121,7 @@ main = do hPutStrLn stderr $ "tx-firehose: querying UTxO for " ++ show addrAny initialFunds <- queryFunds connInfo addrAny when (Map.null initialFunds) $ - die "tx-firehose: no UTxO found at derived address — fund it first" + die "tx-firehose: no UTxO found at derived address - fund it first" hPutStrLn stderr $ "tx-firehose: seeded with " ++ show (Map.size initialFunds) ++ " UTxO(s), total " ++ show (sum (Map.elems initialFunds)) ++ " lovelace" @@ -246,7 +260,7 @@ reconcileLoop cfg connInfo addrAny fundsVar = forever $ do threadDelay (round (cfgReconcileEvery cfg * 1_000_000)) fresh <- queryFunds connInfo addrAny STM.atomically $ STM.writeTVar fundsVar fresh - hPutStrLn stderr $ "tx-firehose: reconciled — " + hPutStrLn stderr $ "tx-firehose: reconciled - " ++ show (Map.size fresh) ++ " UTxO(s), total " ++ show (sum (Map.elems fresh)) ++ " lovelace" diff --git a/bench/tx-firehose/src/Cardano/Benchmarking/TxFirehose/Tx.hs b/bench/tx-firehose/src/Cardano/Benchmarking/TxFirehose/Tx.hs index 5127bf92454..997d7c6a2b0 100644 --- a/bench/tx-firehose/src/Cardano/Benchmarking/TxFirehose/Tx.hs +++ b/bench/tx-firehose/src/Cardano/Benchmarking/TxFirehose/Tx.hs @@ -49,10 +49,10 @@ buildTx destAddr signingKey inFunds numOutputs fee | numOutputs == 0 = Left "buildTx: outputs_per_tx must be >= 1" | feeLovelace < 0 = Left "buildTx: fee must be >= 0" | changeTotal <= 0 = Left $ - "buildTx: insufficient funds — total inputs (" ++ show totalIn + "buildTx: insufficient funds - total inputs (" ++ show totalIn ++ " lovelace) do not cover fee (" ++ show feeLovelace ++ ")" | minOutputLovelace <= 0 = Left $ - "buildTx: output value too low — " ++ show numOutputs + "buildTx: output value too low - " ++ show numOutputs ++ " outputs from " ++ show changeTotal ++ " lovelace yields " ++ show minOutputLovelace ++ " per output" | otherwise = case Exp.makeUnsignedTx Exp.DijkstraEra bodyContent of From 13dd485436758aa0ef004c41dd6101e995e05f63 Mon Sep 17 00:00:00 2001 From: Sebastian Nagel Date: Sun, 5 Jul 2026 23:43:26 +0200 Subject: [PATCH 05/12] tx-firehose: optional stakingKeyFile for base-address derivation MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Shelley initialFunds with a delegator setup live at base addresses (payment credential + stake credential). Deriving an enterprise address from just the payment key looks up a different, empty address. Add an optional stakingKeyFile config field: when set, we load the stake signing key, derive its verification key hash, and construct a base address. When omitted, behaviour is unchanged (enterprise address), matching the genesis-utxo-key case. Note that only the vkey hash is used — the stake key does not have to sign anything, so we don't need to keep the signing key around after boot. --- bench/tx-firehose/app/Main.hs | 28 ++++++++++++++++--- .../Cardano/Benchmarking/TxFirehose/Config.hs | 24 ++++++++++------ 2 files changed, 40 insertions(+), 12 deletions(-) diff --git a/bench/tx-firehose/app/Main.hs b/bench/tx-firehose/app/Main.hs index fbadfef530e..db82ccdd40e 100644 --- a/bench/tx-firehose/app/Main.hs +++ b/bench/tx-firehose/app/Main.hs @@ -105,9 +105,10 @@ main = do cfg <- loadConfig cfgPath signingKey <- loadSigningKey (cfgSigningKeyFile cfg) + mStakeVk <- traverse loadStakingKey (cfgStakingKeyFile cfg) let networkId = Testnet (NetworkMagic (fromIntegral (cfgNetworkMagic cfg))) - addrInEra = deriveAddress networkId signingKey + addrInEra = deriveAddress networkId signingKey mStakeVk addrAny = case addrInEra of Api.AddressInEra _ addr -> Api.toAddressAny addr connInfo = LocalNodeConnectInfo @@ -161,14 +162,33 @@ loadSigningKey path = do , FromSomeType (Api.AsSigningKey Api.AsPaymentKey) id ] +-- | Load a stake signing key (from a .skey text envelope) and derive its +-- verification key. Only the vkey hash is needed to build a base address — +-- the stake key does not have to sign anything (payment credential does). +loadStakingKey :: FilePath -> IO (Api.VerificationKey Api.StakeKey) +loadStakingKey path = do + result <- Api.readFileTextEnvelope (File path) + case result of + Left err -> die $ "tx-firehose: cannot read stake key " + ++ show path ++ ": " ++ show err + Right (sk :: SigningKey Api.StakeKey) -> pure (Api.getVerificationKey sk) + deriveAddress - :: NetworkId -> SigningKey Api.PaymentKey -> AddressInEra Api.DijkstraEra -deriveAddress networkId sk = + :: NetworkId + -> SigningKey Api.PaymentKey + -> Maybe (Api.VerificationKey Api.StakeKey) + -> AddressInEra Api.DijkstraEra +deriveAddress networkId sk mStakeVk = Api.shelleyAddressInEra (Api.shelleyBasedEra @Api.DijkstraEra) $ Api.makeShelleyAddress networkId (PaymentCredentialByKey (Api.verificationKeyHash (Api.getVerificationKey sk))) - NoStakeAddress + stakeRef + where + stakeRef = case mStakeVk of + Nothing -> NoStakeAddress + Just vk -> Api.StakeAddressByValue + (Api.StakeCredentialByKey (Api.verificationKeyHash vk)) -------------------------------------------------------------------------------- -- Era sanity check diff --git a/bench/tx-firehose/src/Cardano/Benchmarking/TxFirehose/Config.hs b/bench/tx-firehose/src/Cardano/Benchmarking/TxFirehose/Config.hs index 80bbd5e64f8..a256c943320 100644 --- a/bench/tx-firehose/src/Cardano/Benchmarking/TxFirehose/Config.hs +++ b/bench/tx-firehose/src/Cardano/Benchmarking/TxFirehose/Config.hs @@ -14,14 +14,20 @@ import Numeric.Natural (Natural) import System.Exit (die) data Config = Config - { cfgSocketPath :: !FilePath - , cfgNetworkMagic :: !Natural - , cfgSigningKeyFile :: !FilePath - , cfgTps :: !Double - , cfgInputsPerTx :: !Natural - , cfgOutputsPerTx :: !Natural - , cfgFee :: !Integer - , cfgReconcileEvery :: !Double + { cfgSocketPath :: !FilePath + , cfgNetworkMagic :: !Natural + , cfgSigningKeyFile :: !FilePath + , cfgStakingKeyFile :: !(Maybe FilePath) + -- ^ Optional stake signing key. If provided, the derived address is a + -- base address (payment credential + stake credential); otherwise it + -- is an enterprise address. Set this when spending from a genesis + -- entry whose address includes a stake credential (e.g. Shelley + -- initialFunds with a delegator setup). + , cfgTps :: !Double + , cfgInputsPerTx :: !Natural + , cfgOutputsPerTx :: !Natural + , cfgFee :: !Integer + , cfgReconcileEvery :: !Double -- ^ Requery UTxO by address every N seconds. 0 disables periodic -- reconciliation (still requeries at startup and on sync errors). } @@ -32,6 +38,7 @@ instance Aeson.FromJSON Config where socketPath <- o .: "socketPath" networkMagic <- o .: "networkMagic" signingKeyFile <- o .: "signingKeyFile" + stakingKeyFile <- o .:? "stakingKeyFile" tps <- o .: "tps" inputsPerTx <- o .:? "inputsPerTx" Aeson..!= 1 outputsPerTx <- o .:? "outputsPerTx" Aeson..!= 1 @@ -41,6 +48,7 @@ instance Aeson.FromJSON Config where { cfgSocketPath = socketPath , cfgNetworkMagic = networkMagic , cfgSigningKeyFile = signingKeyFile + , cfgStakingKeyFile = stakingKeyFile , cfgTps = tps , cfgInputsPerTx = inputsPerTx , cfgOutputsPerTx = outputsPerTx From bbb507764f4c53f64ccac60d370660d1e9166bed Mon Sep 17 00:00:00 2001 From: Sebastian Nagel Date: Sun, 5 Jul 2026 23:55:28 +0200 Subject: [PATCH 06/12] tx-firehose: drop reconcile loop, add consecutive-error kill switch MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Reconciling the local fund set against on-chain UTxO during a run was buying almost nothing: the local set diverges by design (we recycle mempool outputs optimistically), and a periodic replace-reconcile introduced its own race — replacing while descendants were still in mempool caused a wave of AllInputsAreSpent rejects. Simpler: keep the local set append-only during a run, count consecutive rejects, and exit with a message when the count crosses a configurable threshold (default 50). A supervisor restart then requeries UTxO from a clean slate. Configuration: - Removed: reconcileEvery - Added: maxConsecutiveErrors (default 50) The reconcileLoop function and its Async.race_ wiring are gone; main now just links the persistent submission client and runs the submit loop in the foreground. --- bench/tx-firehose/app/Main.hs | 50 ++++++++----------- .../Cardano/Benchmarking/TxFirehose/Config.hs | 36 +++++++------ 2 files changed, 42 insertions(+), 44 deletions(-) diff --git a/bench/tx-firehose/app/Main.hs b/bench/tx-firehose/app/Main.hs index db82ccdd40e..04cf0a6adda 100644 --- a/bench/tx-firehose/app/Main.hs +++ b/bench/tx-firehose/app/Main.hs @@ -14,6 +14,7 @@ import Control.Concurrent.STM (TMVar, TQueue, TVar) import Control.Concurrent.STM qualified as STM import Control.Monad (forever, when) import Control.Monad.Trans.Except (runExceptT) +import Data.IORef qualified as IORef import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map import Data.Set qualified as Set @@ -130,19 +131,12 @@ main = do fundsVar <- STM.newTVarIO initialFunds pendingQueue <- STM.newTQueueIO - let clientThread = runSubmissionClient connInfo pendingQueue - submitter = submitLoop cfg addrInEra signingKey fundsVar pendingQueue - reconciler - | cfgReconcileEvery cfg <= 0 = forever (threadDelay maxBound) - | otherwise = reconcileLoop cfg connInfo addrAny fundsVar - -- The submission client owns the wire; if it dies (socket closed, node -- restarted, protocol error) we want to die with it. Link so the exception - -- propagates. race_ ties the submitter and reconciler together so the - -- first to fail brings the other down. - Async.withAsync clientThread $ \clientA -> do + -- propagates while the submit loop runs in the foreground. + Async.withAsync (runSubmissionClient connInfo pendingQueue) $ \clientA -> do Async.link clientA - Async.race_ submitter reconciler + submitLoop cfg addrInEra signingKey fundsVar pendingQueue -------------------------------------------------------------------------------- -- Signing key & address @@ -266,30 +260,18 @@ submitViaQueue q tx = do STM.atomically $ STM.writeTQueue q (Pending tx reply) STM.atomically $ STM.takeTMVar reply --------------------------------------------------------------------------------- --- Reconcile loop --------------------------------------------------------------------------------- - --- | Periodically replace the local fund set with a fresh UTxO query. --- Mempool-only outputs are temporarily lost and reappear on the next --- reconcile once they're on chain. Keeps drift bounded. -reconcileLoop - :: Config -> LocalNodeConnectInfo -> AddressAny - -> TVar (Map Api.TxIn Integer) -> IO () -reconcileLoop cfg connInfo addrAny fundsVar = forever $ do - threadDelay (round (cfgReconcileEvery cfg * 1_000_000)) - fresh <- queryFunds connInfo addrAny - STM.atomically $ STM.writeTVar fundsVar fresh - hPutStrLn stderr $ "tx-firehose: reconciled - " - ++ show (Map.size fresh) ++ " UTxO(s), total " - ++ show (sum (Map.elems fresh)) ++ " lovelace" - -------------------------------------------------------------------------------- -- Submit loop -------------------------------------------------------------------------------- -- | Rate-limited loop: take @inputsPerTx@ funds, build a tx, submit via the -- persistent queue, dispatch on the reply. +-- +-- We deliberately do NOT try to reconcile the local fund set with the ledger +-- while running: the local set is populated optimistically from every +-- SubmitSuccess and will diverge under normal chain progress. Instead we +-- track consecutive rejects and die once they cross the configured +-- threshold. The supervisor restarts us and we requery from a clean slate. submitLoop :: Config -> AddressInEra Api.DijkstraEra @@ -300,6 +282,15 @@ submitLoop submitLoop cfg addr sk fundsVar pendingQueue = do let period = round (1_000_000 / cfgTps cfg) :: Int n = fromIntegral (cfgInputsPerTx cfg) :: Int + maxErrs = cfgMaxConsecutiveErrors cfg + consecutive <- IORef.newIORef (0 :: Int) + let bumpError reason = do + c <- IORef.atomicModifyIORef' consecutive (\c -> (c + 1, c + 1)) + when (c >= maxErrs) $ + die $ "tx-firehose: " ++ show maxErrs + ++ " consecutive rejects, exiting for restart (last: " + ++ reason ++ ")" + resetError = IORef.writeIORef consecutive 0 forever $ do inputs <- STM.atomically $ do m <- STM.readTVar fundsVar @@ -315,6 +306,7 @@ submitLoop cfg addr sk fundsVar pendingQueue = do Left err -> do hPutStrLn stderr $ "tx-firehose: buildTx failed: " ++ err returnFunds fundsVar inputs + bumpError ("buildTx: " ++ err) threadDelay period Right (signedTx, outFunds) -> do let txId = Api.getTxId (Api.getTxBody signedTx) @@ -325,10 +317,12 @@ submitLoop cfg addr sk fundsVar pendingQueue = do hPutStrLn stderr $ "tx-firehose: submitted " ++ show txId STM.atomically $ STM.modifyTVar' fundsVar $ \m -> foldr (\f -> Map.insert (fundTxIn f) (fundValue f)) m outFunds + resetError SubmitFail reason -> do hPutStrLn stderr $ "tx-firehose: rejected " ++ show txId ++ ": " ++ show reason returnFunds fundsVar inputs + bumpError (show reason) threadDelay period returnFunds :: TVar (Map Api.TxIn Integer) -> [(Api.TxIn, Integer)] -> IO () diff --git a/bench/tx-firehose/src/Cardano/Benchmarking/TxFirehose/Config.hs b/bench/tx-firehose/src/Cardano/Benchmarking/TxFirehose/Config.hs index a256c943320..bd00eb30740 100644 --- a/bench/tx-firehose/src/Cardano/Benchmarking/TxFirehose/Config.hs +++ b/bench/tx-firehose/src/Cardano/Benchmarking/TxFirehose/Config.hs @@ -27,9 +27,11 @@ data Config = Config , cfgInputsPerTx :: !Natural , cfgOutputsPerTx :: !Natural , cfgFee :: !Integer - , cfgReconcileEvery :: !Double - -- ^ Requery UTxO by address every N seconds. 0 disables periodic - -- reconciliation (still requeries at startup and on sync errors). + , cfgMaxConsecutiveErrors :: !Int + -- ^ Exit the process after this many consecutive rejects. The idea: + -- keep tx-firehose stateless and dumb; when the local fund set drifts + -- from the ledger badly enough to lose N in a row, let the supervisor + -- restart us and we'll requery UTxO fresh. } deriving Show @@ -40,20 +42,20 @@ instance Aeson.FromJSON Config where signingKeyFile <- o .: "signingKeyFile" stakingKeyFile <- o .:? "stakingKeyFile" tps <- o .: "tps" - inputsPerTx <- o .:? "inputsPerTx" Aeson..!= 1 - outputsPerTx <- o .:? "outputsPerTx" Aeson..!= 1 - fee <- o .:? "fee" Aeson..!= 200_000 - reconcileEvery <- o .:? "reconcileEvery" Aeson..!= 60 + inputsPerTx <- o .:? "inputsPerTx" Aeson..!= 1 + outputsPerTx <- o .:? "outputsPerTx" Aeson..!= 1 + fee <- o .:? "fee" Aeson..!= 200_000 + maxErrs <- o .:? "maxConsecutiveErrors" Aeson..!= 50 pure Config - { cfgSocketPath = socketPath - , cfgNetworkMagic = networkMagic - , cfgSigningKeyFile = signingKeyFile - , cfgStakingKeyFile = stakingKeyFile - , cfgTps = tps - , cfgInputsPerTx = inputsPerTx - , cfgOutputsPerTx = outputsPerTx - , cfgFee = fee - , cfgReconcileEvery = reconcileEvery + { cfgSocketPath = socketPath + , cfgNetworkMagic = networkMagic + , cfgSigningKeyFile = signingKeyFile + , cfgStakingKeyFile = stakingKeyFile + , cfgTps = tps + , cfgInputsPerTx = inputsPerTx + , cfgOutputsPerTx = outputsPerTx + , cfgFee = fee + , cfgMaxConsecutiveErrors = maxErrs } loadConfig :: FilePath -> IO Config @@ -65,5 +67,7 @@ loadConfig path = do when (cfgTps cfg <= 0) $ die "tps must be > 0" when (cfgInputsPerTx cfg == 0) $ die "inputsPerTx must be >= 1" when (cfgOutputsPerTx cfg == 0) $ die "outputsPerTx must be >= 1" + when (cfgMaxConsecutiveErrors cfg <= 0) $ + die "maxConsecutiveErrors must be >= 1" when (cfgFee cfg < 0) $ die "fee must be >= 0" pure cfg From 897da8059d9d769c2d07661f59750ff2783dc845 Mon Sep 17 00:00:00 2001 From: Sebastian Nagel Date: Mon, 6 Jul 2026 00:10:45 +0200 Subject: [PATCH 07/12] tx-firehose: drop JSON config, switch to CLI flags Most of the config was static per-run and the JSON round-trip added more code than it saved. Replace it with an optparse-applicative parser whose flag names mirror cardano-cli conventions: --socket-path (was JSON socketPath) --testnet-magic (was JSON networkMagic) --signing-key-file (was JSON signingKeyFile) --staking-key-file (was JSON stakingKeyFile) --tps --inputs-per-tx --outputs-per-tx --fee --max-consecutive-errors Net: deletes the Config module (~60 lines of Aeson boilerplate) in exchange for a ~30-line parser inline in Main. `--help` and error messages come for free. New dep: optparse-applicative (transitive in this repo already). --- bench/tx-firehose/app/Main.hs | 93 ++++++++++++++----- .../Cardano/Benchmarking/TxFirehose/Config.hs | 73 --------------- bench/tx-firehose/tx-firehose.cabal | 5 +- 3 files changed, 73 insertions(+), 98 deletions(-) delete mode 100644 bench/tx-firehose/src/Cardano/Benchmarking/TxFirehose/Config.hs diff --git a/bench/tx-firehose/app/Main.hs b/bench/tx-firehose/app/Main.hs index 04cf0a6adda..79bf733b10f 100644 --- a/bench/tx-firehose/app/Main.hs +++ b/bench/tx-firehose/app/Main.hs @@ -1,6 +1,5 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE ImportQualifiedPost #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -8,6 +7,7 @@ module Main (main) where +import Control.Applicative (optional) import Control.Concurrent (threadDelay) import Control.Concurrent.Async qualified as Async import Control.Concurrent.STM (TMVar, TQueue, TVar) @@ -18,7 +18,8 @@ import Data.IORef qualified as IORef import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map import Data.Set qualified as Set -import System.Environment (getArgs) +import Numeric.Natural (Natural) +import Options.Applicative qualified as Opt import System.Exit (die) import System.IO ( BufferMode (LineBuffering) @@ -70,10 +71,6 @@ import Ouroboros.Network.Protocol.LocalTxSubmission.Client , LocalTxSubmissionClient (LocalTxSubmissionClient) ) -import Cardano.Benchmarking.TxFirehose.Config - ( Config (..) - , loadConfig - ) import Cardano.Benchmarking.TxFirehose.Tx (Fund (Fund, fundTxIn, fundValue)) import Cardano.Benchmarking.TxFirehose.Tx qualified as Tx @@ -91,6 +88,56 @@ data Pending = Pending !TxInMode !(TMVar (SubmitResult TxValidationErrorInCardanoMode)) +-- | Command-line options. Set the optional 'optStakingKey' to spend from a +-- base address (payment + stake); omit for an enterprise address. +data Options = Options + { optSocketPath :: !FilePath + , optNetworkMagic :: !Natural + , optSigningKey :: !FilePath + , optStakingKey :: !(Maybe FilePath) + , optTps :: !Double + , optInputsPerTx :: !Natural + , optOutputsPerTx :: !Natural + , optFee :: !Integer + , optMaxConsecutiveErrors :: !Int + } + +optionsParser :: Opt.Parser Options +optionsParser = Options + <$> Opt.strOption + ( Opt.long "socket-path" <> Opt.metavar "SOCKET_PATH" + <> Opt.help "Path to the node socket (node-to-client)" ) + <*> Opt.option Opt.auto + ( Opt.long "testnet-magic" <> Opt.metavar "NATURAL" + <> Opt.help "Specify a testnet magic id (e.g. 164 for leios proto-devnet)" ) + <*> Opt.strOption + ( Opt.long "signing-key-file" <> Opt.metavar "FILEPATH" + <> Opt.help "Payment signing key (.skey; GenesisUTxOKey also accepted)" ) + <*> optional (Opt.strOption + ( Opt.long "staking-key-file" <> Opt.metavar "FILEPATH" + <> Opt.help "Stake signing key (.skey). If set, derive a base address; else enterprise." )) + <*> Opt.option Opt.auto + ( Opt.long "tps" <> Opt.metavar "NATURAL" + <> Opt.help "Target submissions per second (rate ceiling)" ) + <*> Opt.option Opt.auto + ( Opt.long "inputs-per-tx" <> Opt.metavar "NATURAL" <> Opt.value 1 <> Opt.showDefault + <> Opt.help "Number of inputs per generated tx" ) + <*> Opt.option Opt.auto + ( Opt.long "outputs-per-tx" <> Opt.metavar "NATURAL" <> Opt.value 1 <> Opt.showDefault + <> Opt.help "Number of outputs per generated tx" ) + <*> Opt.option Opt.auto + ( Opt.long "fee" <> Opt.metavar "LOVELACE" <> Opt.value 200_000 <> Opt.showDefault + <> Opt.help "Fixed fee per tx (lovelace)" ) + <*> Opt.option Opt.auto + ( Opt.long "max-consecutive-errors" <> Opt.metavar "NATURAL" <> Opt.value 50 <> Opt.showDefault + <> Opt.help "Exit after this many consecutive rejects (for supervisor restart)" ) + +parseOptions :: IO Options +parseOptions = Opt.execParser $ Opt.info (optionsParser Opt.<**> Opt.helper) + ( Opt.fullDesc + <> Opt.progDesc "Push-based single-node tx load generator over node-to-client." + <> Opt.header "tx-firehose - hose transactions at one Cardano node" ) + main :: IO () main = do -- Force stderr to UTF-8 + line buffering so log messages don't get @@ -100,22 +147,24 @@ main = do hSetEncoding stderr utf8 hSetBuffering stderr LineBuffering - cfgPath <- getArgs >>= \case - [p] -> pure p - _ -> die "usage: tx-firehose " - cfg <- loadConfig cfgPath + opts <- parseOptions + when (optTps opts <= 0) $ die "--tps must be > 0" + when (optInputsPerTx opts == 0) $ die "--inputs-per-tx must be >= 1" + when (optOutputsPerTx opts == 0) $ die "--outputs-per-tx must be >= 1" + when (optMaxConsecutiveErrors opts <= 0) $ + die "--max-consecutive-errors must be >= 1" - signingKey <- loadSigningKey (cfgSigningKeyFile cfg) - mStakeVk <- traverse loadStakingKey (cfgStakingKeyFile cfg) + signingKey <- loadSigningKey (optSigningKey opts) + mStakeVk <- traverse loadStakingKey (optStakingKey opts) - let networkId = Testnet (NetworkMagic (fromIntegral (cfgNetworkMagic cfg))) + let networkId = Testnet (NetworkMagic (fromIntegral (optNetworkMagic opts))) addrInEra = deriveAddress networkId signingKey mStakeVk addrAny = case addrInEra of Api.AddressInEra _ addr -> Api.toAddressAny addr connInfo = LocalNodeConnectInfo { Api.localConsensusModeParams = CardanoModeParams byronEpochSlots , Api.localNodeNetworkId = networkId - , Api.localNodeSocketPath = File (cfgSocketPath cfg) + , Api.localNodeSocketPath = File (optSocketPath opts) } ensureDijkstra connInfo @@ -136,7 +185,7 @@ main = do -- propagates while the submit loop runs in the foreground. Async.withAsync (runSubmissionClient connInfo pendingQueue) $ \clientA -> do Async.link clientA - submitLoop cfg addrInEra signingKey fundsVar pendingQueue + submitLoop opts addrInEra signingKey fundsVar pendingQueue -------------------------------------------------------------------------------- -- Signing key & address @@ -273,16 +322,16 @@ submitViaQueue q tx = do -- track consecutive rejects and die once they cross the configured -- threshold. The supervisor restarts us and we requery from a clean slate. submitLoop - :: Config + :: Options -> AddressInEra Api.DijkstraEra -> SigningKey Api.PaymentKey -> TVar (Map Api.TxIn Integer) -> TQueue Pending -> IO () -submitLoop cfg addr sk fundsVar pendingQueue = do - let period = round (1_000_000 / cfgTps cfg) :: Int - n = fromIntegral (cfgInputsPerTx cfg) :: Int - maxErrs = cfgMaxConsecutiveErrors cfg +submitLoop opts addr sk fundsVar pendingQueue = do + let period = round (1_000_000 / optTps opts) :: Int + n = fromIntegral (optInputsPerTx opts) :: Int + maxErrs = optMaxConsecutiveErrors opts consecutive <- IORef.newIORef (0 :: Int) let bumpError reason = do c <- IORef.atomicModifyIORef' consecutive (\c -> (c + 1, c + 1)) @@ -301,8 +350,8 @@ submitLoop cfg addr sk fundsVar pendingQueue = do pure taken let inFunds = [ Fund { fundTxIn = tin, fundValue = v } | (tin, v) <- inputs ] - case Tx.buildTx addr sk inFunds (cfgOutputsPerTx cfg) - (L.Coin (cfgFee cfg)) of + case Tx.buildTx addr sk inFunds (optOutputsPerTx opts) + (L.Coin (optFee opts)) of Left err -> do hPutStrLn stderr $ "tx-firehose: buildTx failed: " ++ err returnFunds fundsVar inputs diff --git a/bench/tx-firehose/src/Cardano/Benchmarking/TxFirehose/Config.hs b/bench/tx-firehose/src/Cardano/Benchmarking/TxFirehose/Config.hs deleted file mode 100644 index bd00eb30740..00000000000 --- a/bench/tx-firehose/src/Cardano/Benchmarking/TxFirehose/Config.hs +++ /dev/null @@ -1,73 +0,0 @@ -{-# LANGUAGE ImportQualifiedPost #-} -{-# LANGUAGE NumericUnderscores #-} -{-# LANGUAGE OverloadedStrings #-} - -module Cardano.Benchmarking.TxFirehose.Config - ( Config (..) - , loadConfig - ) where - -import Control.Monad (when) -import Data.Aeson ((.:), (.:?)) -import Data.Aeson qualified as Aeson -import Numeric.Natural (Natural) -import System.Exit (die) - -data Config = Config - { cfgSocketPath :: !FilePath - , cfgNetworkMagic :: !Natural - , cfgSigningKeyFile :: !FilePath - , cfgStakingKeyFile :: !(Maybe FilePath) - -- ^ Optional stake signing key. If provided, the derived address is a - -- base address (payment credential + stake credential); otherwise it - -- is an enterprise address. Set this when spending from a genesis - -- entry whose address includes a stake credential (e.g. Shelley - -- initialFunds with a delegator setup). - , cfgTps :: !Double - , cfgInputsPerTx :: !Natural - , cfgOutputsPerTx :: !Natural - , cfgFee :: !Integer - , cfgMaxConsecutiveErrors :: !Int - -- ^ Exit the process after this many consecutive rejects. The idea: - -- keep tx-firehose stateless and dumb; when the local fund set drifts - -- from the ledger badly enough to lose N in a row, let the supervisor - -- restart us and we'll requery UTxO fresh. - } - deriving Show - -instance Aeson.FromJSON Config where - parseJSON = Aeson.withObject "Config" $ \o -> do - socketPath <- o .: "socketPath" - networkMagic <- o .: "networkMagic" - signingKeyFile <- o .: "signingKeyFile" - stakingKeyFile <- o .:? "stakingKeyFile" - tps <- o .: "tps" - inputsPerTx <- o .:? "inputsPerTx" Aeson..!= 1 - outputsPerTx <- o .:? "outputsPerTx" Aeson..!= 1 - fee <- o .:? "fee" Aeson..!= 200_000 - maxErrs <- o .:? "maxConsecutiveErrors" Aeson..!= 50 - pure Config - { cfgSocketPath = socketPath - , cfgNetworkMagic = networkMagic - , cfgSigningKeyFile = signingKeyFile - , cfgStakingKeyFile = stakingKeyFile - , cfgTps = tps - , cfgInputsPerTx = inputsPerTx - , cfgOutputsPerTx = outputsPerTx - , cfgFee = fee - , cfgMaxConsecutiveErrors = maxErrs - } - -loadConfig :: FilePath -> IO Config -loadConfig path = do - bytes <- Aeson.eitherDecodeFileStrict path - case bytes of - Left err -> die $ "Config parse error in " ++ path ++ ": " ++ err - Right cfg -> do - when (cfgTps cfg <= 0) $ die "tps must be > 0" - when (cfgInputsPerTx cfg == 0) $ die "inputsPerTx must be >= 1" - when (cfgOutputsPerTx cfg == 0) $ die "outputsPerTx must be >= 1" - when (cfgMaxConsecutiveErrors cfg <= 0) $ - die "maxConsecutiveErrors must be >= 1" - when (cfgFee cfg < 0) $ die "fee must be >= 0" - pure cfg diff --git a/bench/tx-firehose/tx-firehose.cabal b/bench/tx-firehose/tx-firehose.cabal index 0c45490a6c5..935749700b8 100644 --- a/bench/tx-firehose/tx-firehose.cabal +++ b/bench/tx-firehose/tx-firehose.cabal @@ -31,10 +31,8 @@ common project-config library import: project-config hs-source-dirs: src - exposed-modules: Cardano.Benchmarking.TxFirehose.Config - Cardano.Benchmarking.TxFirehose.Tx + exposed-modules: Cardano.Benchmarking.TxFirehose.Tx build-depends: base >= 4.14 && < 5 - , aeson , cardano-api , cardano-ledger-core @@ -50,6 +48,7 @@ executable tx-firehose , cardano-api , cardano-ledger-core , containers + , optparse-applicative , ouroboros-network:protocols , stm , transformers From 5c9bd34af4a7d47c4104ffc5e69bdb7dfe36e2c7 Mon Sep 17 00:00:00 2001 From: Sebastian Nagel Date: Mon, 6 Jul 2026 08:03:55 +0200 Subject: [PATCH 08/12] tx-firehose: emit structured JSON traces on stderr The proto-devnet Alloy pipeline expects log lines in the cardano-node trace schema (@{at, sev, host, thread, ns, data}@) so it can extract namespaces and drive Grafana panels off Loki queries filtered by @ns=...@. Plain-text stderr got dropped by the JSON-parse stage in extract_cardano_node_logs. Add a small @trace@ helper that emits one JSON line per event with that schema, and switch every hPutStrLn site over. Namespaces are hierarchical so dashboards can filter with exact-match or a prefix: TxFirehose.Startup.Query -- one at boot; data: address TxFirehose.Startup.Seeded -- one at boot; data: utxos, totalLovelace TxFirehose.Submit.Success -- one per accepted tx; data: tx TxFirehose.Submit.Reject -- one per rejected tx; data: tx, reason TxFirehose.Build.Fail -- buildTx errors TxFirehose.Exit.MaxErrors -- consecutive-rejects kill switch fired Throughput = rate(Submit.Success), reject rate = rate(Submit.Reject). --- bench/tx-firehose/app/Main.hs | 55 +++++++++++++++++++++++------ bench/tx-firehose/tx-firehose.cabal | 4 +++ 2 files changed, 49 insertions(+), 10 deletions(-) diff --git a/bench/tx-firehose/app/Main.hs b/bench/tx-firehose/app/Main.hs index 79bf733b10f..563b4e79e7d 100644 --- a/bench/tx-firehose/app/Main.hs +++ b/bench/tx-firehose/app/Main.hs @@ -1,6 +1,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-deprecations #-} @@ -14,16 +15,22 @@ import Control.Concurrent.STM (TMVar, TQueue, TVar) import Control.Concurrent.STM qualified as STM import Control.Monad (forever, when) import Control.Monad.Trans.Except (runExceptT) +import Data.Aeson (Value, (.=)) +import Data.Aeson qualified as Aeson +import Data.ByteString.Lazy.Char8 qualified as BSL import Data.IORef qualified as IORef import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map import Data.Set qualified as Set +import Data.Text (Text) +import Data.Text qualified as T +import Data.Time.Clock (getCurrentTime) +import Data.Time.Format.ISO8601 (iso8601Show) import Numeric.Natural (Natural) import Options.Applicative qualified as Opt import System.Exit (die) import System.IO ( BufferMode (LineBuffering) - , hPutStrLn , hSetBuffering , hSetEncoding , stderr @@ -88,6 +95,24 @@ data Pending = Pending !TxInMode !(TMVar (SubmitResult TxValidationErrorInCardanoMode)) +-- | Emit one line of structured JSON on stderr, in the shape the +-- proto-devnet Alloy log pipeline expects +-- (@{at, sev, host, thread, ns, data}@ — the cardano-node trace +-- schema). Rate / event counts in Grafana can then be derived by +-- filtering on the @ns@ label. +trace :: Text -> Text -> Value -> IO () +trace ns sev dat = do + now <- getCurrentTime + let payload = Aeson.object + [ "at" .= T.pack (iso8601Show now) + , "sev" .= sev + , "host" .= ("tx-firehose" :: Text) + , "thread" .= ("main" :: Text) + , "ns" .= ns + , "data" .= dat + ] + BSL.hPutStrLn stderr (Aeson.encode payload) + -- | Command-line options. Set the optional 'optStakingKey' to spend from a -- base address (payment + stake); omit for an enterprise address. data Options = Options @@ -169,13 +194,15 @@ main = do ensureDijkstra connInfo - hPutStrLn stderr $ "tx-firehose: querying UTxO for " ++ show addrAny + trace "TxFirehose.Startup.Query" "Info" $ + Aeson.object ["address" .= T.pack (show addrAny)] initialFunds <- queryFunds connInfo addrAny when (Map.null initialFunds) $ die "tx-firehose: no UTxO found at derived address - fund it first" - hPutStrLn stderr $ "tx-firehose: seeded with " - ++ show (Map.size initialFunds) ++ " UTxO(s), total " - ++ show (sum (Map.elems initialFunds)) ++ " lovelace" + trace "TxFirehose.Startup.Seeded" "Info" $ Aeson.object + [ "utxos" .= Map.size initialFunds + , "totalLovelace" .= sum (Map.elems initialFunds) + ] fundsVar <- STM.newTVarIO initialFunds pendingQueue <- STM.newTQueueIO @@ -335,7 +362,11 @@ submitLoop opts addr sk fundsVar pendingQueue = do consecutive <- IORef.newIORef (0 :: Int) let bumpError reason = do c <- IORef.atomicModifyIORef' consecutive (\c -> (c + 1, c + 1)) - when (c >= maxErrs) $ + when (c >= maxErrs) $ do + trace "TxFirehose.Exit.MaxErrors" "Error" $ Aeson.object + [ "threshold" .= maxErrs + , "lastReason" .= T.pack reason + ] die $ "tx-firehose: " ++ show maxErrs ++ " consecutive rejects, exiting for restart (last: " ++ reason ++ ")" @@ -353,7 +384,8 @@ submitLoop opts addr sk fundsVar pendingQueue = do case Tx.buildTx addr sk inFunds (optOutputsPerTx opts) (L.Coin (optFee opts)) of Left err -> do - hPutStrLn stderr $ "tx-firehose: buildTx failed: " ++ err + trace "TxFirehose.Build.Fail" "Error" $ + Aeson.object ["error" .= T.pack err] returnFunds fundsVar inputs bumpError ("buildTx: " ++ err) threadDelay period @@ -363,13 +395,16 @@ submitLoop opts addr sk fundsVar pendingQueue = do result <- submitViaQueue pendingQueue txInMode case result of SubmitSuccess -> do - hPutStrLn stderr $ "tx-firehose: submitted " ++ show txId + trace "TxFirehose.Submit.Success" "Info" $ + Aeson.object ["tx" .= T.pack (show txId)] STM.atomically $ STM.modifyTVar' fundsVar $ \m -> foldr (\f -> Map.insert (fundTxIn f) (fundValue f)) m outFunds resetError SubmitFail reason -> do - hPutStrLn stderr $ "tx-firehose: rejected " ++ show txId - ++ ": " ++ show reason + trace "TxFirehose.Submit.Reject" "Warning" $ Aeson.object + [ "tx" .= T.pack (show txId) + , "reason" .= T.pack (show reason) + ] returnFunds fundsVar inputs bumpError (show reason) threadDelay period diff --git a/bench/tx-firehose/tx-firehose.cabal b/bench/tx-firehose/tx-firehose.cabal index 935749700b8..310ba20afb1 100644 --- a/bench/tx-firehose/tx-firehose.cabal +++ b/bench/tx-firehose/tx-firehose.cabal @@ -44,12 +44,16 @@ executable tx-firehose -rtsopts "-with-rtsopts=-N -T" build-depends: base >= 4.14 && < 5 + , aeson , async + , bytestring , cardano-api , cardano-ledger-core , containers , optparse-applicative , ouroboros-network:protocols , stm + , text + , time , transformers , tx-firehose From 84ce9e5df20eae654701950aa2ba72c85740e4f3 Mon Sep 17 00:00:00 2001 From: Sebastian Nagel Date: Mon, 6 Jul 2026 08:23:16 +0200 Subject: [PATCH 09/12] tx-firehose: emit txId (hex) and size on Submit events Two small trace payload fixes on the Submit.Success / Submit.Reject events: - "tx" -> "txId", serialised via serialiseToRawBytesHexText. Was T.pack (show txId), which round-tripped through Show and gave "\"aba32...\"" - a JSON string with embedded quotes. - Add "size": the wire size of the tx (BS.length of serialiseToCBOR). Lets downstream dashboards compute byte-rate directly instead of multiplying tx-count by an assumed constant. Sample after: {"data":{"txId":"adebeacd...","size":228},"ns":"TxFirehose.Submit.Reject",...} --- bench/tx-firehose/app/Main.hs | 15 +++++++++++---- 1 file changed, 11 insertions(+), 4 deletions(-) diff --git a/bench/tx-firehose/app/Main.hs b/bench/tx-firehose/app/Main.hs index 563b4e79e7d..441adaddc75 100644 --- a/bench/tx-firehose/app/Main.hs +++ b/bench/tx-firehose/app/Main.hs @@ -17,6 +17,7 @@ import Control.Monad (forever, when) import Control.Monad.Trans.Except (runExceptT) import Data.Aeson (Value, (.=)) import Data.Aeson qualified as Aeson +import Data.ByteString qualified as BS import Data.ByteString.Lazy.Char8 qualified as BSL import Data.IORef qualified as IORef import Data.Map.Strict (Map) @@ -390,19 +391,25 @@ submitLoop opts addr sk fundsVar pendingQueue = do bumpError ("buildTx: " ++ err) threadDelay period Right (signedTx, outFunds) -> do - let txId = Api.getTxId (Api.getTxBody signedTx) + let txId = Api.serialiseToRawBytesHexText + (Api.getTxId (Api.getTxBody signedTx)) + txBytes = Api.serialiseToCBOR signedTx + txSize = BS.length txBytes txInMode = TxInMode (Api.shelleyBasedEra @Api.DijkstraEra) signedTx result <- submitViaQueue pendingQueue txInMode case result of SubmitSuccess -> do - trace "TxFirehose.Submit.Success" "Info" $ - Aeson.object ["tx" .= T.pack (show txId)] + trace "TxFirehose.Submit.Success" "Info" $ Aeson.object + [ "txId" .= txId + , "size" .= txSize + ] STM.atomically $ STM.modifyTVar' fundsVar $ \m -> foldr (\f -> Map.insert (fundTxIn f) (fundValue f)) m outFunds resetError SubmitFail reason -> do trace "TxFirehose.Submit.Reject" "Warning" $ Aeson.object - [ "tx" .= T.pack (show txId) + [ "txId" .= txId + , "size" .= txSize , "reason" .= T.pack (show reason) ] returnFunds fundsVar inputs From 49e3d750ba5245b0b86f1b900af69c0307ce4e81 Mon Sep 17 00:00:00 2001 From: Sebastian Nagel Date: Mon, 6 Jul 2026 17:34:48 +0200 Subject: [PATCH 10/12] tx-firehose: compute txId / size via cardano-ledger-api MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Api.getTxBody is deprecated in favour of Cardano.Api.Experimental's UnsignedTx, and with -Werror on the deprecation warning the Nix build now fails. Rather than round-trip through a new experimental function, compute both the txId and the wire size directly on the ledger tx we already have in hand. Pattern taken from Test.ThreadNet.Leios in ouroboros-consensus: txIdTx :: EraTx era => Tx l era -> TxId -- Cardano.Ledger.Core sizeTxF :: SimpleGetter (Tx l era) Word32 -- Cardano.Ledger.Core buildTx now returns a BuiltTx record with the signed api-Tx, ledger txId, wire size, and output funds. Main.hs uses the fields directly, so it no longer needs Api.getTxBody, Api.getTxId, Api.serialiseToCBOR, or the manual serialiseToRawBytesHexText step — TxId has a hex-string ToJSON instance from cardano-ledger. --- bench/tx-firehose/app/Main.hs | 26 +++++++------- .../src/Cardano/Benchmarking/TxFirehose/Tx.hs | 34 ++++++++++++++++--- bench/tx-firehose/tx-firehose.cabal | 2 ++ 3 files changed, 43 insertions(+), 19 deletions(-) diff --git a/bench/tx-firehose/app/Main.hs b/bench/tx-firehose/app/Main.hs index 441adaddc75..9b240beca65 100644 --- a/bench/tx-firehose/app/Main.hs +++ b/bench/tx-firehose/app/Main.hs @@ -1,10 +1,10 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} -{-# OPTIONS_GHC -Wno-deprecations #-} module Main (main) where @@ -17,7 +17,6 @@ import Control.Monad (forever, when) import Control.Monad.Trans.Except (runExceptT) import Data.Aeson (Value, (.=)) import Data.Aeson qualified as Aeson -import Data.ByteString qualified as BS import Data.ByteString.Lazy.Char8 qualified as BSL import Data.IORef qualified as IORef import Data.Map.Strict (Map) @@ -79,7 +78,10 @@ import Ouroboros.Network.Protocol.LocalTxSubmission.Client , LocalTxSubmissionClient (LocalTxSubmissionClient) ) -import Cardano.Benchmarking.TxFirehose.Tx (Fund (Fund, fundTxIn, fundValue)) +import Cardano.Benchmarking.TxFirehose.Tx + ( BuiltTx (BuiltTx, btxId, btxOutputs, btxSigned, btxSize) + , Fund (Fund, fundTxIn, fundValue) + ) import Cardano.Benchmarking.TxFirehose.Tx qualified as Tx -------------------------------------------------------------------------------- @@ -390,26 +392,22 @@ submitLoop opts addr sk fundsVar pendingQueue = do returnFunds fundsVar inputs bumpError ("buildTx: " ++ err) threadDelay period - Right (signedTx, outFunds) -> do - let txId = Api.serialiseToRawBytesHexText - (Api.getTxId (Api.getTxBody signedTx)) - txBytes = Api.serialiseToCBOR signedTx - txSize = BS.length txBytes - txInMode = TxInMode (Api.shelleyBasedEra @Api.DijkstraEra) signedTx + Right BuiltTx { btxSigned, btxId, btxSize, btxOutputs } -> do + let txInMode = TxInMode (Api.shelleyBasedEra @Api.DijkstraEra) btxSigned result <- submitViaQueue pendingQueue txInMode case result of SubmitSuccess -> do trace "TxFirehose.Submit.Success" "Info" $ Aeson.object - [ "txId" .= txId - , "size" .= txSize + [ "txId" .= btxId + , "size" .= btxSize ] STM.atomically $ STM.modifyTVar' fundsVar $ \m -> - foldr (\f -> Map.insert (fundTxIn f) (fundValue f)) m outFunds + foldr (\f -> Map.insert (fundTxIn f) (fundValue f)) m btxOutputs resetError SubmitFail reason -> do trace "TxFirehose.Submit.Reject" "Warning" $ Aeson.object - [ "txId" .= txId - , "size" .= txSize + [ "txId" .= btxId + , "size" .= btxSize , "reason" .= T.pack (show reason) ] returnFunds fundsVar inputs diff --git a/bench/tx-firehose/src/Cardano/Benchmarking/TxFirehose/Tx.hs b/bench/tx-firehose/src/Cardano/Benchmarking/TxFirehose/Tx.hs index 997d7c6a2b0..1d15bab4920 100644 --- a/bench/tx-firehose/src/Cardano/Benchmarking/TxFirehose/Tx.hs +++ b/bench/tx-firehose/src/Cardano/Benchmarking/TxFirehose/Tx.hs @@ -1,6 +1,5 @@ {-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE TypeApplications #-} -{-# OPTIONS_GHC -Wno-deprecations #-} -- | Dijkstra-era transaction builder. -- @@ -14,12 +13,19 @@ -- We wrap the resulting 'Exp.SignedTx' back into an old-style 'Api.Tx' via the -- 'Api.ShelleyTx' constructor so the caller can hand it to 'TxInMode' / the -- LocalTxSubmission client without further changes. +-- +-- TxId and wire size come straight from cardano-ledger-api on the raw ledger +-- Tx we already have in hand — no need to round-trip through the deprecated +-- 'Api.getTxBody'. module Cardano.Benchmarking.TxFirehose.Tx ( Fund (..) + , BuiltTx (..) , buildTx ) where import Data.Function ((&)) +import Lens.Micro ((^.)) +import Data.Word (Word32) import Numeric.Natural (Natural) import Cardano.Api qualified as Api @@ -27,6 +33,8 @@ import Cardano.Api qualified as Api import Cardano.Api.Experimental qualified as Exp import Cardano.Api.Experimental.Tx qualified as Exp +import Cardano.Ledger.Api (sizeTxF, txIdTx) +import Cardano.Ledger.Api.Tx.In (TxId) import Cardano.Ledger.Coin qualified as L -- | A spendable UTxO under our signing key. @@ -36,6 +44,16 @@ data Fund = Fund } deriving (Eq, Ord, Show) +-- | A built and signed transaction, together with the ledger-native +-- txId and wire size (bytes). Callers wanting to submit it hand +-- 'btxSigned' to 'TxInMode'; observability uses 'btxId' / 'btxSize'. +data BuiltTx = BuiltTx + { btxSigned :: !(Api.Tx Api.DijkstraEra) + , btxId :: !TxId + , btxSize :: !Word32 + , btxOutputs :: ![Fund] + } + -- | Build and sign a Dijkstra-era transaction. buildTx :: Api.AddressInEra Api.DijkstraEra @@ -43,7 +61,7 @@ buildTx -> [Fund] -> Natural -> L.Coin - -> Either String (Api.Tx Api.DijkstraEra, [Fund]) + -> Either String BuiltTx buildTx destAddr signingKey inFunds numOutputs fee | null inFunds = Left "buildTx: no input funds" | numOutputs == 0 = Left "buildTx: outputs_per_tx must be >= 1" @@ -62,14 +80,20 @@ buildTx destAddr signingKey inFunds numOutputs fee (Api.WitnessPaymentKey signingKey) Exp.SignedTx ledgerTx = Exp.signTx Exp.DijkstraEra [] [keyWit] unsigned signedTx = Api.ShelleyTx sbe ledgerTx - txId = Api.getTxId (Api.getTxBody signedTx) + ledgerTxId = txIdTx ledgerTx + apiTxId = Api.fromShelleyTxId ledgerTxId outFunds = - [ Fund { fundTxIn = Api.TxIn txId (Api.TxIx ix) + [ Fund { fundTxIn = Api.TxIn apiTxId (Api.TxIx ix) , fundValue = amt } | (ix, amt) <- zip [0..] outAmounts ] - in Right (signedTx, outFunds) + in Right BuiltTx + { btxSigned = signedTx + , btxId = ledgerTxId + , btxSize = ledgerTx ^. sizeTxF + , btxOutputs = outFunds + } where sbe = Api.shelleyBasedEra @Api.DijkstraEra diff --git a/bench/tx-firehose/tx-firehose.cabal b/bench/tx-firehose/tx-firehose.cabal index 310ba20afb1..05f0d158943 100644 --- a/bench/tx-firehose/tx-firehose.cabal +++ b/bench/tx-firehose/tx-firehose.cabal @@ -34,7 +34,9 @@ library exposed-modules: Cardano.Benchmarking.TxFirehose.Tx build-depends: base >= 4.14 && < 5 , cardano-api + , cardano-ledger-api , cardano-ledger-core + , microlens executable tx-firehose import: project-config From 53fb63729fe12f953253dcfdbdbf441c1597b674 Mon Sep 17 00:00:00 2001 From: Sebastian Nagel Date: Mon, 6 Jul 2026 20:22:35 +0200 Subject: [PATCH 11/12] tx-firehose: restructure top-down, era-generic, single-threaded MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Sweeping refactor covering four things at once: 1. Structure Main.hs top-down. Options + parser, then main, then runFirehoseInEra, then mkFirehoseClient, then trace, then startup helpers, then queries. Reader can follow from the entry point downward without hopping. 2. No separate submission thread, no queue, no TVar. The LocalTxSubmission client itself carries the loop's state - fund set (`Map TxIn Integer`) and consecutive-error counter (`!Int`) - as strict recursive parameters through its continuations. No Async.withAsync, no TQueue, no IORef. 3. Query the node's current era at boot and dispatch the whole pipeline on the resulting existential (via caseByronOrShelleyBasedEra). deriveAddress / queryFundsInEra / mkFirehoseClient all take a `ShelleyBasedEra era` witness rather than hardcoding Dijkstra. Byron gets a clean rejection. 4. Tx builder is era-generic. Tx.buildTx uses the ledger type classes (EraTx / EraTxBody / EraTxOut / EraTxWits, via ShelleyBasedEraConstraints) with mkBasicTxBody + lens edits. Signing goes through Api.makeShelleyKeyWitness' which is era-generic and Dijkstra-safe (unlike createTransactionBody). The internal Fund set is ledger-typed (L.TxIn) now; api ↔ ledger conversion happens only at the query and submit boundaries. Fund set updates: - success: remove consumed inputs, add fresh outputs - reject: keep inputs (never touched) - build fail: keep inputs, bump the error counter --- bench/tx-firehose/app/Main.hs | 468 +++++++++--------- .../src/Cardano/Benchmarking/TxFirehose/Tx.hs | 146 +++--- bench/tx-firehose/tx-firehose.cabal | 5 +- 3 files changed, 326 insertions(+), 293 deletions(-) diff --git a/bench/tx-firehose/app/Main.hs b/bench/tx-firehose/app/Main.hs index 9b240beca65..73733af0e2c 100644 --- a/bench/tx-firehose/app/Main.hs +++ b/bench/tx-firehose/app/Main.hs @@ -1,24 +1,22 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} module Main (main) where import Control.Applicative (optional) import Control.Concurrent (threadDelay) -import Control.Concurrent.Async qualified as Async -import Control.Concurrent.STM (TMVar, TQueue, TVar) -import Control.Concurrent.STM qualified as STM -import Control.Monad (forever, when) +import Control.Monad (when) import Control.Monad.Trans.Except (runExceptT) import Data.Aeson (Value, (.=)) import Data.Aeson qualified as Aeson import Data.ByteString.Lazy.Char8 qualified as BSL -import Data.IORef qualified as IORef import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map import Data.Set qualified as Set @@ -40,11 +38,11 @@ import System.IO import Cardano.Api ( AddressAny , AddressInEra - , AnyCardanoEra (..) - , CardanoEra (DijkstraEra) + , AnyCardanoEra (AnyCardanoEra) , ConsensusModeParams (CardanoModeParams) , File (File) , FromSomeType (FromSomeType) + , LocalChainSyncClient (NoLocalChainSyncClient) , LocalNodeClientProtocols ( LocalNodeClientProtocols , localChainSyncClient @@ -52,7 +50,6 @@ import Cardano.Api , localTxMonitoringClient , localTxSubmissionClient ) - , LocalChainSyncClient (NoLocalChainSyncClient) , LocalNodeConnectInfo (LocalNodeConnectInfo) , NetworkId (Testnet) , NetworkMagic (NetworkMagic) @@ -61,6 +58,7 @@ import Cardano.Api , QueryInMode (QueryCurrentEra, QueryInEra) , QueryInShelleyBasedEra (QueryUTxO) , QueryUTxOFilter (QueryUTxOByAddress) + , ShelleyBasedEra , SigningKey , StakeAddressReference (NoStakeAddress) , SubmitResult (SubmitFail, SubmitSuccess) @@ -71,10 +69,11 @@ import Cardano.Api ) import Cardano.Api qualified as Api -import Cardano.Ledger.Coin qualified as L +import Cardano.Ledger.Api.Tx.In (TxIn) +import Cardano.Ledger.Coin (Coin (Coin)) import Ouroboros.Network.Protocol.LocalTxSubmission.Client - ( LocalTxClientStIdle (SendMsgSubmitTx) + ( LocalTxClientStIdle (SendMsgDone, SendMsgSubmitTx) , LocalTxSubmissionClient (LocalTxSubmissionClient) ) @@ -84,40 +83,10 @@ import Cardano.Benchmarking.TxFirehose.Tx ) import Cardano.Benchmarking.TxFirehose.Tx qualified as Tx +-------------------------------------------------------------------------------- +-- CLI -------------------------------------------------------------------------------- --- | Byron epoch length passed in ConsensusModeParams -- only used to decode --- Byron EBBs, which we never do. Matches every historical Cardano network --- and is what cardano-cli hardcodes. -byronEpochSlots :: Api.EpochSlots -byronEpochSlots = Api.EpochSlots 21600 - --- | An outstanding submission: the tx to submit, and a reply slot the --- persistent client fills once the node responds. -data Pending = Pending - !TxInMode - !(TMVar (SubmitResult TxValidationErrorInCardanoMode)) - --- | Emit one line of structured JSON on stderr, in the shape the --- proto-devnet Alloy log pipeline expects --- (@{at, sev, host, thread, ns, data}@ — the cardano-node trace --- schema). Rate / event counts in Grafana can then be derived by --- filtering on the @ns@ label. -trace :: Text -> Text -> Value -> IO () -trace ns sev dat = do - now <- getCurrentTime - let payload = Aeson.object - [ "at" .= T.pack (iso8601Show now) - , "sev" .= sev - , "host" .= ("tx-firehose" :: Text) - , "thread" .= ("main" :: Text) - , "ns" .= ns - , "data" .= dat - ] - BSL.hPutStrLn stderr (Aeson.encode payload) - --- | Command-line options. Set the optional 'optStakingKey' to spend from a --- base address (payment + stake); omit for an enterprise address. data Options = Options { optSocketPath :: !FilePath , optNetworkMagic :: !Natural @@ -130,6 +99,12 @@ data Options = Options , optMaxConsecutiveErrors :: !Int } +parseOptions :: IO Options +parseOptions = Opt.execParser $ Opt.info (optionsParser Opt.<**> Opt.helper) + ( Opt.fullDesc + <> Opt.progDesc "Push-based single-node tx load generator over node-to-client." + <> Opt.header "tx-firehose - hose transactions at one Cardano node" ) + optionsParser :: Opt.Parser Options optionsParser = Options <$> Opt.strOption @@ -148,77 +123,241 @@ optionsParser = Options ( Opt.long "tps" <> Opt.metavar "NATURAL" <> Opt.help "Target submissions per second (rate ceiling)" ) <*> Opt.option Opt.auto - ( Opt.long "inputs-per-tx" <> Opt.metavar "NATURAL" <> Opt.value 1 <> Opt.showDefault + ( Opt.long "inputs-per-tx" <> Opt.metavar "NATURAL" + <> Opt.value 1 <> Opt.showDefault <> Opt.help "Number of inputs per generated tx" ) <*> Opt.option Opt.auto - ( Opt.long "outputs-per-tx" <> Opt.metavar "NATURAL" <> Opt.value 1 <> Opt.showDefault + ( Opt.long "outputs-per-tx" <> Opt.metavar "NATURAL" + <> Opt.value 1 <> Opt.showDefault <> Opt.help "Number of outputs per generated tx" ) <*> Opt.option Opt.auto - ( Opt.long "fee" <> Opt.metavar "LOVELACE" <> Opt.value 200_000 <> Opt.showDefault + ( Opt.long "fee" <> Opt.metavar "LOVELACE" + <> Opt.value 200_000 <> Opt.showDefault <> Opt.help "Fixed fee per tx (lovelace)" ) <*> Opt.option Opt.auto - ( Opt.long "max-consecutive-errors" <> Opt.metavar "NATURAL" <> Opt.value 50 <> Opt.showDefault + ( Opt.long "max-consecutive-errors" <> Opt.metavar "NATURAL" + <> Opt.value 50 <> Opt.showDefault <> Opt.help "Exit after this many consecutive rejects (for supervisor restart)" ) -parseOptions :: IO Options -parseOptions = Opt.execParser $ Opt.info (optionsParser Opt.<**> Opt.helper) - ( Opt.fullDesc - <> Opt.progDesc "Push-based single-node tx load generator over node-to-client." - <> Opt.header "tx-firehose - hose transactions at one Cardano node" ) +-------------------------------------------------------------------------------- +-- Entry point +-------------------------------------------------------------------------------- main :: IO () main = do -- Force stderr to UTF-8 + line buffering so log messages don't get - -- garbled or merged when the process runs under `LANG=C` (the default - -- inside process-compose / nix sandbox), and each hPutStrLn appears - -- on its own line. + -- garbled or merged when the process runs under `LANG=C`. hSetEncoding stderr utf8 hSetBuffering stderr LineBuffering opts <- parseOptions - when (optTps opts <= 0) $ die "--tps must be > 0" - when (optInputsPerTx opts == 0) $ die "--inputs-per-tx must be >= 1" - when (optOutputsPerTx opts == 0) $ die "--outputs-per-tx must be >= 1" - when (optMaxConsecutiveErrors opts <= 0) $ - die "--max-consecutive-errors must be >= 1" + validateOptions opts signingKey <- loadSigningKey (optSigningKey opts) mStakeVk <- traverse loadStakingKey (optStakingKey opts) let networkId = Testnet (NetworkMagic (fromIntegral (optNetworkMagic opts))) - addrInEra = deriveAddress networkId signingKey mStakeVk - addrAny = case addrInEra of - Api.AddressInEra _ addr -> Api.toAddressAny addr connInfo = LocalNodeConnectInfo { Api.localConsensusModeParams = CardanoModeParams byronEpochSlots , Api.localNodeNetworkId = networkId , Api.localNodeSocketPath = File (optSocketPath opts) } - ensureDijkstra connInfo + -- Dispatch on whatever era the node reports; the tx builder is + -- generic over ShelleyBasedEra. + currentEra <- queryCurrentEra connInfo + runInEra currentEra $ \sbe -> + runFirehoseInEra sbe opts connInfo networkId signingKey mStakeVk + +-- | Fail if the node is in Byron; otherwise run the continuation with +-- the era's 'ShelleyBasedEra' witness. +runInEra + :: AnyCardanoEra + -> (forall era. Api.ShelleyBasedEraConstraints era => ShelleyBasedEra era -> IO ()) + -> IO () +runInEra (AnyCardanoEra ce) k = + Api.caseByronOrShelleyBasedEra + (die "tx-firehose: Byron era is not supported") + k + ce + +validateOptions :: Options -> IO () +validateOptions opts = do + when (optTps opts <= 0) $ die "--tps must be > 0" + when (optInputsPerTx opts == 0) $ die "--inputs-per-tx must be >= 1" + when (optOutputsPerTx opts == 0) $ die "--outputs-per-tx must be >= 1" + when (optMaxConsecutiveErrors opts <= 0) $ + die "--max-consecutive-errors must be >= 1" + +byronEpochSlots :: Api.EpochSlots +byronEpochSlots = Api.EpochSlots 21600 + +-------------------------------------------------------------------------------- +-- Per-era firehose +-------------------------------------------------------------------------------- + +-- | Query the initial UTxO for the derived address, then open a single +-- N2C connection whose LocalTxSubmission client drives the whole loop. +-- No separate thread and no shared TVar: the loop's state (funds and +-- consecutive-error counter) lives in the client's recursive +-- continuation. +runFirehoseInEra + :: Api.ShelleyBasedEraConstraints era + => ShelleyBasedEra era + -> Options + -> LocalNodeConnectInfo + -> NetworkId + -> SigningKey Api.PaymentKey + -> Maybe (Api.VerificationKey Api.StakeKey) + -> IO () +runFirehoseInEra sbe opts connInfo networkId signingKey mStakeVk = do + let addrInEra = deriveAddress sbe networkId signingKey mStakeVk + addrAny = case addrInEra of + Api.AddressInEra _ addr -> Api.toAddressAny addr trace "TxFirehose.Startup.Query" "Info" $ - Aeson.object ["address" .= T.pack (show addrAny)] - initialFunds <- queryFunds connInfo addrAny + Aeson.object ["address" .= T.pack (show addrAny), "era" .= show sbe] + + initialFunds <- queryFundsInEra sbe connInfo addrAny when (Map.null initialFunds) $ die "tx-firehose: no UTxO found at derived address - fund it first" + trace "TxFirehose.Startup.Seeded" "Info" $ Aeson.object - [ "utxos" .= Map.size initialFunds + [ "utxos" .= Map.size initialFunds , "totalLovelace" .= sum (Map.elems initialFunds) ] - fundsVar <- STM.newTVarIO initialFunds - pendingQueue <- STM.newTQueueIO + Api.connectToLocalNode connInfo LocalNodeClientProtocols + { localChainSyncClient = NoLocalChainSyncClient + , localStateQueryClient = Nothing + , localTxSubmissionClient = + Just (mkFirehoseClient sbe opts addrInEra signingKey initialFunds) + , localTxMonitoringClient = Nothing + } - -- The submission client owns the wire; if it dies (socket closed, node - -- restarted, protocol error) we want to die with it. Link so the exception - -- propagates while the submit loop runs in the foreground. - Async.withAsync (runSubmissionClient connInfo pendingQueue) $ \clientA -> do - Async.link clientA - submitLoop opts addrInEra signingKey fundsVar pendingQueue +-- | The LocalTxSubmission state machine. Holds the fund set and the +-- consecutive-error counter as strict recursive parameters — no TVars, +-- no IORefs, no async. +mkFirehoseClient + :: forall era + . Api.ShelleyBasedEraConstraints era + => ShelleyBasedEra era + -> Options + -> AddressInEra era + -> SigningKey Api.PaymentKey + -> Map TxIn Integer + -> LocalTxSubmissionClient TxInMode TxValidationErrorInCardanoMode IO () +mkFirehoseClient sbe opts addr sk initialFunds = + LocalTxSubmissionClient (step initialFunds 0) + where + !period = round (1_000_000 / optTps opts) :: Int + !n = fromIntegral (optInputsPerTx opts) :: Int + !maxErrs = optMaxConsecutiveErrors opts + + -- One step of the loop, in IO. Returns the next client state. + step + :: Map TxIn Integer + -> Int + -> IO (LocalTxClientStIdle TxInMode TxValidationErrorInCardanoMode IO ()) + step !funds !consec + | Map.size funds < n = + -- We recycle outputs on every success and never lose funds on + -- reject (inputs stay put), so running dry is catastrophic — + -- exit and let the supervisor restart with a fresh query. + pure (SendMsgDone ()) + | otherwise = + let (chosen, funds') = takeInputs n funds + inFunds = + [ Fund { fundTxIn = tin, fundValue = v } + | (tin, v) <- chosen + ] + in case Tx.buildTx sbe addr sk inFunds + (optOutputsPerTx opts) (Coin (optFee opts)) of + Left err -> do + trace "TxFirehose.Build.Fail" "Error" $ + Aeson.object ["error" .= T.pack err] + -- Inputs stay in the fund set: buildTx never touched + -- them, so this is just a signal for restart. + onError funds consec ("buildTx: " ++ err) + Right built -> + pure (submitStep funds funds' consec built) + + -- SendMsgSubmitTx state: post-submit handling of the reply. + submitStep + :: Map TxIn Integer -- ^ funds to keep on reject (inputs still there) + -> Map TxIn Integer -- ^ funds after removing this tx's inputs + -> Int + -> BuiltTx era + -> LocalTxClientStIdle TxInMode TxValidationErrorInCardanoMode IO () + submitStep fundsOnFail fundsOnSuccess !consec + BuiltTx { btxSigned, btxId, btxSize, btxOutputs } = + SendMsgSubmitTx (TxInMode sbe btxSigned) $ \result -> do + threadDelay period + case result of + SubmitSuccess -> do + trace "TxFirehose.Submit.Success" "Info" $ Aeson.object + [ "txId" .= btxId, "size" .= btxSize ] + let !funds'' = foldr addOutput fundsOnSuccess btxOutputs + step funds'' 0 + SubmitFail reason -> do + trace "TxFirehose.Submit.Reject" "Warning" $ Aeson.object + [ "txId" .= btxId, "size" .= btxSize + , "reason" .= T.pack (show reason) + ] + onError fundsOnFail consec (show reason) + + -- Bump the consecutive-error counter and either exit or loop. + onError + :: Map TxIn Integer + -> Int + -> String + -> IO (LocalTxClientStIdle TxInMode TxValidationErrorInCardanoMode IO ()) + onError funds !consec reason = do + let !consec' = consec + 1 + if consec' >= maxErrs + then do + trace "TxFirehose.Exit.MaxErrors" "Error" $ Aeson.object + [ "threshold" .= maxErrs + , "lastReason" .= T.pack reason + ] + die $ "tx-firehose: " ++ show maxErrs + ++ " consecutive rejects, exiting for restart (last: " + ++ reason ++ ")" + else step funds consec' + +-- | Deterministically pull @n@ entries out of a fund set. +takeInputs :: Int -> Map TxIn Integer -> ([(TxIn, Integer)], Map TxIn Integer) +takeInputs n m = + let taken = take n (Map.toList m) + m' = foldr (Map.delete . fst) m taken + in (taken, m') + +addOutput :: Fund -> Map TxIn Integer -> Map TxIn Integer +addOutput f = Map.insert (fundTxIn f) (fundValue f) -------------------------------------------------------------------------------- --- Signing key & address +-- Structured logging +-------------------------------------------------------------------------------- + +-- | Emit one JSON line in the cardano-node trace schema +-- (@{at, sev, host, thread, ns, data}@). The proto-devnet Alloy +-- pipeline turns @ns@ into a Loki label, so Grafana can filter on +-- @TxFirehose.Submit.Success@ etc. +trace :: Text -> Text -> Value -> IO () +trace ns sev dat = do + now <- getCurrentTime + let payload = Aeson.object + [ "at" .= T.pack (iso8601Show now) + , "sev" .= sev + , "host" .= ("tx-firehose" :: Text) + , "thread" .= ("main" :: Text) + , "ns" .= ns + , "data" .= dat + ] + BSL.hPutStrLn stderr (Aeson.encode payload) + +-------------------------------------------------------------------------------- +-- Startup helpers -------------------------------------------------------------------------------- loadSigningKey :: FilePath -> IO (SigningKey Api.PaymentKey) @@ -235,9 +374,9 @@ loadSigningKey path = do , FromSomeType (Api.AsSigningKey Api.AsPaymentKey) id ] --- | Load a stake signing key (from a .skey text envelope) and derive its --- verification key. Only the vkey hash is needed to build a base address — --- the stake key does not have to sign anything (payment credential does). +-- | Load a stake signing key and derive its verification key. Only the +-- vkey hash is used (to build a base address); the stake key does not +-- sign anything. loadStakingKey :: FilePath -> IO (Api.VerificationKey Api.StakeKey) loadStakingKey path = do result <- Api.readFileTextEnvelope (File path) @@ -247,12 +386,13 @@ loadStakingKey path = do Right (sk :: SigningKey Api.StakeKey) -> pure (Api.getVerificationKey sk) deriveAddress - :: NetworkId + :: ShelleyBasedEra era + -> NetworkId -> SigningKey Api.PaymentKey -> Maybe (Api.VerificationKey Api.StakeKey) - -> AddressInEra Api.DijkstraEra -deriveAddress networkId sk mStakeVk = - Api.shelleyAddressInEra (Api.shelleyBasedEra @Api.DijkstraEra) $ + -> AddressInEra era +deriveAddress sbe networkId sk mStakeVk = + Api.shelleyAddressInEra sbe $ Api.makeShelleyAddress networkId (PaymentCredentialByKey (Api.verificationKeyHash (Api.getVerificationKey sk))) @@ -264,157 +404,39 @@ deriveAddress networkId sk mStakeVk = (Api.StakeCredentialByKey (Api.verificationKeyHash vk)) -------------------------------------------------------------------------------- --- Era sanity check +-- Local-state queries -------------------------------------------------------------------------------- -ensureDijkstra :: LocalNodeConnectInfo -> IO () -ensureDijkstra connInfo = do +queryCurrentEra :: LocalNodeConnectInfo -> IO AnyCardanoEra +queryCurrentEra connInfo = do res <- runExceptT $ Api.queryNodeLocalState connInfo VolatileTip QueryCurrentEra case res of Left af -> die $ "tx-firehose: failed to acquire tip: " ++ show af - Right (AnyCardanoEra DijkstraEra) -> pure () - Right (AnyCardanoEra other) -> - die $ "tx-firehose: node is in era " ++ show other - ++ ", but this tool only builds Dijkstra-era transactions" - --------------------------------------------------------------------------------- --- UTxO query (ephemeral connection) --------------------------------------------------------------------------------- - -queryFunds - :: LocalNodeConnectInfo -> AddressAny -> IO (Map Api.TxIn Integer) -queryFunds connInfo addrAny = do + Right ce -> pure ce + +-- | Query the current UTxO at our derived address in whatever era the +-- node reports. Converts each 'Api.TxIn' to the ledger 'TxIn' so the +-- fund set the client owns is in ledger types from the start. +queryFundsInEra + :: ShelleyBasedEra era + -> LocalNodeConnectInfo + -> AddressAny + -> IO (Map TxIn Integer) +queryFundsInEra sbe connInfo addrAny = do let q = QueryInEra - (QueryInShelleyBasedEra - (Api.shelleyBasedEra @Api.DijkstraEra) + (QueryInShelleyBasedEra sbe (QueryUTxO (QueryUTxOByAddress (Set.singleton addrAny)))) res <- runExceptT $ Api.queryNodeLocalState connInfo VolatileTip q case res of Left af -> die $ "tx-firehose: failed to acquire tip: " ++ show af Right (Left mismatch) -> die $ "tx-firehose: era mismatch on UTxO query: " ++ show mismatch - Right (Right (UTxO m)) -> pure (Map.map toLovelace m) + Right (Right (UTxO m)) -> + pure . Map.fromList $ + [ (Api.toShelleyTxIn tin, toLovelace txOut) + | (tin, txOut) <- Map.toList m + ] where - toLovelace :: Api.TxOut Api.CtxUTxO Api.DijkstraEra -> Integer + toLovelace :: Api.TxOut Api.CtxUTxO era -> Integer toLovelace (Api.TxOut _ v _ _) = - let L.Coin c = Api.txOutValueToLovelace v in c - --------------------------------------------------------------------------------- --- Persistent submission client --------------------------------------------------------------------------------- - --- | Reads pending submissions from the queue and drives them one at a time --- over a single LocalTxSubmission session. The protocol is inherently --- request/response so pipelining a queue in front of it is the right shape: --- multiple producers can enqueue concurrently, this thread serialises them --- onto the wire and posts each reply back to the caller. -mkPersistentClient - :: TQueue Pending - -> LocalTxSubmissionClient TxInMode TxValidationErrorInCardanoMode IO () -mkPersistentClient q = LocalTxSubmissionClient loop - where - loop :: IO (LocalTxClientStIdle TxInMode TxValidationErrorInCardanoMode IO ()) - loop = do - Pending tx reply <- STM.atomically (STM.readTQueue q) - pure $ SendMsgSubmitTx tx $ \result -> do - STM.atomically $ STM.putTMVar reply result - loop - -runSubmissionClient :: LocalNodeConnectInfo -> TQueue Pending -> IO () -runSubmissionClient connInfo q = - Api.connectToLocalNode connInfo LocalNodeClientProtocols - { localChainSyncClient = NoLocalChainSyncClient - , localStateQueryClient = Nothing - , localTxSubmissionClient = Just (mkPersistentClient q) - , localTxMonitoringClient = Nothing - } - --- | Enqueue a tx and block until the node replies. -submitViaQueue - :: TQueue Pending - -> TxInMode - -> IO (SubmitResult TxValidationErrorInCardanoMode) -submitViaQueue q tx = do - reply <- STM.newEmptyTMVarIO - STM.atomically $ STM.writeTQueue q (Pending tx reply) - STM.atomically $ STM.takeTMVar reply - --------------------------------------------------------------------------------- --- Submit loop --------------------------------------------------------------------------------- - --- | Rate-limited loop: take @inputsPerTx@ funds, build a tx, submit via the --- persistent queue, dispatch on the reply. --- --- We deliberately do NOT try to reconcile the local fund set with the ledger --- while running: the local set is populated optimistically from every --- SubmitSuccess and will diverge under normal chain progress. Instead we --- track consecutive rejects and die once they cross the configured --- threshold. The supervisor restarts us and we requery from a clean slate. -submitLoop - :: Options - -> AddressInEra Api.DijkstraEra - -> SigningKey Api.PaymentKey - -> TVar (Map Api.TxIn Integer) - -> TQueue Pending - -> IO () -submitLoop opts addr sk fundsVar pendingQueue = do - let period = round (1_000_000 / optTps opts) :: Int - n = fromIntegral (optInputsPerTx opts) :: Int - maxErrs = optMaxConsecutiveErrors opts - consecutive <- IORef.newIORef (0 :: Int) - let bumpError reason = do - c <- IORef.atomicModifyIORef' consecutive (\c -> (c + 1, c + 1)) - when (c >= maxErrs) $ do - trace "TxFirehose.Exit.MaxErrors" "Error" $ Aeson.object - [ "threshold" .= maxErrs - , "lastReason" .= T.pack reason - ] - die $ "tx-firehose: " ++ show maxErrs - ++ " consecutive rejects, exiting for restart (last: " - ++ reason ++ ")" - resetError = IORef.writeIORef consecutive 0 - forever $ do - inputs <- STM.atomically $ do - m <- STM.readTVar fundsVar - when (Map.size m < n) STM.retry - let taken = take n (Map.toList m) - m' = foldr (Map.delete . fst) m taken - STM.writeTVar fundsVar m' - pure taken - let inFunds = - [ Fund { fundTxIn = tin, fundValue = v } | (tin, v) <- inputs ] - case Tx.buildTx addr sk inFunds (optOutputsPerTx opts) - (L.Coin (optFee opts)) of - Left err -> do - trace "TxFirehose.Build.Fail" "Error" $ - Aeson.object ["error" .= T.pack err] - returnFunds fundsVar inputs - bumpError ("buildTx: " ++ err) - threadDelay period - Right BuiltTx { btxSigned, btxId, btxSize, btxOutputs } -> do - let txInMode = TxInMode (Api.shelleyBasedEra @Api.DijkstraEra) btxSigned - result <- submitViaQueue pendingQueue txInMode - case result of - SubmitSuccess -> do - trace "TxFirehose.Submit.Success" "Info" $ Aeson.object - [ "txId" .= btxId - , "size" .= btxSize - ] - STM.atomically $ STM.modifyTVar' fundsVar $ \m -> - foldr (\f -> Map.insert (fundTxIn f) (fundValue f)) m btxOutputs - resetError - SubmitFail reason -> do - trace "TxFirehose.Submit.Reject" "Warning" $ Aeson.object - [ "txId" .= btxId - , "size" .= btxSize - , "reason" .= T.pack (show reason) - ] - returnFunds fundsVar inputs - bumpError (show reason) - threadDelay period - -returnFunds :: TVar (Map Api.TxIn Integer) -> [(Api.TxIn, Integer)] -> IO () -returnFunds fundsVar inputs = STM.atomically $ - STM.modifyTVar' fundsVar $ \m -> - foldr (uncurry Map.insert) m inputs + let Coin c = Api.txOutValueToLovelace v in c diff --git a/bench/tx-firehose/src/Cardano/Benchmarking/TxFirehose/Tx.hs b/bench/tx-firehose/src/Cardano/Benchmarking/TxFirehose/Tx.hs index 1d15bab4920..177782e0e12 100644 --- a/bench/tx-firehose/src/Cardano/Benchmarking/TxFirehose/Tx.hs +++ b/bench/tx-firehose/src/Cardano/Benchmarking/TxFirehose/Tx.hs @@ -1,22 +1,16 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE ImportQualifiedPost #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} --- | Dijkstra-era transaction builder. +-- | Era-generic transaction builder for tx-firehose. -- --- Uses the experimental 'Cardano.Api.Experimental' API because the stable --- 'Api.createTransactionBody' path is not yet Dijkstra-complete --- (@caseShelleyToBabbageOrConwayEraOnwards@ errors out on the Dijkstra --- witness-extraction branch inside 'collectTxBodyScriptWitnessRequirements'). --- --- 'Exp.makeUnsignedTx' bypasses that path entirely: it constructs the ledger --- transaction directly from the experimental 'TxBodyContent (LedgerEra era)'. --- We wrap the resulting 'Exp.SignedTx' back into an old-style 'Api.Tx' via the --- 'Api.ShelleyTx' constructor so the caller can hand it to 'TxInMode' / the --- LocalTxSubmission client without further changes. --- --- TxId and wire size come straight from cardano-ledger-api on the raw ledger --- Tx we already have in hand — no need to round-trip through the deprecated --- 'Api.getTxBody'. +-- The transaction is assembled with the ledger 'EraTx' \/ 'EraTxBody' \/ +-- 'EraTxOut' type classes so the same code covers every Shelley-based era +-- (Shelley .. Dijkstra). Signing goes through cardano-api's +-- 'makeShelleyKeyWitness'' - that path is era-generic and, unlike +-- 'createTransactionBody', does not trip over the Dijkstra witness +-- extraction case-analysis. module Cardano.Benchmarking.TxFirehose.Tx ( Fund (..) , BuiltTx (..) @@ -24,45 +18,59 @@ module Cardano.Benchmarking.TxFirehose.Tx ) where import Data.Function ((&)) -import Lens.Micro ((^.)) +import Data.Sequence.Strict qualified as StrictSeq +import Data.Set qualified as Set import Data.Word (Word32) +import Lens.Micro ((%~), (.~), (^.)) import Numeric.Natural (Natural) import Cardano.Api qualified as Api -import Cardano.Api.Experimental qualified as Exp -import Cardano.Api.Experimental.Tx qualified as Exp - -import Cardano.Ledger.Api (sizeTxF, txIdTx) -import Cardano.Ledger.Api.Tx.In (TxId) -import Cardano.Ledger.Coin qualified as L +import Cardano.Ledger.Api + ( addrTxWitsL + , feeTxBodyL + , inputsTxBodyL + , mkBasicTx + , mkBasicTxBody + , outputsTxBodyL + , sizeTxF + , txIdTx + , witsTxL + ) +import Cardano.Ledger.Api.Tx.In (TxId, TxIn, mkTxInPartial) +import Cardano.Ledger.Coin (Coin (Coin)) --- | A spendable UTxO under our signing key. +-- | A spendable UTxO we own: ledger-level 'TxIn' + its lovelace value. +-- Keeping the internal fund set ledger-typed lets the tx builder stay +-- pure ledger; api conversion only happens at query \/ submit boundaries. data Fund = Fund - { fundTxIn :: !Api.TxIn + { fundTxIn :: !TxIn , fundValue :: !Integer } deriving (Eq, Ord, Show) --- | A built and signed transaction, together with the ledger-native --- txId and wire size (bytes). Callers wanting to submit it hand --- 'btxSigned' to 'TxInMode'; observability uses 'btxId' / 'btxSize'. -data BuiltTx = BuiltTx - { btxSigned :: !(Api.Tx Api.DijkstraEra) +-- | A built and signed transaction, together with observability +-- metadata we want to trace on submit. +data BuiltTx era = BuiltTx + { btxSigned :: !(Api.Tx era) , btxId :: !TxId , btxSize :: !Word32 , btxOutputs :: ![Fund] } --- | Build and sign a Dijkstra-era transaction. +-- | Build and sign an era-generic 1..n-input, m-output transaction that +-- sends the change back to @destAddr@ under @signingKey@. buildTx - :: Api.AddressInEra Api.DijkstraEra + :: forall era + . Api.ShelleyBasedEraConstraints era + => Api.ShelleyBasedEra era + -> Api.AddressInEra era -> Api.SigningKey Api.PaymentKey -> [Fund] -> Natural - -> L.Coin - -> Either String BuiltTx -buildTx destAddr signingKey inFunds numOutputs fee + -> Coin + -> Either String (BuiltTx era) +buildTx sbe destAddr signingKey inFunds numOutputs fee | null inFunds = Left "buildTx: no input funds" | numOutputs == 0 = Left "buildTx: outputs_per_tx must be >= 1" | feeLovelace < 0 = Left "buildTx: fee must be >= 0" @@ -73,32 +81,42 @@ buildTx destAddr signingKey inFunds numOutputs fee "buildTx: output value too low - " ++ show numOutputs ++ " outputs from " ++ show changeTotal ++ " lovelace yields " ++ show minOutputLovelace ++ " per output" - | otherwise = case Exp.makeUnsignedTx Exp.DijkstraEra bodyContent of - Left err -> Left $ "buildTx: " ++ show err - Right unsigned -> - let keyWit = Exp.makeKeyWitness Exp.DijkstraEra unsigned - (Api.WitnessPaymentKey signingKey) - Exp.SignedTx ledgerTx = Exp.signTx Exp.DijkstraEra [] [keyWit] unsigned - signedTx = Api.ShelleyTx sbe ledgerTx - ledgerTxId = txIdTx ledgerTx - apiTxId = Api.fromShelleyTxId ledgerTxId - outFunds = - [ Fund { fundTxIn = Api.TxIn apiTxId (Api.TxIx ix) - , fundValue = amt - } - | (ix, amt) <- zip [0..] outAmounts - ] - in Right BuiltTx - { btxSigned = signedTx - , btxId = ledgerTxId - , btxSize = ledgerTx ^. sizeTxF - , btxOutputs = outFunds - } + | otherwise = Right built where - sbe = Api.shelleyBasedEra @Api.DijkstraEra + -- Body: pure ledger, era-generic via EraTxBody. + body = + mkBasicTxBody + & inputsTxBodyL .~ Set.fromList (map fundTxIn inFunds) + & outputsTxBodyL %~ (<> StrictSeq.fromList (map mkOut outAmounts)) + & feeTxBodyL .~ fee + + -- Signing via cardano-api - era-generic and Dijkstra-safe. + witVKey = case Api.makeShelleyKeyWitness' sbe body + (Api.WitnessPaymentKey signingKey) of + Api.ShelleyKeyWitness _ w -> w + _ -> error "buildTx: unexpected non-Shelley witness" + + ledgerTx = + mkBasicTx body + & witsTxL . addrTxWitsL .~ Set.singleton witVKey + ledgerTxId = txIdTx ledgerTx + + outFunds = + [ Fund { fundTxIn = mkTxInPartial ledgerTxId ix, fundValue = amt } + | (ix, amt) <- zip [0..] outAmounts + ] + + built = BuiltTx + { btxSigned = Api.ShelleyTx sbe ledgerTx + , btxId = ledgerTxId + , btxSize = ledgerTx ^. sizeTxF + , btxOutputs = outFunds + } + + -- Money math. totalIn = sum (map fundValue inFunds) - feeLovelace = let L.Coin c = fee in c + feeLovelace = let Coin c = fee in c changeTotal = totalIn - feeLovelace n = fromIntegral numOutputs :: Integer minOutputLovelace = changeTotal `div` n @@ -107,18 +125,10 @@ buildTx destAddr signingKey inFunds numOutputs fee remainder = changeTotal `mod` n in (base + remainder) : replicate (fromIntegral numOutputs - 1) base - mkOut :: Integer -> Exp.TxOut (Exp.LedgerEra Api.DijkstraEra) mkOut lovelace = let apiOut = Api.TxOut destAddr - (Api.lovelaceToTxOutValue sbe (Api.Coin lovelace)) + (Api.lovelaceToTxOutValue sbe (Coin lovelace)) Api.TxOutDatumNone Api.ReferenceScriptNone - in Exp.TxOut (Api.toShelleyTxOutAny sbe apiOut) - - bodyContent = - Exp.defaultTxBodyContent - & Exp.setTxIns - [ (fundTxIn f, Exp.AnyKeyWitnessPlaceholder) | f <- inFunds ] - & Exp.setTxOuts (map mkOut outAmounts) - & Exp.setTxFee fee + in Api.toShelleyTxOutAny sbe apiOut diff --git a/bench/tx-firehose/tx-firehose.cabal b/bench/tx-firehose/tx-firehose.cabal index 05f0d158943..cce56a85228 100644 --- a/bench/tx-firehose/tx-firehose.cabal +++ b/bench/tx-firehose/tx-firehose.cabal @@ -36,6 +36,8 @@ library , cardano-api , cardano-ledger-api , cardano-ledger-core + , cardano-strict-containers + , containers , microlens executable tx-firehose @@ -47,14 +49,13 @@ executable tx-firehose "-with-rtsopts=-N -T" build-depends: base >= 4.14 && < 5 , aeson - , async , bytestring , cardano-api + , cardano-ledger-api , cardano-ledger-core , containers , optparse-applicative , ouroboros-network:protocols - , stm , text , time , transformers From a3a25baaa2b110a5686607bf91ff564e5fc99520 Mon Sep 17 00:00:00 2001 From: Sebastian Nagel Date: Mon, 6 Jul 2026 20:39:31 +0200 Subject: [PATCH 12/12] tx-firehose: prefer where over let for local bindings Sweep the tx-firehose sources to use where clauses instead of let ... in wherever it's in scope. Only the let bindings that close over IO-bound values or lambda-captured variables (where a where clause can't reach) are kept as let. Also: switch feeLovelace's local pattern-let to a where-level pattern binding on the Coin newtype for the same reason. --- bench/tx-firehose/app/Main.hs | 554 ++++++++++-------- bench/tx-firehose/fourmolu.yaml | 7 + .../src/Cardano/Benchmarking/TxFirehose/Tx.hs | 157 ++--- 3 files changed, 389 insertions(+), 329 deletions(-) create mode 100644 bench/tx-firehose/fourmolu.yaml diff --git a/bench/tx-firehose/app/Main.hs b/bench/tx-firehose/app/Main.hs index 73733af0e2c..0a5a6e3519f 100644 --- a/bench/tx-firehose/app/Main.hs +++ b/bench/tx-firehose/app/Main.hs @@ -10,31 +10,6 @@ module Main (main) where -import Control.Applicative (optional) -import Control.Concurrent (threadDelay) -import Control.Monad (when) -import Control.Monad.Trans.Except (runExceptT) -import Data.Aeson (Value, (.=)) -import Data.Aeson qualified as Aeson -import Data.ByteString.Lazy.Char8 qualified as BSL -import Data.Map.Strict (Map) -import Data.Map.Strict qualified as Map -import Data.Set qualified as Set -import Data.Text (Text) -import Data.Text qualified as T -import Data.Time.Clock (getCurrentTime) -import Data.Time.Format.ISO8601 (iso8601Show) -import Numeric.Natural (Natural) -import Options.Applicative qualified as Opt -import System.Exit (die) -import System.IO - ( BufferMode (LineBuffering) - , hSetBuffering - , hSetEncoding - , stderr - , utf8 - ) - import Cardano.Api ( AddressAny , AddressInEra @@ -44,12 +19,12 @@ import Cardano.Api , FromSomeType (FromSomeType) , LocalChainSyncClient (NoLocalChainSyncClient) , LocalNodeClientProtocols - ( LocalNodeClientProtocols - , localChainSyncClient - , localStateQueryClient - , localTxMonitoringClient - , localTxSubmissionClient - ) + ( LocalNodeClientProtocols + , localChainSyncClient + , localStateQueryClient + , localTxMonitoringClient + , localTxSubmissionClient + ) , LocalNodeConnectInfo (LocalNodeConnectInfo) , NetworkId (Testnet) , NetworkMagic (NetworkMagic) @@ -68,80 +43,126 @@ import Cardano.Api , UTxO (UTxO) ) import Cardano.Api qualified as Api - +import Cardano.Benchmarking.TxFirehose.Tx + ( BuiltTx (BuiltTx, btxId, btxOutputs, btxSigned, btxSize) + , Fund (Fund, fundTxIn, fundValue) + ) +import Cardano.Benchmarking.TxFirehose.Tx qualified as Tx import Cardano.Ledger.Api.Tx.In (TxIn) import Cardano.Ledger.Coin (Coin (Coin)) - +import Control.Applicative (optional) +import Control.Concurrent (threadDelay) +import Control.Monad (when) +import Control.Monad.Trans.Except (runExceptT) +import Data.Aeson (Value, (.=)) +import Data.Aeson qualified as Aeson +import Data.ByteString.Lazy.Char8 qualified as BSL +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Data.Text (Text) +import Data.Text qualified as T +import Data.Time.Clock (getCurrentTime) +import Data.Time.Format.ISO8601 (iso8601Show) +import Numeric.Natural (Natural) +import Options.Applicative qualified as Opt import Ouroboros.Network.Protocol.LocalTxSubmission.Client ( LocalTxClientStIdle (SendMsgDone, SendMsgSubmitTx) , LocalTxSubmissionClient (LocalTxSubmissionClient) ) - -import Cardano.Benchmarking.TxFirehose.Tx - ( BuiltTx (BuiltTx, btxId, btxOutputs, btxSigned, btxSize) - , Fund (Fund, fundTxIn, fundValue) - ) -import Cardano.Benchmarking.TxFirehose.Tx qualified as Tx +import System.Exit (die) +import System.IO (BufferMode (LineBuffering), hSetBuffering, hSetEncoding, stderr, utf8) -------------------------------------------------------------------------------- -- CLI -------------------------------------------------------------------------------- data Options = Options - { optSocketPath :: !FilePath - , optNetworkMagic :: !Natural - , optSigningKey :: !FilePath - , optStakingKey :: !(Maybe FilePath) - , optTps :: !Double - , optInputsPerTx :: !Natural - , optOutputsPerTx :: !Natural - , optFee :: !Integer + { optSocketPath :: !FilePath + , optNetworkMagic :: !Natural + , optSigningKey :: !FilePath + , optStakingKey :: !(Maybe FilePath) + , optTps :: !Double + , optInputsPerTx :: !Natural + , optOutputsPerTx :: !Natural + , optFee :: !Integer , optMaxConsecutiveErrors :: !Int } parseOptions :: IO Options -parseOptions = Opt.execParser $ Opt.info (optionsParser Opt.<**> Opt.helper) - ( Opt.fullDesc - <> Opt.progDesc "Push-based single-node tx load generator over node-to-client." - <> Opt.header "tx-firehose - hose transactions at one Cardano node" ) +parseOptions = + Opt.execParser $ + Opt.info + (optionsParser Opt.<**> Opt.helper) + ( Opt.fullDesc + <> Opt.progDesc "Push-based single-node tx load generator over node-to-client." + <> Opt.header "tx-firehose - hose transactions at one Cardano node" + ) optionsParser :: Opt.Parser Options -optionsParser = Options - <$> Opt.strOption - ( Opt.long "socket-path" <> Opt.metavar "SOCKET_PATH" - <> Opt.help "Path to the node socket (node-to-client)" ) - <*> Opt.option Opt.auto - ( Opt.long "testnet-magic" <> Opt.metavar "NATURAL" - <> Opt.help "Specify a testnet magic id (e.g. 164 for leios proto-devnet)" ) - <*> Opt.strOption - ( Opt.long "signing-key-file" <> Opt.metavar "FILEPATH" - <> Opt.help "Payment signing key (.skey; GenesisUTxOKey also accepted)" ) - <*> optional (Opt.strOption - ( Opt.long "staking-key-file" <> Opt.metavar "FILEPATH" - <> Opt.help "Stake signing key (.skey). If set, derive a base address; else enterprise." )) - <*> Opt.option Opt.auto - ( Opt.long "tps" <> Opt.metavar "NATURAL" - <> Opt.help "Target submissions per second (rate ceiling)" ) - <*> Opt.option Opt.auto - ( Opt.long "inputs-per-tx" <> Opt.metavar "NATURAL" - <> Opt.value 1 <> Opt.showDefault - <> Opt.help "Number of inputs per generated tx" ) - <*> Opt.option Opt.auto - ( Opt.long "outputs-per-tx" <> Opt.metavar "NATURAL" - <> Opt.value 1 <> Opt.showDefault - <> Opt.help "Number of outputs per generated tx" ) - <*> Opt.option Opt.auto - ( Opt.long "fee" <> Opt.metavar "LOVELACE" - <> Opt.value 200_000 <> Opt.showDefault - <> Opt.help "Fixed fee per tx (lovelace)" ) - <*> Opt.option Opt.auto - ( Opt.long "max-consecutive-errors" <> Opt.metavar "NATURAL" - <> Opt.value 50 <> Opt.showDefault - <> Opt.help "Exit after this many consecutive rejects (for supervisor restart)" ) - --------------------------------------------------------------------------------- --- Entry point --------------------------------------------------------------------------------- +optionsParser = + Options + <$> Opt.strOption + ( Opt.long "socket-path" + <> Opt.metavar "SOCKET_PATH" + <> Opt.help "Path to the node socket (node-to-client)" + ) + <*> Opt.option + Opt.auto + ( Opt.long "testnet-magic" + <> Opt.metavar "NATURAL" + <> Opt.help "Specify a testnet magic id (e.g. 164 for leios proto-devnet)" + ) + <*> Opt.strOption + ( Opt.long "signing-key-file" + <> Opt.metavar "FILEPATH" + <> Opt.help "Payment signing key (.skey; GenesisUTxOKey also accepted)" + ) + <*> optional + ( Opt.strOption + ( Opt.long "staking-key-file" + <> Opt.metavar "FILEPATH" + <> Opt.help "Stake signing key (.skey). If set, derive a base address; else enterprise." + ) + ) + <*> Opt.option + Opt.auto + ( Opt.long "tps" + <> Opt.metavar "NATURAL" + <> Opt.help "Target submissions per second (rate ceiling)" + ) + <*> Opt.option + Opt.auto + ( Opt.long "inputs-per-tx" + <> Opt.metavar "NATURAL" + <> Opt.value 1 + <> Opt.showDefault + <> Opt.help "Number of inputs per generated tx" + ) + <*> Opt.option + Opt.auto + ( Opt.long "outputs-per-tx" + <> Opt.metavar "NATURAL" + <> Opt.value 1 + <> Opt.showDefault + <> Opt.help "Number of outputs per generated tx" + ) + <*> Opt.option + Opt.auto + ( Opt.long "fee" + <> Opt.metavar "LOVELACE" + <> Opt.value 200_000 + <> Opt.showDefault + <> Opt.help "Fixed fee per tx (lovelace)" + ) + <*> Opt.option + Opt.auto + ( Opt.long "max-consecutive-errors" + <> Opt.metavar "NATURAL" + <> Opt.value 50 + <> Opt.showDefault + <> Opt.help "Exit after this many consecutive rejects (for supervisor restart)" + ) main :: IO () main = do @@ -157,11 +178,12 @@ main = do mStakeVk <- traverse loadStakingKey (optStakingKey opts) let networkId = Testnet (NetworkMagic (fromIntegral (optNetworkMagic opts))) - connInfo = LocalNodeConnectInfo - { Api.localConsensusModeParams = CardanoModeParams byronEpochSlots - , Api.localNodeNetworkId = networkId - , Api.localNodeSocketPath = File (optSocketPath opts) - } + connInfo = + LocalNodeConnectInfo + { Api.localConsensusModeParams = CardanoModeParams byronEpochSlots + , Api.localNodeNetworkId = networkId + , Api.localNodeSocketPath = File (optSocketPath opts) + } -- Dispatch on whatever era the node reports; the tx builder is -- generic over ShelleyBasedEra. @@ -171,10 +193,10 @@ main = do -- | Fail if the node is in Byron; otherwise run the continuation with -- the era's 'ShelleyBasedEra' witness. -runInEra - :: AnyCardanoEra - -> (forall era. Api.ShelleyBasedEraConstraints era => ShelleyBasedEra era -> IO ()) - -> IO () +runInEra :: + AnyCardanoEra -> + (forall era. Api.ShelleyBasedEraConstraints era => ShelleyBasedEra era -> IO ()) -> + IO () runInEra (AnyCardanoEra ce) k = Api.caseByronOrShelleyBasedEra (die "tx-firehose: Byron era is not supported") @@ -189,32 +211,27 @@ validateOptions opts = do when (optMaxConsecutiveErrors opts <= 0) $ die "--max-consecutive-errors must be >= 1" +-- | Byron epoch length passed in ConsensusModeParams -- only used to +-- decode Byron EBBs, which we never do. Matches every historical +-- Cardano network and is what cardano-cli hardcodes. byronEpochSlots :: Api.EpochSlots byronEpochSlots = Api.EpochSlots 21600 --------------------------------------------------------------------------------- --- Per-era firehose --------------------------------------------------------------------------------- - -- | Query the initial UTxO for the derived address, then open a single -- N2C connection whose LocalTxSubmission client drives the whole loop. -- No separate thread and no shared TVar: the loop's state (funds and -- consecutive-error counter) lives in the client's recursive -- continuation. -runFirehoseInEra - :: Api.ShelleyBasedEraConstraints era - => ShelleyBasedEra era - -> Options - -> LocalNodeConnectInfo - -> NetworkId - -> SigningKey Api.PaymentKey - -> Maybe (Api.VerificationKey Api.StakeKey) - -> IO () +runFirehoseInEra :: + Api.ShelleyBasedEraConstraints era => + ShelleyBasedEra era -> + Options -> + LocalNodeConnectInfo -> + NetworkId -> + SigningKey Api.PaymentKey -> + Maybe (Api.VerificationKey Api.StakeKey) -> + IO () runFirehoseInEra sbe opts connInfo networkId signingKey mStakeVk = do - let addrInEra = deriveAddress sbe networkId signingKey mStakeVk - addrAny = case addrInEra of - Api.AddressInEra _ addr -> Api.toAddressAny addr - trace "TxFirehose.Startup.Query" "Info" $ Aeson.object ["address" .= T.pack (show addrAny), "era" .= show sbe] @@ -222,123 +239,139 @@ runFirehoseInEra sbe opts connInfo networkId signingKey mStakeVk = do when (Map.null initialFunds) $ die "tx-firehose: no UTxO found at derived address - fund it first" - trace "TxFirehose.Startup.Seeded" "Info" $ Aeson.object - [ "utxos" .= Map.size initialFunds - , "totalLovelace" .= sum (Map.elems initialFunds) - ] + trace "TxFirehose.Startup.Seeded" "Info" $ + Aeson.object + [ "utxos" .= Map.size initialFunds + , "totalLovelace" .= sum (Map.elems initialFunds) + ] - Api.connectToLocalNode connInfo LocalNodeClientProtocols - { localChainSyncClient = NoLocalChainSyncClient - , localStateQueryClient = Nothing - , localTxSubmissionClient = - Just (mkFirehoseClient sbe opts addrInEra signingKey initialFunds) - , localTxMonitoringClient = Nothing - } + Api.connectToLocalNode + connInfo + LocalNodeClientProtocols + { localChainSyncClient = NoLocalChainSyncClient + , localStateQueryClient = Nothing + , localTxSubmissionClient = + Just (mkFirehoseClient sbe opts addrInEra signingKey initialFunds) + , localTxMonitoringClient = Nothing + } + where + addrInEra = deriveAddress sbe networkId signingKey mStakeVk + addrAny = case addrInEra of + Api.AddressInEra _ addr -> Api.toAddressAny addr -- | The LocalTxSubmission state machine. Holds the fund set and the -- consecutive-error counter as strict recursive parameters — no TVars, -- no IORefs, no async. -mkFirehoseClient - :: forall era - . Api.ShelleyBasedEraConstraints era - => ShelleyBasedEra era - -> Options - -> AddressInEra era - -> SigningKey Api.PaymentKey - -> Map TxIn Integer - -> LocalTxSubmissionClient TxInMode TxValidationErrorInCardanoMode IO () +mkFirehoseClient :: + forall era. + Api.ShelleyBasedEraConstraints era => + ShelleyBasedEra era -> + Options -> + AddressInEra era -> + SigningKey Api.PaymentKey -> + Map TxIn Integer -> + LocalTxSubmissionClient TxInMode TxValidationErrorInCardanoMode IO () mkFirehoseClient sbe opts addr sk initialFunds = - LocalTxSubmissionClient (step initialFunds 0) - where - !period = round (1_000_000 / optTps opts) :: Int - !n = fromIntegral (optInputsPerTx opts) :: Int - !maxErrs = optMaxConsecutiveErrors opts - - -- One step of the loop, in IO. Returns the next client state. - step - :: Map TxIn Integer - -> Int - -> IO (LocalTxClientStIdle TxInMode TxValidationErrorInCardanoMode IO ()) - step !funds !consec - | Map.size funds < n = - -- We recycle outputs on every success and never lose funds on - -- reject (inputs stay put), so running dry is catastrophic — - -- exit and let the supervisor restart with a fresh query. - pure (SendMsgDone ()) - | otherwise = - let (chosen, funds') = takeInputs n funds - inFunds = - [ Fund { fundTxIn = tin, fundValue = v } - | (tin, v) <- chosen - ] - in case Tx.buildTx sbe addr sk inFunds - (optOutputsPerTx opts) (Coin (optFee opts)) of - Left err -> do - trace "TxFirehose.Build.Fail" "Error" $ - Aeson.object ["error" .= T.pack err] - -- Inputs stay in the fund set: buildTx never touched - -- them, so this is just a signal for restart. - onError funds consec ("buildTx: " ++ err) - Right built -> - pure (submitStep funds funds' consec built) + LocalTxSubmissionClient (step initialFunds 0) + where + !period = round (1_000_000 / optTps opts) :: Int + !n = fromIntegral (optInputsPerTx opts) :: Int + !maxErrs = optMaxConsecutiveErrors opts + + -- One step of the loop, in IO. Returns the next client state. + step :: + Map TxIn Integer -> + Int -> + IO (LocalTxClientStIdle TxInMode TxValidationErrorInCardanoMode IO ()) + step !funds !consec + | Map.size funds < n = + -- We recycle outputs on every success and never lose funds on + -- reject (inputs stay put), so running dry is catastrophic — + -- exit and let the supervisor restart with a fresh query. + pure (SendMsgDone ()) + | otherwise = + case Tx.buildTx sbe addr sk inFunds + (optOutputsPerTx opts) (Coin (optFee opts)) of + Left err -> do + trace "TxFirehose.Build.Fail" "Error" $ + Aeson.object ["error" .= T.pack err] + -- Inputs stay in the fund set: buildTx never touched + -- them, so this is just a signal for restart. + onError funds consec ("buildTx: " ++ err) + Right built -> + pure (submitStep funds funds' consec built) + where + (chosen, funds') = takeInputs n funds + inFunds = + [ Fund{fundTxIn = tin, fundValue = v} + | (tin, v) <- chosen + ] - -- SendMsgSubmitTx state: post-submit handling of the reply. - submitStep - :: Map TxIn Integer -- ^ funds to keep on reject (inputs still there) - -> Map TxIn Integer -- ^ funds after removing this tx's inputs - -> Int - -> BuiltTx era - -> LocalTxClientStIdle TxInMode TxValidationErrorInCardanoMode IO () - submitStep fundsOnFail fundsOnSuccess !consec - BuiltTx { btxSigned, btxId, btxSize, btxOutputs } = + -- SendMsgSubmitTx state: post-submit handling of the reply. + submitStep :: + Map TxIn Integer -> + -- \^ funds to keep on reject (inputs still there) + Map TxIn Integer -> + -- \^ funds after removing this tx's inputs + Int -> + BuiltTx era -> + LocalTxClientStIdle TxInMode TxValidationErrorInCardanoMode IO () + submitStep + fundsOnFail + fundsOnSuccess + !consec + BuiltTx{btxSigned, btxId, btxSize, btxOutputs} = SendMsgSubmitTx (TxInMode sbe btxSigned) $ \result -> do threadDelay period case result of SubmitSuccess -> do - trace "TxFirehose.Submit.Success" "Info" $ Aeson.object - [ "txId" .= btxId, "size" .= btxSize ] + trace "TxFirehose.Submit.Success" "Info" $ + Aeson.object + ["txId" .= btxId, "size" .= btxSize] let !funds'' = foldr addOutput fundsOnSuccess btxOutputs step funds'' 0 SubmitFail reason -> do - trace "TxFirehose.Submit.Reject" "Warning" $ Aeson.object - [ "txId" .= btxId, "size" .= btxSize - , "reason" .= T.pack (show reason) - ] + trace "TxFirehose.Submit.Reject" "Warning" $ + Aeson.object + [ "txId" .= btxId + , "size" .= btxSize + , "reason" .= T.pack (show reason) + ] onError fundsOnFail consec (show reason) - -- Bump the consecutive-error counter and either exit or loop. - onError - :: Map TxIn Integer - -> Int - -> String - -> IO (LocalTxClientStIdle TxInMode TxValidationErrorInCardanoMode IO ()) - onError funds !consec reason = do - let !consec' = consec + 1 - if consec' >= maxErrs - then do - trace "TxFirehose.Exit.MaxErrors" "Error" $ Aeson.object - [ "threshold" .= maxErrs + -- Bump the consecutive-error counter and either exit or loop. + onError :: + Map TxIn Integer -> + Int -> + String -> + IO (LocalTxClientStIdle TxInMode TxValidationErrorInCardanoMode IO ()) + onError funds !consec reason + | consec' >= maxErrs = do + trace "TxFirehose.Exit.MaxErrors" "Error" $ + Aeson.object + [ "threshold" .= maxErrs , "lastReason" .= T.pack reason ] - die $ "tx-firehose: " ++ show maxErrs - ++ " consecutive rejects, exiting for restart (last: " - ++ reason ++ ")" - else step funds consec' + die $ + "tx-firehose: " + ++ show maxErrs + ++ " consecutive rejects, exiting for restart (last: " + ++ reason + ++ ")" + | otherwise = step funds consec' + where + !consec' = consec + 1 -- | Deterministically pull @n@ entries out of a fund set. takeInputs :: Int -> Map TxIn Integer -> ([(TxIn, Integer)], Map TxIn Integer) -takeInputs n m = - let taken = take n (Map.toList m) - m' = foldr (Map.delete . fst) m taken - in (taken, m') +takeInputs n m = (taken, m') + where + taken = take n (Map.toList m) + m' = foldr (Map.delete . fst) m taken addOutput :: Fund -> Map TxIn Integer -> Map TxIn Integer addOutput f = Map.insert (fundTxIn f) (fundValue f) --------------------------------------------------------------------------------- --- Structured logging --------------------------------------------------------------------------------- - -- | Emit one JSON line in the cardano-node trace schema -- (@{at, sev, host, thread, ns, data}@). The proto-devnet Alloy -- pipeline turns @ns@ into a Loki label, so Grafana can filter on @@ -346,33 +379,35 @@ addOutput f = Map.insert (fundTxIn f) (fundValue f) trace :: Text -> Text -> Value -> IO () trace ns sev dat = do now <- getCurrentTime - let payload = Aeson.object - [ "at" .= T.pack (iso8601Show now) - , "sev" .= sev - , "host" .= ("tx-firehose" :: Text) - , "thread" .= ("main" :: Text) - , "ns" .= ns - , "data" .= dat - ] - BSL.hPutStrLn stderr (Aeson.encode payload) - --------------------------------------------------------------------------------- --- Startup helpers --------------------------------------------------------------------------------- + BSL.hPutStrLn stderr (Aeson.encode (payload now)) + where + payload now = + Aeson.object + [ "at" .= T.pack (iso8601Show now) + , "sev" .= sev + , "host" .= ("tx-firehose" :: Text) + , "thread" .= ("main" :: Text) + , "ns" .= ns + , "data" .= dat + ] loadSigningKey :: FilePath -> IO (SigningKey Api.PaymentKey) loadSigningKey path = do result <- Api.readFileTextEnvelopeAnyOf accepted (File path) case result of - Left err -> die $ "tx-firehose: cannot read signing key " - ++ show path ++ ": " ++ show err + Left err -> + die $ + "tx-firehose: cannot read signing key " + ++ show path + ++ ": " + ++ show err Right sk -> pure sk - where - accepted :: [FromSomeType Api.HasTextEnvelope (SigningKey Api.PaymentKey)] - accepted = - [ FromSomeType (Api.AsSigningKey Api.AsGenesisUTxOKey) Api.castSigningKey - , FromSomeType (Api.AsSigningKey Api.AsPaymentKey) id - ] + where + accepted :: [FromSomeType Api.HasTextEnvelope (SigningKey Api.PaymentKey)] + accepted = + [ FromSomeType (Api.AsSigningKey Api.AsGenesisUTxOKey) Api.castSigningKey + , FromSomeType (Api.AsSigningKey Api.AsPaymentKey) id + ] -- | Load a stake signing key and derive its verification key. Only the -- vkey hash is used (to build a base address); the stake key does not @@ -381,27 +416,34 @@ loadStakingKey :: FilePath -> IO (Api.VerificationKey Api.StakeKey) loadStakingKey path = do result <- Api.readFileTextEnvelope (File path) case result of - Left err -> die $ "tx-firehose: cannot read stake key " - ++ show path ++ ": " ++ show err + Left err -> + die $ + "tx-firehose: cannot read stake key " + ++ show path + ++ ": " + ++ show err Right (sk :: SigningKey Api.StakeKey) -> pure (Api.getVerificationKey sk) -deriveAddress - :: ShelleyBasedEra era - -> NetworkId - -> SigningKey Api.PaymentKey - -> Maybe (Api.VerificationKey Api.StakeKey) - -> AddressInEra era +deriveAddress :: + ShelleyBasedEra era -> + NetworkId -> + SigningKey Api.PaymentKey -> + Maybe (Api.VerificationKey Api.StakeKey) -> + AddressInEra era deriveAddress sbe networkId sk mStakeVk = Api.shelleyAddressInEra sbe $ - Api.makeShelleyAddress networkId - (PaymentCredentialByKey - (Api.verificationKeyHash (Api.getVerificationKey sk))) + Api.makeShelleyAddress + networkId + ( PaymentCredentialByKey + (Api.verificationKeyHash (Api.getVerificationKey sk)) + ) stakeRef - where - stakeRef = case mStakeVk of - Nothing -> NoStakeAddress - Just vk -> Api.StakeAddressByValue - (Api.StakeCredentialByKey (Api.verificationKeyHash vk)) + where + stakeRef = case mStakeVk of + Nothing -> NoStakeAddress + Just vk -> + Api.StakeAddressByValue + (Api.StakeCredentialByKey (Api.verificationKeyHash vk)) -------------------------------------------------------------------------------- -- Local-state queries @@ -417,15 +459,12 @@ queryCurrentEra connInfo = do -- | Query the current UTxO at our derived address in whatever era the -- node reports. Converts each 'Api.TxIn' to the ledger 'TxIn' so the -- fund set the client owns is in ledger types from the start. -queryFundsInEra - :: ShelleyBasedEra era - -> LocalNodeConnectInfo - -> AddressAny - -> IO (Map TxIn Integer) +queryFundsInEra :: + ShelleyBasedEra era -> + LocalNodeConnectInfo -> + AddressAny -> + IO (Map TxIn Integer) queryFundsInEra sbe connInfo addrAny = do - let q = QueryInEra - (QueryInShelleyBasedEra sbe - (QueryUTxO (QueryUTxOByAddress (Set.singleton addrAny)))) res <- runExceptT $ Api.queryNodeLocalState connInfo VolatileTip q case res of Left af -> die $ "tx-firehose: failed to acquire tip: " ++ show af @@ -436,7 +475,14 @@ queryFundsInEra sbe connInfo addrAny = do [ (Api.toShelleyTxIn tin, toLovelace txOut) | (tin, txOut) <- Map.toList m ] - where - toLovelace :: Api.TxOut Api.CtxUTxO era -> Integer - toLovelace (Api.TxOut _ v _ _) = - let Coin c = Api.txOutValueToLovelace v in c + where + q = + QueryInEra + ( QueryInShelleyBasedEra + sbe + (QueryUTxO (QueryUTxOByAddress (Set.singleton addrAny))) + ) + toLovelace :: Api.TxOut Api.CtxUTxO era -> Integer + toLovelace (Api.TxOut _ v _ _) = c + where + Coin c = Api.txOutValueToLovelace v diff --git a/bench/tx-firehose/fourmolu.yaml b/bench/tx-firehose/fourmolu.yaml new file mode 100644 index 00000000000..a6618df746d --- /dev/null +++ b/bench/tx-firehose/fourmolu.yaml @@ -0,0 +1,7 @@ +indentation: 2 +column-limit: 100 +import-export-style: leading +haddock-style: single-line +single-constraint-parens: never +single-deriving-parens: never +import-grouping: single diff --git a/bench/tx-firehose/src/Cardano/Benchmarking/TxFirehose/Tx.hs b/bench/tx-firehose/src/Cardano/Benchmarking/TxFirehose/Tx.hs index 177782e0e12..a5c480e23d5 100644 --- a/bench/tx-firehose/src/Cardano/Benchmarking/TxFirehose/Tx.hs +++ b/bench/tx-firehose/src/Cardano/Benchmarking/TxFirehose/Tx.hs @@ -11,21 +11,9 @@ -- 'makeShelleyKeyWitness'' - that path is era-generic and, unlike -- 'createTransactionBody', does not trip over the Dijkstra witness -- extraction case-analysis. -module Cardano.Benchmarking.TxFirehose.Tx - ( Fund (..) - , BuiltTx (..) - , buildTx - ) where - -import Data.Function ((&)) -import Data.Sequence.Strict qualified as StrictSeq -import Data.Set qualified as Set -import Data.Word (Word32) -import Lens.Micro ((%~), (.~), (^.)) -import Numeric.Natural (Natural) +module Cardano.Benchmarking.TxFirehose.Tx where import Cardano.Api qualified as Api - import Cardano.Ledger.Api ( addrTxWitsL , feeTxBodyL @@ -39,12 +27,18 @@ import Cardano.Ledger.Api ) import Cardano.Ledger.Api.Tx.In (TxId, TxIn, mkTxInPartial) import Cardano.Ledger.Coin (Coin (Coin)) +import Data.Function ((&)) +import Data.Sequence.Strict qualified as StrictSeq +import Data.Set qualified as Set +import Data.Word (Word32) +import Lens.Micro ((%~), (.~), (^.)) +import Numeric.Natural (Natural) -- | A spendable UTxO we own: ledger-level 'TxIn' + its lovelace value. -- Keeping the internal fund set ledger-typed lets the tx builder stay -- pure ledger; api conversion only happens at query \/ submit boundaries. data Fund = Fund - { fundTxIn :: !TxIn + { fundTxIn :: !TxIn , fundValue :: !Integer } deriving (Eq, Ord, Show) @@ -52,83 +46,96 @@ data Fund = Fund -- | A built and signed transaction, together with observability -- metadata we want to trace on submit. data BuiltTx era = BuiltTx - { btxSigned :: !(Api.Tx era) - , btxId :: !TxId - , btxSize :: !Word32 + { btxSigned :: !(Api.Tx era) + , btxId :: !TxId + , btxSize :: !Word32 , btxOutputs :: ![Fund] } -- | Build and sign an era-generic 1..n-input, m-output transaction that -- sends the change back to @destAddr@ under @signingKey@. -buildTx - :: forall era - . Api.ShelleyBasedEraConstraints era - => Api.ShelleyBasedEra era - -> Api.AddressInEra era - -> Api.SigningKey Api.PaymentKey - -> [Fund] - -> Natural - -> Coin - -> Either String (BuiltTx era) +buildTx :: + forall era. + Api.ShelleyBasedEraConstraints era => + Api.ShelleyBasedEra era -> + Api.AddressInEra era -> + Api.SigningKey Api.PaymentKey -> + [Fund] -> + Natural -> + Coin -> + Either String (BuiltTx era) buildTx sbe destAddr signingKey inFunds numOutputs fee | null inFunds = Left "buildTx: no input funds" | numOutputs == 0 = Left "buildTx: outputs_per_tx must be >= 1" | feeLovelace < 0 = Left "buildTx: fee must be >= 0" - | changeTotal <= 0 = Left $ - "buildTx: insufficient funds - total inputs (" ++ show totalIn - ++ " lovelace) do not cover fee (" ++ show feeLovelace ++ ")" - | minOutputLovelace <= 0 = Left $ - "buildTx: output value too low - " ++ show numOutputs - ++ " outputs from " ++ show changeTotal - ++ " lovelace yields " ++ show minOutputLovelace ++ " per output" + | changeTotal <= 0 = + Left $ + "buildTx: insufficient funds - total inputs (" + ++ show totalIn + ++ " lovelace) do not cover fee (" + ++ show feeLovelace + ++ ")" + | minOutputLovelace <= 0 = + Left $ + "buildTx: output value too low - " + ++ show numOutputs + ++ " outputs from " + ++ show changeTotal + ++ " lovelace yields " + ++ show minOutputLovelace + ++ " per output" | otherwise = Right built - where - -- Body: pure ledger, era-generic via EraTxBody. - body = - mkBasicTxBody - & inputsTxBodyL .~ Set.fromList (map fundTxIn inFunds) - & outputsTxBodyL %~ (<> StrictSeq.fromList (map mkOut outAmounts)) - & feeTxBodyL .~ fee + where + -- Body: pure ledger, era-generic via EraTxBody. + body = + mkBasicTxBody + & inputsTxBodyL .~ Set.fromList (map fundTxIn inFunds) + & outputsTxBodyL %~ (<> StrictSeq.fromList (map mkOut outAmounts)) + & feeTxBodyL .~ fee - -- Signing via cardano-api - era-generic and Dijkstra-safe. - witVKey = case Api.makeShelleyKeyWitness' sbe body - (Api.WitnessPaymentKey signingKey) of - Api.ShelleyKeyWitness _ w -> w - _ -> error "buildTx: unexpected non-Shelley witness" + -- Signing via cardano-api - era-generic and Dijkstra-safe. + witVKey = case Api.makeShelleyKeyWitness' + sbe + body + (Api.WitnessPaymentKey signingKey) of + Api.ShelleyKeyWitness _ w -> w + _ -> error "buildTx: unexpected non-Shelley witness" - ledgerTx = - mkBasicTx body - & witsTxL . addrTxWitsL .~ Set.singleton witVKey + ledgerTx = + mkBasicTx body + & witsTxL . addrTxWitsL .~ Set.singleton witVKey - ledgerTxId = txIdTx ledgerTx + ledgerTxId = txIdTx ledgerTx - outFunds = - [ Fund { fundTxIn = mkTxInPartial ledgerTxId ix, fundValue = amt } - | (ix, amt) <- zip [0..] outAmounts - ] + outFunds = + [ Fund{fundTxIn = mkTxInPartial ledgerTxId ix, fundValue = amt} + | (ix, amt) <- zip [0 ..] outAmounts + ] - built = BuiltTx - { btxSigned = Api.ShelleyTx sbe ledgerTx - , btxId = ledgerTxId - , btxSize = ledgerTx ^. sizeTxF + built = + BuiltTx + { btxSigned = Api.ShelleyTx sbe ledgerTx + , btxId = ledgerTxId + , btxSize = ledgerTx ^. sizeTxF , btxOutputs = outFunds } - -- Money math. - totalIn = sum (map fundValue inFunds) - feeLovelace = let Coin c = fee in c - changeTotal = totalIn - feeLovelace - n = fromIntegral numOutputs :: Integer - minOutputLovelace = changeTotal `div` n - outAmounts = - let base = changeTotal `div` n - remainder = changeTotal `mod` n - in (base + remainder) : replicate (fromIntegral numOutputs - 1) base + -- Money math. + totalIn = sum (map fundValue inFunds) + Coin feeLovelace = fee + changeTotal = totalIn - feeLovelace + n = fromIntegral numOutputs :: Integer + minOutputLovelace = changeTotal `div` n + outAmounts = (base + remainder) : replicate (fromIntegral numOutputs - 1) base + where + base = changeTotal `div` n + remainder = changeTotal `mod` n - mkOut lovelace = - let apiOut = Api.TxOut - destAddr - (Api.lovelaceToTxOutValue sbe (Coin lovelace)) - Api.TxOutDatumNone - Api.ReferenceScriptNone - in Api.toShelleyTxOutAny sbe apiOut + mkOut lovelace = Api.toShelleyTxOutAny sbe apiOut + where + apiOut = + Api.TxOut + destAddr + (Api.lovelaceToTxOutValue sbe (Coin lovelace)) + Api.TxOutDatumNone + Api.ReferenceScriptNone