diff --git a/cardano-tx-generator/cardano-tx-generator.cabal b/cardano-tx-generator/cardano-tx-generator.cabal index 41ca9da0..21f27749 100644 --- a/cardano-tx-generator/cardano-tx-generator.cabal +++ b/cardano-tx-generator/cardano-tx-generator.cabal @@ -31,10 +31,12 @@ library build-depends: aeson , async + , attoparsec , base >=4.12 && <5 , bytestring , cardano-api , cardano-binary + , cardano-cli , cardano-config , cardano-crypto-class , cardano-crypto-wrapper @@ -49,6 +51,7 @@ library , filepath , formatting , generic-monoid + , generics-sop , ghc-prim , http-client , http-types diff --git a/cardano-tx-generator/src/Cardano/Benchmarking/GeneratorTx.hs b/cardano-tx-generator/src/Cardano/Benchmarking/GeneratorTx.hs index 022d7ac7..674701a8 100644 --- a/cardano-tx-generator/src/Cardano/Benchmarking/GeneratorTx.hs +++ b/cardano-tx-generator/src/Cardano/Benchmarking/GeneratorTx.hs @@ -8,6 +8,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} {-# OPTIONS_GHC -Wno-all-missed-specialisations #-} {-# OPTIONS_GHC -Wno-missed-specialisations #-} @@ -21,14 +22,15 @@ module Cardano.Benchmarking.GeneratorTx , TPSRate(..) , TxAdditionalSize(..) , TxGenError - , genesisBenchmarkRunner + , secureFunds + , runBenchmark ) where import Cardano.Prelude -import Prelude (String, id) +import Prelude (String, error, id) import Control.Concurrent (threadDelay) -import Control.Monad (forM, forM_) +import Control.Monad (fail, forM, forM_) import Control.Monad.Trans.Except (ExceptT) import Control.Monad.Trans.Except.Extra (left, right, newExceptT) import Control.Tracer (traceWith) @@ -63,34 +65,6 @@ import Cardano.Benchmarking.GeneratorTx.Submission import Cardano.Benchmarking.GeneratorTx.Tx ------------------------------------------------------------------------------------------ --- | Genesis benchmark runner (we call it in 'Run.runNode'). --- --- Using a _richman_ (from genesis block) to supply some initial --- amount of funds for disbursment. ------------------------------------------------------------------------------------------ -genesisBenchmarkRunner - :: EraSupportsTxGen era - => Benchmark -> Era era -> SigningKeyFile - -> ExceptT TxGenError IO () -genesisBenchmarkRunner b p keyFile = do - key <- readSigningKey p keyFile - liftIO . traceWith (trTxSubmit p) . TraceBenchTxSubDebug - $ "******* Tx generator, signing keys are ready *******" - - fundsWithGenesisMoney <- liftIO $ - prepareInitialFunds b p - (extractGenesisFunds p key) key - (keyAddress p key) - - liftIO . traceWith (trTxSubmit p) . TraceBenchTxSubDebug - $ "******* Tx generator, initial funds are prepared (sent to sourceAddress) *******" - - runBenchmark b p key (keyAddress p key) fundsWithGenesisMoney - -{------------------------------------------------------------------------------- - Main logic --------------------------------------------------------------------------------} readSigningKey :: Era era -> SigningKeyFile -> ExceptT TxGenError IO (SigningKeyOf era) @@ -105,36 +79,49 @@ readSigningKey p = , FromSomeType (AsSigningKey AsPaymentKey) id ] ------------------------------------------------------------------------------------------ --- Obtain initial funds. ------------------------------------------------------------------------------------------ -prepareInitialFunds - :: forall era - . EraSupportsTxGen era +secureFunds :: ConfigSupportsTxGen mode era => Benchmark - -> Era era - -> (TxIn, TxOut era) - -> SigningKeyOf era - -> Address era - -> IO (TxIn, TxOut era) -prepareInitialFunds - Benchmark{bTxFee, bInitialTTL} p (_, TxOut _ genesisCoin) key toAddr = do - r <- submitTx (eraLocalConnInfo p) (castTxMode tx) - liftIO . traceWith (trTxSubmit p) . TraceBenchTxSubDebug + -> Mode mode era + -> GeneratorFunds + -> ExceptT TxGenError IO (SigningKeyOf era, (TxIn, TxOut era)) + +secureFunds Benchmark{bTxFee, bInitialTTL} m (FundsGenesis keyF) = do + key <- readSigningKey (modeEra m) keyF + let (_, TxOut _ genesisCoin) = extractGenesisFunds m key + toAddr = keyAddress m key + (tx, txin, txout) = + genesisExpenditure m key toAddr genesisCoin bTxFee bInitialTTL + txOfMode = castTxMode m tx + r <- liftIO $ submitTx (modeLocalConnInfo m) txOfMode + liftIO . traceWith (trTxSubmit m) . TraceBenchTxSubDebug $ "------------- WIN3" + case r of + TxSubmitSuccess -> + liftIO . traceWith (trTxSubmit m) . TraceBenchTxSubDebug $ mconcat - [ "******* Genesis funds move (", show txin, " -> ", show txout - , ") submission result: " - , show r] - pure (txin, txout) - where - (tx, txin, txout) = - genesisExpenditure p key toAddr genesisCoin bTxFee bInitialTTL + [ "******* Funding secured (", show txin, " -> ", show txout + , "), submission result: " , show r ] + e -> fail $ show e + pure (key, (txin, txout)) + +secureFunds _ m@ModeShelley{} (FundsUtxo keyF txin txout) = do + key <- readSigningKey (modeEra m) keyF + pure (key, (txin, txout)) + +secureFunds _ m@ModeCardanoShelley{} (FundsUtxo keyF txin txout) = do + key <- readSigningKey (modeEra m) keyF + pure (key, (txin, txout)) + +secureFunds _ m f = + error $ "secureFunds: unsupported config: " <> show m <> " / " <> show f +----------------------------------------------------------------------------------------- +-- Obtain initial funds. +----------------------------------------------------------------------------------------- splitFunds - :: forall era - . EraSupportsTxGen era + :: forall mode era + . ConfigSupportsTxGen mode era => Benchmark - -> Era era + -> Mode mode era -> SigningKeyOf era -> (TxIn, TxOut era) -> ExceptT TxGenError IO (Set (TxIn, TxOut era)) @@ -142,7 +129,7 @@ splitFunds Benchmark{ bTxFee=fee@(Lovelace feeRaw), bTxCount=NumberOfTxs numTxs , bTxFanIn=NumberOfInputsPerTx txFanin } - p sourceKey fundsTxIO@(_, (TxOut addr (Lovelace rawCoin))) = do + m sourceKey fundsTxIO@(_, (TxOut addr (Lovelace rawCoin))) = do let -- The number of splitting txout entries (corresponds to the number of all inputs we will need). numRequiredTxOuts = numTxs * fromIntegral txFanin splitFanout = 60 :: Word64 -- near the upper bound so as not to exceed the tx size limit @@ -170,7 +157,7 @@ splitFunds [] -- Submit all splitting transactions sequentially. forM_ (zip splittingTxs [0::Int ..]) $ \((tx, _), i) -> - liftIO (submitTx (eraLocalConnInfo p) (castTxMode tx)) + liftIO (submitTx (modeLocalConnInfo m) (castTxMode m tx)) >>= \case TxSubmitSuccess -> pure () x -> left . SplittingSubmissionError $ mconcat @@ -204,7 +191,7 @@ splitFunds identityIndex + fromIntegral numOutsPerInitTx - 1] (repeat txOut) (mFunds, _fees, outIndices, splitTx) = - mkTransactionGen p sKey (txIO :| []) Nothing outs 0 fee + mkTransactionGen m sKey (txIO :| []) Nothing outs 0 fee !splitTxId = getTxId $ getTxBody splitTx txIOList = flip map (Map.toList outIndices) $ \(_, txInIndex) -> @@ -241,32 +228,30 @@ splitFunds -- So if one Cardano tx contains 10 outputs (with addresses of 10 recipients), -- we have 1 Cardano tx and 10 fiscal txs. runBenchmark - :: forall era - . (EraSupportsTxGen era) + :: forall mode era + . ConfigSupportsTxGen mode era => Benchmark - -> Era era + -> Mode mode era -> SigningKeyOf era - -> Address era -> (TxIn, TxOut era) -> ExceptT TxGenError IO () runBenchmark b@Benchmark{ bTargets , bTps , bInitCooldown=InitCooldown initCooldown } - p - sourceKey - recipientAddress - fundsWithGenesisMoney = do - liftIO . traceWith (trTxSubmit p) . TraceBenchTxSubDebug - $ "******* Tx generator, phase 1: make enough available UTxO entries using: " <> (show fundsWithGenesisMoney :: String) + m fundsKey funds = do + let recipientAddress = keyAddress m fundsKey + + liftIO . traceWith (trTxSubmit m) . TraceBenchTxSubDebug + $ "******* Tx generator, phase 1: make enough available UTxO entries using: " <> (show funds :: String) fundsWithSufficientCoins <- - splitFunds b p sourceKey fundsWithGenesisMoney + splitFunds b m fundsKey funds - liftIO . traceWith (trTxSubmit p) . TraceBenchTxSubDebug + liftIO . traceWith (trTxSubmit m) . TraceBenchTxSubDebug $ "******* Tx generator: waiting " ++ show initCooldown ++ "s *******" liftIO $ threadDelay (initCooldown*1000*1000) - liftIO . traceWith (trTxSubmit p) . TraceBenchTxSubDebug + liftIO . traceWith (trTxSubmit m) . TraceBenchTxSubDebug $ "******* Tx generator, phase 2: pay to recipients *******" let localAddr :: Maybe Network.Socket.AddrInfo @@ -296,16 +281,16 @@ runBenchmark b@Benchmark{ bTargets let numTargets :: Natural = fromIntegral $ NE.length bTargets txs :: [Tx era] <- txGenerator - b p + b m recipientAddress - sourceKey + fundsKey (NE.length bTargets) fundsWithSufficientCoins liftIO $ do - traceWith (trTxSubmit p) . TraceBenchTxSubDebug + traceWith (trTxSubmit m) . TraceBenchTxSubDebug $ "******* Tx generator, launching Tx peers: " ++ show (NE.length remoteAddresses) ++ " of them" - submission <- mkSubmission (trTxSubmit p) $ + submission <- mkSubmission (trTxSubmit m) $ SubmissionParams { spTps = bTps , spTargets = numTargets @@ -314,7 +299,7 @@ runBenchmark b@Benchmark{ bTargets allAsyncs <- forM (zip [0..] $ NE.toList remoteAddresses) $ \(i, remoteAddr) -> launchTxPeer - p + m localAddr remoteAddr submission @@ -322,7 +307,7 @@ runBenchmark b@Benchmark{ bTargets tpsFeeder <- async $ tpsLimitedTxFeeder submission txs -- Wait for all threads to complete. mapM_ wait (tpsFeeder : allAsyncs) - traceWith (trTxSubmit p) =<< + traceWith (trTxSubmit m) =<< TraceBenchTxSubSummary <$> mkSubmissionSummary submission -- | At this moment 'sourceAddress' contains a huge amount of money (lets call it A). @@ -335,10 +320,10 @@ runBenchmark b@Benchmark{ bTargets -- | Work with tx generator thread (for Phase 2). ----------------------------------------------------------------------------------------- txGenerator - :: forall era - . EraSupportsTxGen era + :: forall mode era + . ConfigSupportsTxGen mode era => Benchmark - -> Era era + -> Mode mode era -> Address era -> SigningKeyOf era -> Int @@ -351,13 +336,13 @@ txGenerator Benchmark , bTxFanOut=NumberOfOutputsPerTx numOfOutsPerTx , bTxExtraPayload=txAdditionalSize } - p recipientAddress sourceKey numOfTargetNodes + m recipientAddress sourceKey numOfTargetNodes fundsWithSufficientCoins = do - liftIO . traceWith (trTxSubmit p) . TraceBenchTxSubDebug + liftIO . traceWith (trTxSubmit m) . TraceBenchTxSubDebug $ " Generating " ++ show numOfTransactions ++ " transactions, for " ++ show numOfTargetNodes ++ " peers" txs <- createMainTxs numOfTransactions numOfInsPerTx fundsWithSufficientCoins - liftIO . traceWith (trTxSubmit p) . TraceBenchTxSubDebug + liftIO . traceWith (trTxSubmit m) . TraceBenchTxSubDebug $ " Done, " ++ show numOfTransactions ++ " were generated." pure txs where @@ -384,7 +369,7 @@ txGenerator Benchmark (txInputs, updatedFunds) <- getTxInputs insNumPerTx funds let (_, _, _, txAux :: Tx era) = mkTransactionGen - p + m sourceKey (NE.fromList txInputs) (Just addressForChange) @@ -431,9 +416,9 @@ txGenerator Benchmark -- TODO: transform comments into haddocks. -- launchTxPeer - :: forall era - . EraSupportsTxGen era - => Era era + :: forall mode era + . ConfigSupportsTxGen mode era + => Mode mode era -> Maybe Network.Socket.AddrInfo -- local address binding (if wanted) -> Network.Socket.AddrInfo @@ -443,7 +428,7 @@ launchTxPeer -> Natural -- Thread index -> IO (Async ()) -launchTxPeer p localAddr remoteAddr ss ix = +launchTxPeer m localAddr remoteAddr ss ix = async $ - benchmarkConnectTxSubmit p localAddr remoteAddr - (txSubmissionClient p (trN2N p) (trTxSubmit p) ss ix) + benchmarkConnectTxSubmit m localAddr remoteAddr + (txSubmissionClient m (trN2N m) (trTxSubmit m) ss ix) diff --git a/cardano-tx-generator/src/Cardano/Benchmarking/GeneratorTx/CLI/Parsers.hs b/cardano-tx-generator/src/Cardano/Benchmarking/GeneratorTx/CLI/Parsers.hs index 0d524631..ad4b3fd7 100644 --- a/cardano-tx-generator/src/Cardano/Benchmarking/GeneratorTx/CLI/Parsers.hs +++ b/cardano-tx-generator/src/Cardano/Benchmarking/GeneratorTx/CLI/Parsers.hs @@ -5,11 +5,19 @@ where import Cardano.Prelude hiding (option) import Prelude (String) + +import Control.Monad (fail) +import qualified Data.Attoparsec.ByteString.Char8 as Atto +import qualified Data.ByteString.Char8 as BSC +import qualified Data.Char as Char +import qualified Data.Text.Encoding as Text +import qualified Data.Text as Text import Options.Applicative ( Parser , auto, bashCompleter, completer, flag, help , long, metavar, option, strOption ) +import qualified Options.Applicative as Opt import qualified Control.Arrow as Arr import Network.Socket (PortNumber) @@ -95,3 +103,74 @@ parseGenesisPath = <> metavar "FILEPATH" <> help "Path to the genesis yaml file." ) + +------------------------------------------------------------------ +-- Sadly the following isn't exported from: +-- module Cardano.CLI.Shelley.Parsers +pTxIn :: Parser TxIn +pTxIn = + Opt.option (readerFromAttoParser parseTxIn) + ( Opt.long "tx-in" + <> Opt.metavar "TX-IN" + <> Opt.help "The input transaction as TxId#TxIx where TxId is the transaction hash and TxIx is the index." + ) + +parseTxIn :: Atto.Parser TxIn +parseTxIn = TxIn <$> parseTxId <*> (Atto.char '#' *> parseTxIx) + +renderTxIn :: TxIn -> Text +renderTxIn (TxIn txid (TxIx txix)) = + mconcat + [ Text.decodeUtf8 (serialiseToRawBytesHex txid) + , "#" + , Text.pack (show txix) + ] + +parseTxId :: Atto.Parser TxId +parseTxId = do + bstr <- Atto.takeWhile1 Char.isHexDigit + case deserialiseFromRawBytesHex AsTxId bstr of + Just addr -> return addr + Nothing -> fail $ "Incorrect transaction id format:: " ++ show bstr + +parseTxIx :: Atto.Parser TxIx +parseTxIx = toEnum <$> Atto.decimal + +readerFromAttoParser :: Atto.Parser a -> Opt.ReadM a +readerFromAttoParser p = + Opt.eitherReader (Atto.parseOnly (p <* Atto.endOfInput) . BSC.pack) + +pTxOut :: Parser (TxOut Shelley) +pTxOut = + Opt.option (readerFromAttoParser parseTxOut) + ( Opt.long "tx-out" + <> Opt.metavar "TX-OUT" + <> Opt.help "The ouput transaction as Address+Lovelace where Address is \ + \the Bech32-encoded address followed by the amount in \ + \Lovelace." + ) + where + parseTxOut :: Atto.Parser (TxOut Shelley) + parseTxOut = + TxOut <$> parseAddress <* Atto.char '+' <*> parseLovelace + +parseLovelace :: Atto.Parser Lovelace +parseLovelace = Lovelace <$> Atto.decimal + +parseAddress :: Atto.Parser (Address Shelley) +parseAddress = do + str <- lexPlausibleAddressString + case deserialiseAddress AsShelleyAddress str of + Nothing -> fail "invalid address" + Just addr -> pure addr + +lexPlausibleAddressString :: Atto.Parser Text +lexPlausibleAddressString = + Text.decodeLatin1 <$> Atto.takeWhile1 isPlausibleAddressChar + where + -- Covers both base58 and bech32 (with constrained prefixes) + isPlausibleAddressChar c = + (c >= 'a' && c <= 'z') + || (c >= 'A' && c <= 'Z') + || (c >= '0' && c <= '9') + || c == '_' diff --git a/cardano-tx-generator/src/Cardano/Benchmarking/GeneratorTx/Era.hs b/cardano-tx-generator/src/Cardano/Benchmarking/GeneratorTx/Era.hs index d6572071..c54db2b4 100644 --- a/cardano-tx-generator/src/Cardano/Benchmarking/GeneratorTx/Era.hs +++ b/cardano-tx-generator/src/Cardano/Benchmarking/GeneratorTx/Era.hs @@ -23,19 +23,23 @@ module Cardano.Benchmarking.GeneratorTx.Era ( BlockOf - , BlockMode - , EraOfProtocol - , EraSupportsTxGen + , ModeOfProtocol + , ConfigSupportsTxGen , GenTxOf , GenTxIdOf , HFCBlockOf - , ModeOf + , inject + , project + , SomeMode(..) + , Mode(..) , SomeEra(..) , Era(..) + , ByronBlockHFC , ShelleyBlock , ShelleyBlockHFC , SigningKeyOf , SigningKeyRoleOf + , CardanoBlock , InitCooldown(..) , NumberOfInputsPerTx(..) @@ -55,15 +59,16 @@ module Cardano.Benchmarking.GeneratorTx.Era , SubmissionSummary(..) - , mkEra - , eraCodecConfig - , eraIOManager - , eraLedgerConfig - , eraLocalConnInfo - , eraNetworkId - , eraNetworkMagic - , eraTopLevelConfig - , eraTracers + , mkMode + , modeEra + , modeCodecConfig + , modeIOManager + , modeLedgerConfig + , modeLocalConnInfo + , modeNetworkId + , modeNetworkMagic + , modeTopLevelConfig + , modeTracers , trBase , trTxSubmit , trConnect @@ -79,8 +84,8 @@ module Cardano.Benchmarking.GeneratorTx.Era , createTracers ) where -import Prelude (String, error) -import Cardano.Prelude hiding (TypeError) +import Prelude (Show(..), String, error) +import Cardano.Prelude hiding (TypeError, show) import qualified Codec.CBOR.Term as CBOR import Control.Tracer (Tracer (..), nullTracer, traceWith) @@ -94,11 +99,11 @@ import Data.Time.Clock (DiffTime, getCurrentTime) import GHC.TypeLits import qualified GHC.TypeLits as Ty --- Era-agnostic imports +-- Mode-agnostic imports import Cardano.BM.Data.Tracer (emptyObject, mkObject, trStructured) import Network.Mux (WithMuxBearer(..)) -import Ouroboros.Consensus.Block.Abstract (CodecConfig, SlotNo(..)) +import Ouroboros.Consensus.Block.Abstract (CodecConfig) import qualified Ouroboros.Consensus.Cardano as Consensus import Ouroboros.Consensus.Config ( SecurityParam(..), TopLevelConfig(..) @@ -134,7 +139,7 @@ import Cardano.Api.TxSubmit import qualified Cardano.Api.Typed as Api -- Node imports -import Cardano.Config.Types (NodeAddress, SocketPath(..)) +import Cardano.Config.Types (SocketPath(..)) import Cardano.Node.Logging (LOContent(..), LoggingLayer (..)) import Cardano.TracingOrphanInstances.Byron() import Cardano.TracingOrphanInstances.Common() @@ -148,17 +153,24 @@ import Cardano.Benchmarking.GeneratorTx.Benchmark {------------------------------------------------------------------------------- Era abstraction -------------------------------------------------------------------------------} -type EraSupportsTxGen era - = ( Ord (TxOut era) - , Eq (Address era) - , Key (SigningKeyRoleOf era) - , Mempool.HasTxId (GenTx (BlockOf era)) - , RunNode (BlockOf era) - , Show (Tx era) - , Show (TxOut era) - , Show (TxSubmitResultForMode (ModeOf era)) - , BenchTraceConstraints (BlockOf era) - ) + +type ModeSupportsTxGen mode = + ( BenchTraceConstraints (BlockOf mode) + , Mempool.HasTxId (GenTx (HFCBlockOf mode)) + , Mempool.LedgerSupportsMempool (HFCBlockOf mode) + , Show (TxSubmitResultForMode mode) + , Show (TxForMode mode) + , RunNode (HFCBlockOf mode)) + +type EraSupportsTxGen era = + ( Eq (Address era) + , Key (SigningKeyRoleOf era) + , Ord (TxOut era) + , Show (Tx era) + , Show (TxOut era)) + +type ConfigSupportsTxGen mode era = + (ModeSupportsTxGen mode, EraSupportsTxGen era) deriving instance Eq (Address era) => Ord (Address era) @@ -173,29 +185,21 @@ instance ToJSON TxIx where deriving instance Eq (Address era) => (Eq (TxOut era)) deriving instance Eq (Address era) => (Ord (TxOut era)) - -type family EraOfProtocol p :: Type where - EraOfProtocol Consensus.ProtocolByron = Byron - EraOfProtocol Consensus.ProtocolShelley = Shelley - EraOfProtocol t = TypeError (Ty.Text "Unsupported trotocol: " :<>: ShowType t) - -type family ModeOf era :: Type where - ModeOf Byron = ByronMode - ModeOf Shelley = ShelleyMode - ModeOf t = TypeError (Ty.Text "Unsupported era: " :<>: ShowType t) - type ShelleyBlock = Shelley.ShelleyBlock TPraosStandardCrypto type ShelleyBlockHFC = Shelley.ShelleyBlockHFC TPraosStandardCrypto +type CardanoBlock = Consensus.CardanoBlock TPraosStandardCrypto -type family BlockOf era :: Type where - BlockOf Byron = ByronBlock - BlockOf Shelley = ShelleyBlock - BlockOf t = TypeError (Ty.Text "Unsupported era: " :<>: ShowType t) +type family BlockOf mode :: Type where + BlockOf ByronMode = ByronBlock + BlockOf ShelleyMode = ShelleyBlock + BlockOf CardanoMode = CardanoBlock + BlockOf t = TypeError (Ty.Text "Unsupported mode: " :<>: ShowType t) -type family HFCBlockOf era :: Type where - HFCBlockOf Byron = ByronBlockHFC - HFCBlockOf Shelley = HardForkBlock '[ShelleyBlock] - HFCBlockOf t = TypeError (Ty.Text "Unsupported era: " :<>: ShowType t) +type family HFCBlockOf mode :: Type where + HFCBlockOf ByronMode = ByronBlockHFC + HFCBlockOf ShelleyMode = ShelleyBlockHFC + HFCBlockOf CardanoMode = CardanoBlock + HFCBlockOf t = TypeError (Ty.Text "Unsupported mode: " :<>: ShowType t) type family SigningKeyRoleOf era :: Type where SigningKeyRoleOf Byron = ByronKey @@ -204,128 +208,204 @@ type family SigningKeyRoleOf era :: Type where type SigningKeyOf era = SigningKey (SigningKeyRoleOf era) -type GenTxOf era = GenTx (BlockOf era) -type GenTxIdOf era = GenTxId (BlockOf era) +type GenTxOf mode = GenTx (HFCBlockOf mode) +type GenTxIdOf mode = GenTxId (HFCBlockOf mode) -type family BlockMode blk :: Type where - BlockMode ByronBlock = ByronMode - BlockMode ShelleyBlock = ShelleyMode - BlockMode t = TypeError (Ty.Text "Unsupported block type: " :<>: ShowType t) +type family ModeOfProtocol p :: Type where + ModeOfProtocol Consensus.ProtocolByron = ByronMode + ModeOfProtocol Consensus.ProtocolShelley = ShelleyMode + ModeOfProtocol (HardForkProtocol '[ByronBlock, ShelleyBlock]) = CardanoMode + ModeOfProtocol t = TypeError (Ty.Text "Unsupported protocol: " :<>: ShowType t) -data SomeEra = - forall era. EraSupportsTxGen era => - SomeEra (Era era) +data SomeMode = + forall mode era. ConfigSupportsTxGen mode era => + SomeMode (Mode mode era) -- | System-level submission context (not parameters) -- TODO: rename the type to SubContext or something similar. -data Era era where - EraByron - :: TopLevelConfig (BlockOf Byron) - -> CodecConfig (BlockOf Byron) - -> LocalNodeConnectInfo ByronMode (HFCBlockOf Byron) +data Mode mode era where + ModeByron + :: TopLevelConfig (HFCBlockOf ByronMode) + -> CodecConfig (HFCBlockOf ByronMode) + -> LocalNodeConnectInfo ByronMode (HFCBlockOf ByronMode) + -> IOManager + -> BenchTracers IO (HFCBlockOf ByronMode) + -> Mode ByronMode Byron + ModeShelley + :: TopLevelConfig (HFCBlockOf ShelleyMode) + -> CodecConfig (HFCBlockOf ShelleyMode) + -> LocalNodeConnectInfo ShelleyMode (HFCBlockOf ShelleyMode) -> IOManager - -> BenchTracers IO (BlockOf Byron) - -> Era Byron - EraShelley - :: TopLevelConfig (BlockOf Shelley) - -> CodecConfig (BlockOf Shelley) - -> LocalNodeConnectInfo ShelleyMode (HFCBlockOf Shelley) + -> BenchTracers IO (HFCBlockOf ShelleyMode) + -> Mode ShelleyMode Shelley + ModeCardanoByron + :: TopLevelConfig (HFCBlockOf CardanoMode) + -> CodecConfig (HFCBlockOf CardanoMode) + -> LocalNodeConnectInfo CardanoMode (HFCBlockOf CardanoMode) -> IOManager - -> BenchTracers IO (BlockOf Shelley) - -> Era Shelley + -> BenchTracers IO (HFCBlockOf CardanoMode) + -> Mode CardanoMode Byron + ModeCardanoShelley + :: TopLevelConfig (HFCBlockOf CardanoMode) + -> CodecConfig (HFCBlockOf CardanoMode) + -> LocalNodeConnectInfo CardanoMode (HFCBlockOf CardanoMode) + -> IOManager + -> BenchTracers IO (HFCBlockOf CardanoMode) + -> Mode CardanoMode Shelley + +instance Show (Mode mode era) where + show ModeByron{} = "ModeByron" + show ModeShelley{} = "ModeShelley" + show ModeCardanoByron{} = "ModeCardanoByron" + show ModeCardanoShelley{} = "ModeCardanoShelley" + +data SomeEra = forall era. EraSupportsTxGen era => SomeEra (Era era) + +data Era era where + EraByron :: Era Byron + EraShelley :: Era Shelley -mkEra - :: forall blok era ptcl - . era ~ EraOfProtocol ptcl +instance Show (Era era) where + show EraByron = "EraByron" + show EraShelley = "EraShelley" + +mkMode + :: forall blok era mode ptcl + . ( mode ~ ModeOfProtocol ptcl + ) => Consensus.Protocol IO blok ptcl + -> Era era -> IOManager -> SocketPath -> LoggingLayer - -> Era (EraOfProtocol ptcl) -mkEra ptcl@Consensus.ProtocolByron{} iom (SocketPath sock) ll = - EraByron - (project pInfoConfig) - (configCodec $ project pInfoConfig) + -> Mode mode era +mkMode ptcl@Consensus.ProtocolByron{} EraByron iom (SocketPath sock) ll = + ModeByron + pInfoConfig + (configCodec pInfoConfig) (LocalNodeConnectInfo sock - (Api.Testnet . getNetworkMagic . configBlock $ project pInfoConfig) + (Api.Testnet . getNetworkMagic . configBlock $ pInfoConfig) (ByronMode (Byron.EpochSlots 21600) (SecurityParam 2160))) iom (createTracers ll) where ProtocolInfo{pInfoConfig} = Consensus.protocolInfo ptcl -mkEra ptcl@Consensus.ProtocolShelley{} iom (SocketPath sock) ll = - EraShelley - (project pInfoConfig) - (configCodec $ project pInfoConfig) +mkMode ptcl@Consensus.ProtocolShelley{} EraShelley iom (SocketPath sock) ll = + ModeShelley + pInfoConfig + (configCodec pInfoConfig) (LocalNodeConnectInfo sock - (Api.Testnet . getNetworkMagic . configBlock $ project pInfoConfig) + (Api.Testnet . getNetworkMagic . configBlock $ pInfoConfig) ShelleyMode) iom (createTracers ll) where ProtocolInfo{pInfoConfig} = Consensus.protocolInfo ptcl -mkEra _ _ _ _ = error "mkEra: unhandled protocol" - -eraTopLevelConfig :: Era era -> TopLevelConfig (BlockOf era) -eraTopLevelConfig (EraByron x _ _ _ _) = x -eraTopLevelConfig (EraShelley x _ _ _ _) = x - -eraCodecConfig :: Era era -> CodecConfig (BlockOf era) -eraCodecConfig (EraByron _ x _ _ _) = x -eraCodecConfig (EraShelley _ x _ _ _) = x - -eraLocalConnInfo :: Era era -> LocalNodeConnectInfo (ModeOf era) (HFCBlockOf era) -eraLocalConnInfo (EraByron _ _ x _ _) = x -eraLocalConnInfo (EraShelley _ _ x _ _) = x - -eraIOManager :: Era era -> IOManager -eraIOManager (EraByron _ _ _ x _) = x -eraIOManager (EraShelley _ _ _ x _) = x - -eraTracers :: Era era -> BenchTracers IO (BlockOf era) -eraTracers (EraByron _ _ _ _ x) = x -eraTracers (EraShelley _ _ _ _ x) = x - -eraNetworkId :: Era era -> NetworkId -eraNetworkId p@EraByron{} = Testnet . getNetworkMagic . configBlock $ eraTopLevelConfig p -eraNetworkId p@EraShelley{} = Testnet . getNetworkMagic . configBlock $ eraTopLevelConfig p - -eraNetworkMagic :: Era era -> NetworkMagic -eraNetworkMagic p@EraByron{} = getNetworkMagic . configBlock $ eraTopLevelConfig p -eraNetworkMagic p@EraShelley{} = getNetworkMagic . configBlock $ eraTopLevelConfig p - -eraLedgerConfig :: Era era -> LedgerConfig (BlockOf era) -eraLedgerConfig = configLedger . eraTopLevelConfig - -trBase :: Era era -> Trace IO Text -trTxSubmit :: Era era -> Tracer IO (TraceBenchTxSubmit TxId) -trConnect :: Era era -> Tracer IO SendRecvConnect -trSubmitMux :: Era era -> Tracer IO (SendRecvTxSubmission (BlockOf era)) -trLowLevel :: Era era -> Tracer IO TraceLowLevelSubmit -trN2N :: Era era -> Tracer IO NodeToNodeSubmissionTrace -trBase = btBase_ . eraTracers -trTxSubmit = btTxSubmit_ . eraTracers -trConnect = btConnect_ . eraTracers -trSubmitMux = btSubmission_ . eraTracers -trLowLevel = btLowLevel_ . eraTracers -trN2N = btN2N_ . eraTracers - -data Benchmark - = Benchmark - { bTargets :: !(NonEmpty NodeAddress) - , bInitCooldown :: !InitCooldown - , bInitialTTL :: !SlotNo - , bTxCount :: !NumberOfTxs - , bTps :: !TPSRate - , bTxFanIn :: !NumberOfInputsPerTx - , bTxFanOut :: !NumberOfOutputsPerTx - , bTxFee :: !Lovelace - , bTxExtraPayload :: !TxAdditionalSize - } - deriving (Generic, Show) --- Warning: make sure to maintain correspondence between the two data structures. +mkMode ptcl@Consensus.ProtocolCardano{} EraByron iom (SocketPath sock) ll = + ModeCardanoByron + pInfoConfig + (configCodec pInfoConfig) + (LocalNodeConnectInfo + sock + (Api.Testnet . getNetworkMagic . configBlock $ pInfoConfig) + (CardanoMode (Byron.EpochSlots 21600) (SecurityParam 2160))) + iom + (createTracers ll) + where + ProtocolInfo{pInfoConfig} = Consensus.protocolInfo ptcl +mkMode ptcl@Consensus.ProtocolCardano{} EraShelley iom (SocketPath sock) ll = + ModeCardanoShelley + pInfoConfig + (configCodec pInfoConfig) + (LocalNodeConnectInfo + sock + (Api.Testnet . getNetworkMagic . configBlock $ pInfoConfig) + (CardanoMode (Byron.EpochSlots 21600) (SecurityParam 2160))) + iom + (createTracers ll) + where + ProtocolInfo{pInfoConfig} = Consensus.protocolInfo ptcl +mkMode p e _ _ _ = error $ "mkMode: unhandled protocol/era: " <> show p <> " / " <> show e + +instance Show (Consensus.Protocol m blk p) where + show Consensus.ProtocolByron{} = "ProtocolByron" + show Consensus.ProtocolShelley{} = "ProtocolShelley" + show Consensus.ProtocolCardano{} = "ProtocolCardano" + show Consensus.ProtocolMockBFT{} = "ProtocolMockBFT" + show Consensus.ProtocolMockPBFT{} = "ProtocolMockPBFT" + show Consensus.ProtocolMockPraos{} = "ProtocolMockPraos" + show Consensus.ProtocolLeaderSchedule{} = "ProtocolLeaderSchedule" + +modeEra :: Mode mode era -> Era era +modeEra = \case + ModeByron{} -> EraByron + ModeShelley{} -> EraShelley + ModeCardanoByron{} -> EraByron + ModeCardanoShelley{} -> EraShelley + +modeTopLevelConfig :: Mode mode era -> TopLevelConfig (HFCBlockOf mode) +modeTopLevelConfig (ModeByron x _ _ _ _) = x +modeTopLevelConfig (ModeShelley x _ _ _ _) = x +modeTopLevelConfig (ModeCardanoByron x _ _ _ _) = x +modeTopLevelConfig (ModeCardanoShelley x _ _ _ _) = x + +modeCodecConfig :: Mode mode era -> CodecConfig (HFCBlockOf mode) +modeCodecConfig (ModeByron _ x _ _ _) = x +modeCodecConfig (ModeShelley _ x _ _ _) = x +modeCodecConfig (ModeCardanoByron _ x _ _ _) = x +modeCodecConfig (ModeCardanoShelley _ x _ _ _) = x + +modeLocalConnInfo :: Mode mode era -> LocalNodeConnectInfo mode (HFCBlockOf mode) +modeLocalConnInfo (ModeByron _ _ x _ _) = x +modeLocalConnInfo (ModeShelley _ _ x _ _) = x +modeLocalConnInfo (ModeCardanoByron _ _ x _ _) = x +modeLocalConnInfo (ModeCardanoShelley _ _ x _ _) = x + +modeIOManager :: Mode mode era -> IOManager +modeIOManager (ModeByron _ _ _ x _) = x +modeIOManager (ModeShelley _ _ _ x _) = x +modeIOManager (ModeCardanoByron _ _ _ x _) = x +modeIOManager (ModeCardanoShelley _ _ _ x _) = x + +modeTracers :: Mode mode era -> BenchTracers IO (HFCBlockOf mode) +modeTracers (ModeByron _ _ _ _ x) = x +modeTracers (ModeShelley _ _ _ _ x) = x +modeTracers (ModeCardanoByron _ _ _ _ x) = x +modeTracers (ModeCardanoShelley _ _ _ _ x) = x + +modeNetworkId :: Mode mode era -> NetworkId +modeNetworkId m@ModeByron{} = Testnet . getNetworkMagic . configBlock $ modeTopLevelConfig m +modeNetworkId m@ModeShelley{} = Testnet . getNetworkMagic . configBlock $ modeTopLevelConfig m +modeNetworkId m@ModeCardanoByron{} = Testnet . getNetworkMagic . configBlock $ modeTopLevelConfig m +modeNetworkId m@ModeCardanoShelley{} = Testnet . getNetworkMagic . configBlock $ modeTopLevelConfig m + +modeNetworkMagic :: Mode mode era -> NetworkMagic +modeNetworkMagic m@ModeByron{} = getNetworkMagic . configBlock $ modeTopLevelConfig m +modeNetworkMagic m@ModeShelley{} = getNetworkMagic . configBlock $ modeTopLevelConfig m +modeNetworkMagic m@ModeCardanoByron{} = getNetworkMagic . configBlock $ modeTopLevelConfig m +modeNetworkMagic m@ModeCardanoShelley{} = getNetworkMagic . configBlock $ modeTopLevelConfig m + +modeLedgerConfig :: Mode mode era -> LedgerConfig (BlockOf mode) +modeLedgerConfig m@ModeByron{} = configLedger . project $ modeTopLevelConfig m +modeLedgerConfig m@ModeShelley{} = configLedger . project $ modeTopLevelConfig m +modeLedgerConfig _ = error "Ledger config query not supported in Cardano mode." +-- modeLedgerConfig m@ModeCardanoByron{} = configLedger . project $ modeTopLevelConfig m +-- modeLedgerConfig m@ModeCardanoShelley{} = configLedger . project $ modeTopLevelConfig m + +trBase :: Mode mode era -> Trace IO Text +trTxSubmit :: Mode mode era -> Tracer IO (TraceBenchTxSubmit TxId) +trConnect :: Mode mode era -> Tracer IO SendRecvConnect +trSubmitMux :: Mode mode era -> Tracer IO (SendRecvTxSubmission (HFCBlockOf mode)) +trLowLevel :: Mode mode era -> Tracer IO TraceLowLevelSubmit +trN2N :: Mode mode era -> Tracer IO NodeToNodeSubmissionTrace +trBase = btBase_ . modeTracers +trTxSubmit = btTxSubmit_ . modeTracers +trConnect = btConnect_ . modeTracers +trSubmitMux = btSubmission_ . modeTracers +trLowLevel = btLowLevel_ . modeTracers +trN2N = btN2N_ . modeTracers {------------------------------------------------------------------------------- Tracers diff --git a/cardano-tx-generator/src/Cardano/Benchmarking/GeneratorTx/Genesis.hs b/cardano-tx-generator/src/Cardano/Benchmarking/GeneratorTx/Genesis.hs index 18e644fb..4fd0080b 100644 --- a/cardano-tx-generator/src/Cardano/Benchmarking/GeneratorTx/Genesis.hs +++ b/cardano-tx-generator/src/Cardano/Benchmarking/GeneratorTx/Genesis.hs @@ -5,6 +5,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralisedNewtypeDeriving #-} {-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedLabels #-} @@ -16,7 +17,9 @@ {-# OPTIONS_GHC -Wno-all-missed-specialisations #-} module Cardano.Benchmarking.GeneratorTx.Genesis - ( extractGenesisFunds + ( GeneratorFunds(..) + , parseGeneratorFunds + , extractGenesisFunds , genesisExpenditure , keyAddress ) @@ -27,90 +30,121 @@ import Cardano.Prelude hiding (TypeError) import Control.Arrow ((***)) import qualified Data.Map.Strict as Map +import qualified Options.Applicative as Opt -- Era-agnostic imports +import Cardano.Config.Types + (SigningKeyFile(..)) import qualified Ouroboros.Consensus.Cardano as Consensus -- Byron-specific imports import qualified Cardano.Chain.Common as Byron -import qualified Cardano.Chain.UTxO as Byron +import qualified Cardano.Chain.UTxO as Byron -- Shelley-specific imports -import qualified Ouroboros.Consensus.Shelley.Ledger.Ledger as Shelley +import qualified Ouroboros.Consensus.Shelley.Ledger as Shelley +-- Local imports import Cardano.Api.Typed import Cardano.Benchmarking.GeneratorTx.Era import Cardano.Benchmarking.GeneratorTx.Tx import Cardano.Benchmarking.GeneratorTx.Tx.Byron +import Cardano.Benchmarking.GeneratorTx.CLI.Parsers -keyAddress :: Era era -> SigningKeyOf era -> Address era -keyAddress p@EraByron{} (getVerificationKey -> ByronVerificationKey k) = - ByronAddress $ Byron.makeVerKeyAddress (toByronNetworkMagic $ eraNetworkId p) k -keyAddress p@EraShelley{} k = - makeShelleyAddress - (eraNetworkId p) - (PaymentCredentialByKey $ verificationKeyHash $ getVerificationKey k) - NoStakeAddress +data GeneratorFunds + = FundsGenesis SigningKeyFile + | FundsUtxo SigningKeyFile TxIn (TxOut Shelley) + deriving Show -genesisKeyPseudoTxIn :: Era era -> SigningKeyOf era -> Address era -> TxIn -genesisKeyPseudoTxIn p@EraShelley{} key _ = +parseGeneratorFunds :: Opt.Parser GeneratorFunds +parseGeneratorFunds = + (FundsGenesis + <$> parseSigningKeysFile + "genesis-funds-key" + "Genesis UTxO funds signing key.") + <|> + (FundsUtxo + <$> parseSigningKeysFile + "utxo-funds-key" + "UTxO funds signing key." + <*> pTxIn + <*> pTxOut) + +keyAddress :: Mode mode era -> SigningKeyOf era -> Address era +keyAddress m = case modeEra m of + EraByron{} -> \(getVerificationKey -> ByronVerificationKey k) -> + ByronAddress + (Byron.makeVerKeyAddress (toByronNetworkMagic $ modeNetworkId m) k) + EraShelley{} -> \k -> + makeShelleyAddress + (modeNetworkId m) + (PaymentCredentialByKey $ verificationKeyHash $ getVerificationKey k) + NoStakeAddress + +genesisKeyPseudoTxIn :: Mode mode era -> SigningKeyOf era -> Address era -> TxIn +genesisKeyPseudoTxIn m@ModeShelley{} key _ = genesisUTxOPseudoTxIn - (eraNetworkId p) + (modeNetworkId m) (verificationKeyHash $ getVerificationKey $ castSigningKeyRolePaymentKeyGenesisUTxOKey key) where castSigningKeyRolePaymentKeyGenesisUTxOKey :: SigningKey PaymentKey -> SigningKey GenesisUTxOKey castSigningKeyRolePaymentKeyGenesisUTxOKey (PaymentSigningKey skey) = GenesisUTxOSigningKey skey -genesisKeyPseudoTxIn p@EraByron{} +genesisKeyPseudoTxIn m@ModeByron{} (getVerificationKey -> ByronVerificationKey key) (ByronAddress genAddr) = - fromByronTxIn $ byronGenesisUTxOTxIn (eraLedgerConfig p) key genAddr + fromByronTxIn $ byronGenesisUTxOTxIn (modeLedgerConfig m) key genAddr +genesisKeyPseudoTxIn m _ _ = + error $ "genesisKeyPseudoTxIn: unsupported mode: " <> show m -eraGenesisFunds :: Era era +modeGenesisFunds :: Mode mode era -> [(Address era, Lovelace)] -eraGenesisFunds p@EraShelley{} = +modeGenesisFunds = \case + m@ModeShelley{} -> fmap (fromShelleyAddr *** fromShelleyLovelace) - . Map.toList - . Consensus.sgInitialFunds - . Shelley.shelleyLedgerGenesis - $ eraLedgerConfig p -eraGenesisFunds p@EraByron{} = + . Map.toList + . Consensus.sgInitialFunds + . Shelley.shelleyLedgerGenesis + $ modeLedgerConfig m + m@ModeByron{} -> fmap (\(TxOut addr coin) -> (addr, coin)) - . map (fromByronTxOut . Byron.fromCompactTxOut . snd) - . Map.toList - . Byron.unUTxO - . Byron.genesisUtxo - $ eraLedgerConfig p + . map (fromByronTxOut . Byron.fromCompactTxOut . snd) + . Map.toList + . Byron.unUTxO + . Byron.genesisUtxo + $ modeLedgerConfig m + m -> error $ "modeGenesisFunds: unsupported mode: " <> show m extractGenesisFunds - :: forall era + :: forall mode era . Eq (Address era) - => Era era + => Mode mode era -> SigningKeyOf era -> (TxIn, TxOut era) -extractGenesisFunds p k = +extractGenesisFunds m k = fromMaybe (error "No genesis funds for signing key.") . head . filter (isTxOutForKey . snd) . fmap genesisFundsEntryTxIO - . eraGenesisFunds - $ p + . modeGenesisFunds + $ m where genesisFundsEntryTxIO :: (Address era, Lovelace) -> (TxIn, TxOut era) genesisFundsEntryTxIO (addr, coin) = - (genesisKeyPseudoTxIn p k addr, TxOut addr coin) + (genesisKeyPseudoTxIn m k addr, TxOut addr coin) isTxOutForKey :: TxOut era -> Bool - isTxOutForKey (TxOut addr _) = keyAddress p k == addr + isTxOutForKey (TxOut addr _) = keyAddress m k == addr -genesisExpenditure :: Era era -> SigningKeyOf era -> Address era -> Lovelace -> TxFee -> TTL -> (Tx era, TxIn, TxOut era) -genesisExpenditure p key addr (Lovelace coin) (Lovelace fee) ttl = +genesisExpenditure :: Mode mode era -> SigningKeyOf era -> Address era -> Lovelace -> TxFee -> TTL -> (Tx era, TxIn, TxOut era) +genesisExpenditure m key addr (Lovelace coin) (Lovelace fee) ttl = (,,) tx txin txout where - tx = mkTransaction p key 0 ttl (Lovelace fee) - [genesisKeyPseudoTxIn p key (keyAddress p key)] + tx = mkTransaction m key 0 ttl (Lovelace fee) + [genesisKeyPseudoTxIn m key (keyAddress m key)] [txout] txin = TxIn (getTxId $ getTxBody tx) (TxIx 0) txout = TxOut addr (Lovelace (coin - fee)) + diff --git a/cardano-tx-generator/src/Cardano/Benchmarking/GeneratorTx/NodeToNode.hs b/cardano-tx-generator/src/Cardano/Benchmarking/GeneratorTx/NodeToNode.hs index 42170d49..9c578ff8 100644 --- a/cardano-tx-generator/src/Cardano/Benchmarking/GeneratorTx/NodeToNode.hs +++ b/cardano-tx-generator/src/Cardano/Benchmarking/GeneratorTx/NodeToNode.hs @@ -2,6 +2,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} @@ -47,8 +48,8 @@ import Cardano.Benchmarking.GeneratorTx.Era benchmarkConnectTxSubmit - :: forall m era blk. (blk ~ BlockOf era, RunNode blk, m ~ IO) - => Era era + :: forall m mode era blk. (blk ~ HFCBlockOf mode, RunNode blk, m ~ IO) + => Mode mode era -> Maybe AddrInfo -- ^ local address information (typically local interface/port to use) -> AddrInfo @@ -58,7 +59,7 @@ benchmarkConnectTxSubmit -> m () benchmarkConnectTxSubmit p localAddr remoteAddr myTxSubClient = NtN.connectTo - (socketSnocket $ eraIOManager p) + (socketSnocket $ modeIOManager p) NetworkConnectTracers { nctMuxTracer = nullTracer, nctHandshakeTracer = trConnect p @@ -67,21 +68,27 @@ benchmarkConnectTxSubmit p localAddr remoteAddr myTxSubClient = (addrAddress <$> localAddr) (addrAddress remoteAddr) where + modeVer :: Mode mode era -> NodeToNodeVersion + modeVer = \case + ModeCardanoByron{} -> NodeToNodeV_2 + ModeCardanoShelley{} -> NodeToNodeV_2 + ModeByron{} -> NodeToNodeV_1 + ModeShelley{} -> NodeToNodeV_1 n2nVer :: NodeToNodeVersion - n2nVer = NodeToNodeV_1 + n2nVer = modeVer p blkN2nVer :: BlockNodeToNodeVersion blk blkN2nVer = supportedVers Map.! n2nVer supportedVers :: Map.Map NodeToNodeVersion (BlockNodeToNodeVersion blk) supportedVers = supportedNodeToNodeVersions (Proxy @blk) myCodecs :: Codecs blk DeserialiseFailure m ByteString ByteString ByteString ByteString ByteString ByteString - myCodecs = defaultCodecs (eraCodecConfig p) blkN2nVer + myCodecs = defaultCodecs (modeCodecConfig p) blkN2nVer peerMultiplex :: Versions NtN.NodeToNodeVersion NtN.DictVersion (OuroborosApplication InitiatorMode SockAddr ByteString IO () Void) peerMultiplex = simpleSingletonVersions - NtN.NodeToNodeV_1 - (NtN.NodeToNodeVersionData { NtN.networkMagic = eraNetworkMagic p}) + n2nVer + (NtN.NodeToNodeVersionData { NtN.networkMagic = modeNetworkMagic p}) (NtN.DictVersion NtN.nodeToNodeCodecCBORTerm) $ NtN.nodeToNodeProtocols NtN.defaultMiniProtocolParameters $ \them _ -> NtN.NodeToNodeProtocols diff --git a/cardano-tx-generator/src/Cardano/Benchmarking/GeneratorTx/Submission.hs b/cardano-tx-generator/src/Cardano/Benchmarking/GeneratorTx/Submission.hs index ce274968..b907ac8b 100644 --- a/cardano-tx-generator/src/Cardano/Benchmarking/GeneratorTx/Submission.hs +++ b/cardano-tx-generator/src/Cardano/Benchmarking/GeneratorTx/Submission.hs @@ -213,15 +213,15 @@ consumeTxs Submission{sTxSendQueue} req The submission client -------------------------------------------------------------------------------} txSubmissionClient - :: forall m era tx txid gentx gentxid . + :: forall m mode era tx txid gentx gentxid . ( MonadIO m - , EraSupportsTxGen era + , ConfigSupportsTxGen mode era , tx ~ Tx era , txid ~ TxId - , gentx ~ GenTxOf era - , gentxid ~ GenTxIdOf era + , gentx ~ GenTxOf mode + , gentxid ~ GenTxIdOf mode ) - => Era era + => Mode mode era -> Tracer m NodeToNodeSubmissionTrace -> Tracer m (TraceBenchTxSubmit txid) -> Submission m era @@ -229,7 +229,7 @@ txSubmissionClient -- This return type is forced by Ouroboros.Network.NodeToNode.connectTo -> TxSubmissionClient gentxid gentx m () txSubmissionClient - p tr bmtr + m tr bmtr sub@Submission{sReportsRefs} threadIx = TxSubmissionClient $ @@ -287,15 +287,15 @@ txSubmissionClient (Just neAnnNow, TokBlocking) -> pure $ SendMsgReplyTxIds - (BlockingReply $ txToIdSizify <$> neAnnNow) + (BlockingReply $ txToIdSize <$> neAnnNow) (client exhausted newUnacked newStats) (_, TokNonBlocking) -> pure $ SendMsgReplyTxIds - (NonBlockingReply $ txToIdSizify <$> annNow) + (NonBlockingReply $ txToIdSize <$> annNow) (client exhausted newUnacked newStats) - , recvMsgRequestTxs = \(fmap (fromGenTxId p) -> reqTxids) -> do + , recvMsgRequestTxs = \(fmap (fromGenTxId m) -> reqTxids) -> do traceWith tr $ ReqTxs (length reqTxids) let UnAcked ua = unAcked uaIds = getTxId . getTxBody <$> ua @@ -307,7 +307,7 @@ txSubmissionClient traceWith bmtr $ TraceBenchTxSubServOuts (getTxId . getTxBody <$> ua) unless (L.null missIds) $ traceWith bmtr $ TraceBenchTxSubServUnav missIds - pure $ SendMsgReplyTxs (toGenTx <$> toSend) + pure $ SendMsgReplyTxs (toGenTx m <$> toSend) (client done unAcked $ stats { stsSent = stsSent stats + Sent (length toSend) @@ -326,8 +326,8 @@ txSubmissionClient liftIO . STM.atomically $ STM.putTMVar (sReportsRefs L.!! fromIntegral threadIx) report pure report - txToIdSizify :: tx -> (gentxid, TxSizeInBytes) - txToIdSizify = (Mempool.txId &&& txInBlockSize) . toGenTx + txToIdSize :: tx -> (gentxid, TxSizeInBytes) + txToIdSize = (Mempool.txId &&& txInBlockSize) . toGenTx m protoToAck :: Word16 -> Ack protoToAck = Ack . fromIntegral diff --git a/cardano-tx-generator/src/Cardano/Benchmarking/GeneratorTx/Tx.hs b/cardano-tx-generator/src/Cardano/Benchmarking/GeneratorTx/Tx.hs index 0bd6e977..7b8e3f93 100644 --- a/cardano-tx-generator/src/Cardano/Benchmarking/GeneratorTx/Tx.hs +++ b/cardano-tx-generator/src/Cardano/Benchmarking/GeneratorTx/Tx.hs @@ -11,7 +11,9 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-all-missed-specialisations #-} module Cardano.Benchmarking.GeneratorTx.Tx @@ -38,12 +40,20 @@ import qualified Data.ByteString.Lazy as LB import qualified Data.Map.Strict as Map import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Text as T +-- import Generics.SOP (K(..), I(..), hcollapse, hmap) -- Era-agnostic imports import Cardano.Binary (Annotated(..), reAnnotate) import qualified Cardano.Crypto.Hash.Class as Crypto import Ouroboros.Consensus.Block.Abstract (SlotNo(..)) +-- import Ouroboros.Consensus.HardFork.Combinator as HFC +-- (OneEraGenTxId(..)) +import qualified Ouroboros.Consensus.HardFork.Combinator.Unary as HFC import Ouroboros.Consensus.Ledger.SupportsMempool hiding (TxId) +import Ouroboros.Consensus.TypeFamilyWrappers + +-- Cardano-specific imports +import Ouroboros.Consensus.Cardano.Block hiding (TxId) -- Byron-specific imports import qualified Cardano.Chain.Common as Byron @@ -64,18 +74,30 @@ import Cardano.Benchmarking.GeneratorTx.Era import Cardano.Benchmarking.GeneratorTx.Tx.Byron -castTxMode :: Tx era -> TxForMode (ModeOf era) -castTxMode tx@ByronTx{} = TxForByronMode tx -castTxMode tx@ShelleyTx{} = TxForShelleyMode tx +castTxMode :: Mode mode era -> Tx era -> TxForMode mode +castTxMode ModeByron{} tx@ByronTx{} = TxForByronMode tx +castTxMode ModeShelley{} tx@ShelleyTx{} = TxForShelleyMode tx +castTxMode ModeCardanoByron{} tx@ByronTx{} = TxForCardanoMode $ Left tx +castTxMode ModeCardanoShelley{} tx@ShelleyTx{} = TxForCardanoMode $ Right tx + +toGenTx :: Mode mode era -> Tx era -> GenTx (HFCBlockOf mode) +toGenTx ModeShelley{} (ShelleyTx tx) = inject $ Shelley.mkShelleyTx tx +toGenTx ModeByron{} (ByronTx tx) = inject $ normalByronTxToGenTx tx +toGenTx ModeCardanoShelley{} (ShelleyTx tx) = GenTxShelley $ Shelley.mkShelleyTx tx +toGenTx ModeCardanoByron{} (ByronTx tx) = GenTxByron $ normalByronTxToGenTx tx -toGenTx :: Tx era -> GenTx (BlockOf era) -toGenTx (ShelleyTx tx) = Shelley.mkShelleyTx tx -toGenTx (ByronTx tx) = normalByronTxToGenTx tx +shelleyTxId :: GenTxId (BlockOf ShelleyMode) -> TxId +shelleyTxId (Shelley.ShelleyTxId (ShelleyLedger.TxId i)) = TxId (Crypto.castHash i) -fromGenTxId :: Era era -> GenTxId (BlockOf era) -> TxId -fromGenTxId EraShelley{} (Shelley.ShelleyTxId (ShelleyLedger.TxId i)) = TxId (Crypto.castHash i) -fromGenTxId EraByron{} (Byron.ByronTxId i) = fromByronTxId i -fromGenTxId EraByron{} _ = error "fromGenTxId: unhandled Byron GenTxId case" +fromGenTxId :: Mode mode era -> GenTxId (HFCBlockOf mode) -> TxId +fromGenTxId ModeShelley{} + (HFC.project' (Proxy @(WrapGenTxId ShelleyBlock)) -> x) = shelleyTxId x +fromGenTxId ModeByron{} + (HFC.project' (Proxy @(WrapGenTxId Byron.ByronBlock)) -> (Byron.ByronTxId i)) = fromByronTxId i +fromGenTxId ModeCardanoShelley{} (GenTxIdShelley x) = shelleyTxId x +fromGenTxId ModeCardanoByron{} (GenTxIdByron (Byron.ByronTxId i)) = fromByronTxId i +fromGenTxId _ _ = + error "fromGenTxId: unsupported protocol" fromByronTxId :: Byron.TxId -> TxId fromByronTxId = @@ -115,14 +137,13 @@ toByronLovelace (Lovelace x) = Left _ -> Nothing Right x' -> Just x' -signTransaction :: Era era -> SigningKeyOf era -> TxBody era -> Tx era -signTransaction p@EraByron{} k body = - signByronTransaction (eraNetworkId p) body [k] -signTransaction EraShelley{} k body = - signShelleyTransaction body [WitnessPaymentKey k] +signTransaction :: Mode mode era -> SigningKeyOf era -> TxBody era -> Tx era +signTransaction p k body = case modeEra p of + EraByron -> signByronTransaction (modeNetworkId p) body [k] + EraShelley -> signShelleyTransaction body [WitnessPaymentKey k] -mkTransaction :: forall era - . Era era +mkTransaction :: forall mode era + . Mode mode era -> SigningKeyOf era -> TxAdditionalSize -> TTL @@ -133,17 +154,18 @@ mkTransaction :: forall era mkTransaction p key payloadSize ttl fee txins txouts = signTransaction p key $ makeTransaction p where - makeTransaction :: Era era -> TxBody era - makeTransaction EraShelley{} = - makeShelleyTransaction - (txExtraContentEmpty { txMetadata = - if payloadSize == 0 - then Nothing - else Just $ payloadShelley payloadSize }) - ttl fee txins txouts - makeTransaction EraByron{} = - either (error . T.unpack) Prelude.id $ - mkByronTransaction txins txouts + makeTransaction :: Mode mode era -> TxBody era + makeTransaction m = case modeEra m of + EraShelley -> + makeShelleyTransaction + (txExtraContentEmpty { txMetadata = + if payloadSize == 0 + then Nothing + else Just $ payloadShelley payloadSize }) + ttl fee txins txouts + EraByron -> + either (error . T.unpack) Prelude.id $ + mkByronTransaction txins txouts payloadShelley :: TxAdditionalSize -> TxMetadata payloadShelley = makeTransactionMetadata . Map.singleton 0 . TxMetaBytes . flip SB.replicate 42 . unTxAdditionalSize @@ -206,7 +228,7 @@ mkTransaction p key payloadSize ttl fee txins txouts = mkTransactionGen :: r ~ Int - => Era era + => Mode mode era -> SigningKeyOf era -> NonEmpty (TxIn, TxOut era) -- ^ Non-empty list of (TxIn, TxOut) that will be used as diff --git a/cardano-tx-generator/src/Cardano/Benchmarking/Run.hs b/cardano-tx-generator/src/Cardano/Benchmarking/Run.hs index 812fa095..1b870593 100644 --- a/cardano-tx-generator/src/Cardano/Benchmarking/Run.hs +++ b/cardano-tx-generator/src/Cardano/Benchmarking/Run.hs @@ -1,10 +1,11 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -Wno-all-missed-specialisations #-} +{-# OPTIONS_GHC -Wno-all-missed-specialisations -Wno-orphans #-} module Cardano.Benchmarking.Run ( parseCommand @@ -13,6 +14,7 @@ module Cardano.Benchmarking.Run ) where import Prelude (String) +import qualified Prelude import Data.Version (showVersion ) import Data.Text @@ -32,21 +34,27 @@ import Ouroboros.Network.Block (MaxSlotNo (..)) import Ouroboros.Network.NodeToClient (IOManager, withIOManager) -import Cardano.Api.Protocol +import Ouroboros.Consensus.Cardano (Protocol, ProtocolByron, ProtocolShelley, ProtocolCardano) + +import qualified Cardano.Api.Protocol as Api +import Cardano.Api.Typed +import Cardano.Api.TxSubmit import Cardano.Config.Types import Cardano.Node.Logging +import Cardano.Node.Protocol.Cardano import Cardano.Node.Protocol.Byron import Cardano.Node.Protocol.Shelley import Cardano.Node.Types hiding (Protocol) import Cardano.Benchmarking.GeneratorTx import Cardano.Benchmarking.GeneratorTx.Benchmark +import Cardano.Benchmarking.GeneratorTx.Genesis import Cardano.Benchmarking.GeneratorTx.CLI.Parsers import Cardano.Benchmarking.GeneratorTx.Era data ProtocolError = - IncorrectProtocolSpecified !Protocol + IncorrectProtocolSpecified !Api.Protocol | ProtocolInstantiationError !Text | GenesisBenchmarkRunnerError !TxGenError deriving Show @@ -59,10 +67,10 @@ data CliError = data GeneratorCmd = GenerateTxs FilePath - GenesisFile SocketPath PartialBenchmark - SigningKeyFile + SomeEra + GeneratorFunds parserInfo :: String -> Opt.ParserInfo GeneratorCmd parserInfo t = @@ -76,21 +84,27 @@ parseCommand = <$> parseConfigFile "config" "Configuration file for the cardano-node" - <*> (GenesisFile <$> parseGenesisPath) <*> parseSocketPath "socket-path" "Path to a cardano-node socket" <*> parsePartialBenchmark - <*> parseSigningKeysFile - "sig-key" - "Path to signing key file, for genesis UTxO using by generator." + <*> (fromMaybe (SomeEra defaultEra) <$> + ( parseFlag' Nothing (Just . SomeEra $ EraByron) + "byron" "Initialise Cardano in Byron submode." + <|> parseFlag' Nothing (Just . SomeEra $ EraShelley) + "shelley" "Initialise Cardano in Shelley submode." + )) + <*> parseGeneratorFunds + +defaultEra :: Era Shelley +defaultEra = EraShelley runCommand :: GeneratorCmd -> ExceptT CliError IO () runCommand (GenerateTxs logConfigFp - genFile socketFp cliPartialBenchmark - keyFile) = + someEra + funds) = withIOManagerE $ \iocp -> do -- Logging layer loggingLayer <- firstExceptT (\(ConfigErrorFileNotFound fp) -> FileNotFoundError fp) $ @@ -102,15 +116,25 @@ runCommand (GenerateTxs logConfigFp p <- firstExceptT GenerateTxsError $ case ncProtocolConfig nc of NodeProtocolConfigurationByron config -> do - let config' = config { npcByronGenesisFile = genFile } - ptcl <- firstExceptT (ProtocolInstantiationError . pack . show) $ - mkConsensusProtocolByron config' Nothing - pure . SomeEra $ mkEra ptcl iocp socketFp loggingLayer + ptcl :: Protocol IO ByronBlockHFC ProtocolByron + <- firstExceptT (ProtocolInstantiationError . pack . show) $ + mkConsensusProtocolByron config Nothing + pure . SomeMode $ mkMode ptcl EraByron iocp socketFp loggingLayer NodeProtocolConfigurationShelley config -> do - let config' = config { npcShelleyGenesisFile = genFile } - ptcl <- firstExceptT (ProtocolInstantiationError . pack . show) $ - mkConsensusProtocolShelley config' Nothing - pure . SomeEra $ mkEra ptcl iocp socketFp loggingLayer + ptcl :: Protocol IO ShelleyBlockHFC ProtocolShelley + <- firstExceptT (ProtocolInstantiationError . pack . show) $ + mkConsensusProtocolShelley config Nothing + pure . SomeMode $ mkMode ptcl EraShelley iocp socketFp loggingLayer + NodeProtocolConfigurationCardano byC shC hfC -> do + ptcl :: Protocol IO CardanoBlock ProtocolCardano + <- firstExceptT (ProtocolInstantiationError . pack . show) $ + mkConsensusProtocolCardano byC shC hfC Nothing + case someEra of + SomeEra era -> + pure . SomeMode $ mkMode ptcl era iocp socketFp loggingLayer + -- case someEra of + -- SomeEra EraByron -> + -- pure . SomeMode $ mkMode ptcl EraByron iocp socketFp loggingLayer x -> fail $ "Unsupported protocol: " <> show x firstExceptT GenerateTxsError $ @@ -118,8 +142,9 @@ runCommand (GenerateTxs logConfigFp case (p, mkBenchmark (defaultBenchmark <> cliPartialBenchmark)) of (_, Left e) -> fail $ "Incomplete benchmark spec (is defaultBenchmark complete?): " <> unpack e - (SomeEra era, Right bench) -> - genesisBenchmarkRunner bench era keyFile + (SomeMode mode, Right bench) -> + secureFunds bench mode funds + >>= uncurry (runBenchmark bench mode) liftIO $ do threadDelay (200*1000) -- Let the logging layer print out everything. shutdownLoggingLayer loggingLayer @@ -148,3 +173,10 @@ runCommand (GenerateTxs logConfigFp withIOManagerE :: (IOManager -> ExceptT e IO a) -> ExceptT e IO a withIOManagerE k = ExceptT $ withIOManager (runExceptT . k) + +instance Prelude.Show (TxForMode a) where + show = \case + TxForByronMode tx -> Prelude.show tx + TxForShelleyMode tx -> Prelude.show tx + TxForCardanoMode (Left tx) -> Prelude.show tx + TxForCardanoMode (Right tx) -> Prelude.show tx