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..0a5a6e3519f --- /dev/null +++ b/bench/tx-firehose/app/Main.hs @@ -0,0 +1,488 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Main (main) where + +import Cardano.Api + ( AddressAny + , AddressInEra + , AnyCardanoEra (AnyCardanoEra) + , ConsensusModeParams (CardanoModeParams) + , File (File) + , FromSomeType (FromSomeType) + , LocalChainSyncClient (NoLocalChainSyncClient) + , LocalNodeClientProtocols + ( LocalNodeClientProtocols + , localChainSyncClient + , localStateQueryClient + , localTxMonitoringClient + , localTxSubmissionClient + ) + , LocalNodeConnectInfo (LocalNodeConnectInfo) + , NetworkId (Testnet) + , NetworkMagic (NetworkMagic) + , PaymentCredential (PaymentCredentialByKey) + , QueryInEra (QueryInShelleyBasedEra) + , QueryInMode (QueryCurrentEra, QueryInEra) + , QueryInShelleyBasedEra (QueryUTxO) + , QueryUTxOFilter (QueryUTxOByAddress) + , ShelleyBasedEra + , SigningKey + , StakeAddressReference (NoStakeAddress) + , SubmitResult (SubmitFail, SubmitSuccess) + , Target (VolatileTip) + , TxInMode (TxInMode) + , TxValidationErrorInCardanoMode + , 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 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 + , 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 + ( 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 + -- Force stderr to UTF-8 + line buffering so log messages don't get + -- garbled or merged when the process runs under `LANG=C`. + hSetEncoding stderr utf8 + hSetBuffering stderr LineBuffering + + opts <- parseOptions + validateOptions opts + + signingKey <- loadSigningKey (optSigningKey opts) + 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) + } + + -- 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" + +-- | 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 + +-- | 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 + trace "TxFirehose.Startup.Query" "Info" $ + 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 + , "totalLovelace" .= sum (Map.elems initialFunds) + ] + + 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 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 = + 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 (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 + | 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 + ++ ")" + | 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 = (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) + +-- | 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 + 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 + 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 + ] + +-- | 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) + 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 :: + 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)) + ) + stakeRef + where + stakeRef = case mStakeVk of + Nothing -> NoStakeAddress + Just vk -> + Api.StakeAddressByValue + (Api.StakeCredentialByKey (Api.verificationKeyHash vk)) + +-------------------------------------------------------------------------------- +-- Local-state queries +-------------------------------------------------------------------------------- + +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 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 + 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.fromList $ + [ (Api.toShelleyTxIn tin, toLovelace txOut) + | (tin, txOut) <- Map.toList m + ] + 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 new file mode 100644 index 00000000000..a5c480e23d5 --- /dev/null +++ b/bench/tx-firehose/src/Cardano/Benchmarking/TxFirehose/Tx.hs @@ -0,0 +1,141 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Era-generic transaction builder for tx-firehose. +-- +-- 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 where + +import Cardano.Api qualified as Api +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)) +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 + , fundValue :: !Integer + } + deriving (Eq, Ord, Show) + +-- | 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 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 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" + | 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 + + -- 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) + 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 = Api.toShelleyTxOutAny sbe apiOut + where + apiOut = + Api.TxOut + destAddr + (Api.lovelaceToTxOutValue sbe (Coin lovelace)) + Api.TxOutDatumNone + Api.ReferenceScriptNone diff --git a/bench/tx-firehose/tx-firehose.cabal b/bench/tx-firehose/tx-firehose.cabal new file mode 100644 index 00000000000..cce56a85228 --- /dev/null +++ b/bench/tx-firehose/tx-firehose.cabal @@ -0,0 +1,62 @@ +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.Tx + build-depends: base >= 4.14 && < 5 + , cardano-api + , cardano-ledger-api + , cardano-ledger-core + , cardano-strict-containers + , containers + , microlens + +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 + , aeson + , bytestring + , cardano-api + , cardano-ledger-api + , cardano-ledger-core + , containers + , optparse-applicative + , ouroboros-network:protocols + , text + , time + , 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