/
Benchmark.hs
270 lines (232 loc) · 9.21 KB
/
Benchmark.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-all-missed-specialisations #-}
{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Cardano.Benchmarking.GeneratorTx.Benchmark
( Benchmark(..)
, PartialBenchmark(..)
, defaultBenchmark
, mkBenchmark
, parsePartialBenchmark
, InitCooldown(..)
, NumberOfInputsPerTx(..)
, NumberOfOutputsPerTx(..)
, NumberOfTxs(..)
, TxAdditionalSize(..)
, TPSRate(..)
, Ack(..)
, Acked(..)
, ToAnnce(..)
, Req(..)
, Sent(..)
, UnAcked(..)
, Unav(..)
, UnReqd(..)
, SubmissionSummary(..)
) where
import Prelude (String)
import Cardano.Prelude hiding (TypeError)
import Data.Aeson (ToJSON (..))
import qualified Data.List.NonEmpty as NE
import Data.Monoid.Generic
import Data.Time.Clock (NominalDiffTime)
import Data.Word (Word64)
import Options.Applicative (Parser)
import qualified Options.Applicative as Opt
-- Era-agnostic imports
import Ouroboros.Consensus.Block.Abstract (SlotNo(..))
-- Node API imports
import Cardano.Api.Typed
-- Node imports
import Cardano.Node.Types (NodeAddress)
import Cardano.Tracing.OrphanInstances.Byron()
import Cardano.Tracing.OrphanInstances.Common()
import Cardano.Tracing.OrphanInstances.Consensus()
import Cardano.Tracing.OrphanInstances.Mock()
import Cardano.Tracing.OrphanInstances.Network()
import Cardano.Tracing.OrphanInstances.Shelley()
import Cardano.Benchmarking.GeneratorTx.CLI.Parsers
{-------------------------------------------------------------------------------
Ground types
-------------------------------------------------------------------------------}
-- | How long wait before starting the main submission phase,
-- after the init Tx batch was submitted.
newtype InitCooldown =
InitCooldown Int
deriving (Eq, Ord, Num, Show)
newtype NumberOfInputsPerTx =
NumberOfInputsPerTx Int
deriving (Eq, Ord, Num, Show)
newtype NumberOfOutputsPerTx =
NumberOfOutputsPerTx Int
deriving (Eq, Ord, Num, Show)
newtype NumberOfTxs =
NumberOfTxs Word64
deriving (Eq, Ord, Num, Show)
newtype TPSRate =
TPSRate Double
deriving (Eq, Generic, Ord, Num, Show)
-- | This parameter specifies additional size (in bytes) of transaction.
-- Since 1 transaction is ([input] + [output] + attributes), its size
-- is defined by its inputs and outputs. We want to have an ability to
-- increase transaction's size without increasing the number of inputs/
-- outputs. Such a big transaction will give us more real-world results
-- of benchmarking.
-- Technically this parameter specifies the size of attribute we'll
-- add to transaction (by default attributes are empty, so if this
-- parameter is skipped, attributes will remain empty).
newtype TxAdditionalSize =
TxAdditionalSize { unTxAdditionalSize :: Int }
deriving (Eq, Ord, Num, Show)
-- | Transactions not yet even announced.
newtype UnReqd tx = UnReqd [tx]
-- | Transactions we decided to announce now.
newtype ToAnnce tx = ToAnnce [tx]
-- | Transactions announced, yet unacked by peer.
newtype UnAcked tx = UnAcked [tx]
-- | Transactions acked by peer.
newtype Acked tx = Acked [tx]
-- | Peer acknowledged this many txids of the outstanding window.
newtype Ack = Ack Int deriving (Enum, Eq, Integral, Num, Ord, Real)
-- | Peer requested this many txids to add to the outstanding window.
newtype Req = Req Int deriving (Enum, Eq, Integral, Num, Ord, Real)
-- | This many Txs sent to peer.
newtype Sent = Sent Int deriving (Enum, Eq, Generic, Integral, Num, Ord, Real, Show)
-- | This many Txs requested by the peer, but not available for sending.
newtype Unav = Unav Int deriving (Enum, Eq, Generic, Integral, Num, Ord, Real, Show)
instance ToJSON Sent
instance ToJSON Unav
instance ToJSON TPSRate
deriving instance Num Lovelace
parseNumberOfTxs :: String -> String -> Parser NumberOfTxs
parseNumberOfTxs opt desc = NumberOfTxs <$> parseIntegral opt desc
parseNumberOfInputsPerTx :: String -> String -> Parser NumberOfInputsPerTx
parseNumberOfInputsPerTx opt desc = NumberOfInputsPerTx <$> parseIntegral opt desc
parseNumberOfOutputsPerTx :: String -> String -> Parser NumberOfOutputsPerTx
parseNumberOfOutputsPerTx opt desc = NumberOfOutputsPerTx <$> parseIntegral opt desc
parseTPSRate :: String -> String -> Parser TPSRate
parseTPSRate opt desc = TPSRate <$> parseDouble opt desc
parseInitCooldown :: String -> String -> Parser InitCooldown
parseInitCooldown opt desc = InitCooldown <$> parseIntegral opt desc
parseTxAdditionalSize :: String -> String -> Parser TxAdditionalSize
parseTxAdditionalSize opt desc = TxAdditionalSize <$> parseIntegral opt desc
-- | Summary of a tx submission run.
data SubmissionSummary
= SubmissionSummary
{ ssTxSent :: !Sent
, ssTxUnavailable :: !Unav
, ssElapsed :: !NominalDiffTime
, ssEffectiveTps :: !TPSRate
, ssThreadwiseTps :: ![TPSRate]
} deriving (Show, Generic)
instance ToJSON SubmissionSummary
-- | Specification for a benchmark run.
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.
data PartialBenchmark
= PartialBenchmark
{ pbTargets :: !(Last (NonEmpty NodeAddress))
, pbInitCooldown :: !(Last InitCooldown)
, pbInitialTTL :: !(Last SlotNo)
, pbTxCount :: !(Last NumberOfTxs)
, pbTps :: !(Last TPSRate)
, pbTxFanIn :: !(Last NumberOfInputsPerTx)
, pbTxFanOut :: !(Last NumberOfOutputsPerTx)
, pbTxFee :: !(Last Lovelace)
, pbTxExtraPayload :: !(Last TxAdditionalSize)
}
deriving (Generic, Show)
deriving Semigroup via GenericSemigroup PartialBenchmark
deriving Monoid via GenericMonoid PartialBenchmark
parsePartialBenchmark :: Opt.Parser PartialBenchmark
parsePartialBenchmark =
PartialBenchmark
<$> lastly (NE.fromList <$> some (
parseTargetNodeAddress
"target-node"
"IP address and port of the node transactions will be sent to."
)
)
<*> (lastly $ parseInitCooldown
"init-cooldown"
"Delay between init and main submission phases.")
<*> (lastly $ parseInitialTTL
"initial-ttl"
"Slot denoting TTL of the initial transactions.")
<*> (lastly $ parseNumberOfTxs
"num-of-txs"
"Number of transactions generator will create.")
<*> (lastly $ parseTPSRate
"tps"
"TPS (transaction per second) rate.")
<*> (lastly $ parseNumberOfInputsPerTx
"inputs-per-tx"
"Number of inputs in each of transactions.")
<*> (lastly $ parseNumberOfOutputsPerTx
"outputs-per-tx"
"Number of outputs in each of transactions.")
<*> (lastly $ parseFeePerTx
"tx-fee"
"Fee per transaction, in Lovelaces.")
<*> (lastly $ parseTxAdditionalSize
"add-tx-size"
"Additional size of transaction, in bytes.")
defaultBenchmark :: PartialBenchmark
defaultBenchmark =
PartialBenchmark
{ pbTargets = mempty
, pbInitCooldown = pure 20
, pbInitialTTL = pure (SlotNo 100000000)
, pbTxCount = pure 1000
, pbTps = pure 10
, pbTxFanIn = pure 1
, pbTxFanOut = pure 1
, pbTxFee = pure 1000
, pbTxExtraPayload = pure 100
}
-- This is called at the last stage of the Partial Options Monoid approach.
-- https://medium.com/@jonathangfischoff/the-partial-options-monoid-pattern-31914a71fc67
mkBenchmark :: PartialBenchmark -> Either Text Benchmark
mkBenchmark PartialBenchmark{..} = do
bTargets <- mkComplete "bTargets " pbTargets
bInitCooldown <- mkComplete "bInitCooldown " pbInitCooldown
bInitialTTL <- mkComplete "bInitialTTL " pbInitialTTL
bTxCount <- mkComplete "bTxCount " pbTxCount
bTps <- mkComplete "bTps " pbTps
bTxFanIn <- mkComplete "bTxFanIn " pbTxFanIn
bTxFanOut <- mkComplete "bTxFanOut " pbTxFanOut
bTxFee <- mkComplete "bTxFee " pbTxFee
bTxExtraPayload <- mkComplete "bTxExtraPayload" pbTxExtraPayload
pure Benchmark{..}
where
-- | Return an error if the @Last@ option is incomplete.
mkComplete :: Text -> Last a -> Either Text a
mkComplete err (Last x) = maybe (Left err) Right x