/
Core.hs
309 lines (279 loc) · 11.9 KB
/
Core.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
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
{- HLINT ignore "Reduce duplication" -}
{- HLINT ignore "Use uncurry" -}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RankNTypes #-} --
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Cardano.Benchmarking.Script.Core
where
import Prelude
import Control.Monad
import Control.Monad.Trans.Except
import Control.Monad.IO.Class
import Control.Concurrent (threadDelay)
import Control.Tracer (traceWith)
import Ouroboros.Network.Protocol.LocalTxSubmission.Type (SubmitResult (..))
import Cardano.Api ( AsType(..), CardanoEra(..), InAnyCardanoEra(..), AnyCardanoEra(..), IsShelleyBasedEra, Tx
, Lovelace, NetworkId(..), cardanoEra
, CardanoMode, LocalNodeConnectInfo
, PaymentKey
, SigningKey
, TxInMode
, TxValidationErrorInMode
, getLocalChainTip, queryNodeLocalState, QueryInMode( QueryCurrentEra), ConsensusModeIsMultiEra( CardanoModeIsMultiEra )
, chainTipToChainPoint )
import qualified Cardano.Benchmarking.FundSet as FundSet
import Cardano.Benchmarking.FundSet (FundInEra(..), Validity(..), liftAnyEra )
import Cardano.Benchmarking.GeneratorTx as Core
(AsyncBenchmarkControl, asyncBenchmark, waitBenchmark, readSigningKey, secureGenesisFund, splitFunds, txGenerator, TxGenError)
import Cardano.Benchmarking.GeneratorTx.Tx as Core (keyAddress, txInModeCardano)
import Cardano.Benchmarking.GeneratorTx.LocalProtocolDefinition as Core (startProtocol)
import Cardano.Benchmarking.GeneratorTx.NodeToNode (ConnectClient, benchmarkConnectTxSubmit)
import Cardano.Benchmarking.OuroborosImports as Core
(LocalSubmitTx, SigningKeyFile
, getGenesis, protocolToNetworkId, protocolToCodecConfig, makeLocalConnectInfo, submitTxToNodeLocal)
import Cardano.Benchmarking.Tracer as Core
( TraceBenchTxSubmit (..)
, createTracers, btTxSubmit_, btN2N_, btConnect_, btSubmission_)
import Cardano.Benchmarking.Types as Core (NumberOfTxs(..), SubmissionErrorPolicy(..), TPSRate)
import Cardano.Benchmarking.Wallet
import Cardano.Benchmarking.Script.Env
import Cardano.Benchmarking.Script.Setters
import Cardano.Benchmarking.Script.Store as Store
liftCoreWithEra :: (forall era. IsShelleyBasedEra era => AsType era -> ExceptT TxGenError IO x) -> ActionM (Either TxGenError x)
liftCoreWithEra coreCall = withEra ( liftIO . runExceptT . coreCall)
withEra :: (forall era. IsShelleyBasedEra era => AsType era -> ActionM x) -> ActionM x
withEra action = do
era <- get $ User TEra
case era of
AnyCardanoEra AlonzoEra -> action AsAlonzoEra
AnyCardanoEra MaryEra -> action AsMaryEra
AnyCardanoEra AllegraEra -> action AsAllegraEra
AnyCardanoEra ShelleyEra -> action AsShelleyEra
AnyCardanoEra ByronEra -> error "byron not supported"
startProtocol :: FilePath -> ActionM ()
startProtocol filePath = do
liftIO (runExceptT $ Core.startProtocol filePath) >>= \case
Left err -> throwE $ CliError err
Right (loggingLayer, protocol) -> do
set LoggingLayer loggingLayer
set Protocol protocol
set BenchTracers $ Core.createTracers loggingLayer
set Genesis $ Core.getGenesis protocol
set NetworkId $ protocolToNetworkId protocol
readSigningKey :: KeyName -> SigningKeyFile -> ActionM ()
readSigningKey name filePath =
liftIO ( runExceptT $ Core.readSigningKey filePath) >>= \case
Left err -> liftTxGenError err
Right key -> setName name key
getLocalSubmitTx :: ActionM LocalSubmitTx
getLocalSubmitTx = submitTxToNodeLocal <$> getLocalConnectInfo
secureGenesisFund
:: FundName
-> KeyName
-> KeyName
-> ActionM ()
secureGenesisFund fundName destKey genesisKeyName = do
tracer <- btTxSubmit_ <$> get BenchTracers
localSubmit <- getLocalSubmitTx
networkId <- get NetworkId
genesis <- get Genesis
fee <- getUser TFee
ttl <- getUser TTTL
fundKey <- getName destKey
genesisKey <- getName genesisKeyName
let
coreCall :: forall era. IsShelleyBasedEra era => AsType era -> ExceptT TxGenError IO Store.Fund
coreCall _proxy = do
let addr = Core.keyAddress @ era networkId fundKey
f <- Core.secureGenesisFund tracer localSubmit networkId genesis fee ttl genesisKey addr
return (f, fundKey)
liftCoreWithEra coreCall >>= \case
Left err -> liftTxGenError err
Right fund -> do
-- Todo : user only of two methods
setName fundName fund -- Old method
initGlobalWallet networkId fundKey fund -- New method
initGlobalWallet :: NetworkId -> SigningKey PaymentKey -> Fund -> ActionM ()
initGlobalWallet networkId key ((txIn, outVal), skey) = do
wallet <- liftIO $ initWallet networkId key
liftIO (walletRefInsertFund wallet (FundSet.Fund $ mkFund outVal))
set GlobalWallet wallet
where
mkFund = liftAnyEra $ \value -> FundInEra {
_fundTxIn = txIn
, _fundVal = value
, _fundSigningKey = skey
, _fundValidity = Confirmed
}
splitFundN
:: NumberOfTxs
-> KeyName
-> FundName
-> ActionM [Store.Fund]
splitFundN count destKeyName sourceFund = do
tracer <- btTxSubmit_ <$> get BenchTracers
localSubmit <- getLocalSubmitTx
networkId <- get NetworkId
fee <- getUser TFee
destKey <- getName destKeyName
(fund, fundKey) <- consumeName sourceFund
txIn <- getUser TNumberOfInputsPerTx
let
coreCall :: forall era. IsShelleyBasedEra era => AsType era -> ExceptT TxGenError IO [Store.Fund]
coreCall _proxy = do
let addr = Core.keyAddress @ era networkId fundKey
f <- Core.splitFunds tracer localSubmit fee count txIn fundKey addr fund
return $ zip f $ repeat destKey
liftCoreWithEra coreCall >>= \case
Left err -> liftTxGenError err
Right funds -> return funds
splitFund
:: [FundName]
-> KeyName
-> FundName
-> ActionM ()
splitFund newFunds destKey sourceFund = do
funds <- splitFundN (NumberOfTxs $ fromIntegral $ length newFunds) destKey sourceFund
forM_ (zip newFunds funds) $ \(name, f) -> setName name f
splitFundToList
:: FundListName
-> KeyName
-> FundName
-> ActionM ()
splitFundToList newFunds destKey sourceFund = do
count <- getUser TNumberOfTxs
funds <- splitFundN count destKey sourceFund
setName newFunds funds
delay :: Double -> ActionM ()
delay t = liftIO $ threadDelay $ floor $ 1000000 * t
prepareTxList
:: TxListName
-> KeyName
-> FundListName
-> ActionM ()
prepareTxList name destKey srcFundName = do
tracer <- btTxSubmit_ <$> get BenchTracers
networkId <- get NetworkId
fee <- getUser TFee
fundList <- consumeName srcFundName
key <- getName destKey
txIn <- getUser TNumberOfInputsPerTx
txOut <- getUser TNumberOfOutputsPerTx
count <- getUser TNumberOfTxs
payload <- getUser TTxAdditionalSize
let
coreCall :: forall era. IsShelleyBasedEra era => AsType era -> ExceptT TxGenError IO (InAnyCardanoEra TxList)
coreCall _proxy = do
let addr = Core.keyAddress @ era networkId key
----------------------------------------------------TODO : Constant 1 ???
l <- Core.txGenerator tracer fee count txIn txOut payload addr (snd $ head fundList) 1 (map fst fundList)
return $ InAnyCardanoEra cardanoEra $ TxList l
liftCoreWithEra coreCall >>= \case
Left err -> liftTxGenError err
Right l -> setName name l
waitBenchmarkCore :: AsyncBenchmarkControl -> ActionM ()
waitBenchmarkCore ctl = do
tracers <- get BenchTracers
_ <- liftIO $ runExceptT $ Core.waitBenchmark (btTxSubmit_ tracers) ctl
return ()
asyncBenchmarkCore :: ThreadName -> TxListName -> TPSRate -> ActionM AsyncBenchmarkControl
asyncBenchmarkCore (ThreadName threadName) transactions tps = do
tracers <- get BenchTracers
targets <- getUser TTargets
txs <- getName transactions
(Testnet networkMagic) <- get NetworkId
protocol <- get Protocol
ioManager <- askIOManager
let
connectClient :: ConnectClient
connectClient = benchmarkConnectTxSubmit
ioManager
(btConnect_ tracers)
(btSubmission_ tracers)
(protocolToCodecConfig protocol)
networkMagic
coreCall :: forall era. IsShelleyBasedEra era => [Tx era] -> ExceptT TxGenError IO AsyncBenchmarkControl
coreCall l = Core.asyncBenchmark (btTxSubmit_ tracers) (btN2N_ tracers) connectClient threadName targets tps LogErrors l
ret <- liftIO $ runExceptT $ case txs of
InAnyCardanoEra AlonzoEra (TxList l) -> coreCall l
InAnyCardanoEra MaryEra (TxList l) -> coreCall l
InAnyCardanoEra AllegraEra (TxList l) -> coreCall l
InAnyCardanoEra ShelleyEra (TxList l) -> coreCall l
InAnyCardanoEra ByronEra _ -> error "byron not supported"
case ret of
Left err -> liftTxGenError err
Right ctl -> return ctl
asyncBenchmark :: ThreadName -> TxListName -> TPSRate -> ActionM ()
asyncBenchmark controlName txList tps = asyncBenchmarkCore controlName txList tps >>= setName controlName
waitBenchmark :: ThreadName -> ActionM ()
waitBenchmark n = getName n >>= waitBenchmarkCore
cancelBenchmark :: ThreadName -> ActionM ()
cancelBenchmark n = do
ctl@(_, _ , _ , shutdownAction) <- getName n
liftIO shutdownAction
waitBenchmarkCore ctl
getLocalConnectInfo :: ActionM (LocalNodeConnectInfo CardanoMode)
getLocalConnectInfo = makeLocalConnectInfo <$> get NetworkId <*> getUser TLocalSocket
queryEra :: ActionM AnyCardanoEra
queryEra = do
localNodeConnectInfo <- getLocalConnectInfo
chainTip <- liftIO $ getLocalChainTip localNodeConnectInfo
ret <- liftIO $ queryNodeLocalState localNodeConnectInfo (Just $ chainTipToChainPoint chainTip) $ QueryCurrentEra CardanoModeIsMultiEra
case ret of
Right era -> return era
Left err -> throwE $ ApiError $ show err
waitForEra :: AnyCardanoEra -> ActionM ()
waitForEra era = do
currentEra <- queryEra
if currentEra == era
then return ()
else do
traceError $ "Current era: " ++ show currentEra ++ " Waiting for: " ++ show era
liftIO $ threadDelay 1_000_000
waitForEra era
{-
This is for dirty hacking and testing and quick-fixes.
Its a function that can be called from the JSON scripts
and for which the JSON encoding is "reserved".
-}
reserved :: [String] -> ActionM ()
reserved _ = do
localCreateCoins
-- throwE $ UserError "no dirty hack is implemented"
localCreateCoins :: ActionM ()
localCreateCoins = do
wallet <- get GlobalWallet
let
-- todo: fix hardcoded number of initial coins
outputs :: [[Lovelace]]
outputs = replicate 100 $ map fromInteger [20..50]
createCoins :: forall era. IsShelleyBasedEra era => [Lovelace] -> AsType era -> ActionM (Either String (TxInMode CardanoMode))
createCoins coins _proxy = do
(tx :: Either String (Tx era)) <- liftIO $ walletRefCreateCoins wallet coins
return $ fmap txInModeCardano tx
forM_ outputs $ \coins -> do
gen <- withEra $ createCoins coins
case gen of
Left (_err :: String) -> return ()
Right tx -> void $ localSubmitTx tx
localSubmitTx :: TxInMode CardanoMode -> ActionM (SubmitResult (TxValidationErrorInMode CardanoMode))
localSubmitTx tx = do
submitTracer <- btTxSubmit_ <$> get BenchTracers
submit <- getLocalSubmitTx
ret <- liftIO $ submit tx
let
msg = case ret of
SubmitSuccess -> mconcat
[ "local submit success (" , show tx , ")"]
SubmitFail e -> mconcat
[ "local submit failed: " , show e , " (" , show tx , ")"]
liftIO $ traceWith submitTracer $ TraceBenchTxSubDebug msg
return ret