-
Notifications
You must be signed in to change notification settings - Fork 0
/
LocalProtocolDefinition.hs
98 lines (84 loc) · 3.52 KB
/
LocalProtocolDefinition.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
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
module Cardano.Benchmarking.GeneratorTx.LocalProtocolDefinition
(
mangleLocalProtocolDefinition
) where
import Prelude (error)
import Cardano.Prelude hiding (TypeError, show)
import qualified Ouroboros.Consensus.Cardano as Consensus
import Ouroboros.Consensus.Config
( configBlock, configCodec)
import Ouroboros.Consensus.Config.SupportsNode
(ConfigSupportsNode(..), getNetworkMagic)
import Ouroboros.Consensus.Node.ProtocolInfo
(ProtocolInfo (..))
import Ouroboros.Network.NodeToClient (IOManager)
import Cardano.Chain.Slotting
import Cardano.Api
import Cardano.Api.Typed
import qualified Cardano.Api.Typed as Api
-- Node imports
import Cardano.Node.Types (SocketPath(..))
import Cardano.Tracing.OrphanInstances.Byron()
import Cardano.Tracing.OrphanInstances.Common()
import Cardano.Tracing.OrphanInstances.Consensus()
import Cardano.Tracing.OrphanInstances.Network()
import Cardano.Tracing.OrphanInstances.Shelley()
import Cardano.Benchmarking.GeneratorTx.Benchmark
import Cardano.Benchmarking.GeneratorTx.Era
import Cardano.Benchmarking.GeneratorTx.NodeToNode
import Cardano.Benchmarking.GeneratorTx
import Cardano.Benchmarking.GeneratorTx.Genesis (GeneratorFunds)
type Funding era = Benchmark -> GeneratorFunds -> ExceptT TxGenError IO (SigningKey PaymentKey, [(TxIn, TxOut era)])
type BenchmarkAction era
= Benchmark -> (SigningKey PaymentKey, [(TxIn, TxOut era)]) -> ExceptT TxGenError IO ()
type Action era = Proxy era -> Benchmark -> GeneratorFunds -> ExceptT TxGenError IO ()
mangleLocalProtocolDefinition
:: forall blok ptcl era.
(
IsShelleyBasedEra era
, ConfigSupportsTxGen CardanoMode era
)
=> Consensus.Protocol IO blok ptcl
-> Maybe NetworkMagic
-> Bool
-> IOManager
-> SocketPath
-> BenchTracers IO CardanoBlock
-> Action era
mangleLocalProtocolDefinition ptcl@(Consensus.ProtocolCardano
_
Consensus.ProtocolParamsShelleyBased{Consensus.shelleyBasedGenesis}
_ _ _ _ _ _)
nmagic_opt is_addr_mn iom (SocketPath sock) tracers
= action
where
action _proxy benchmark fundOptions
= funding benchmark fundOptions >>= benchmarkAction benchmark
ProtocolInfo{pInfoConfig} = Consensus.protocolInfo ptcl
localConnectInfo = LocalNodeConnectInfo
sock
(Api.Testnet . getNetworkMagic . configBlock $ pInfoConfig)
(CardanoMode (EpochSlots 21600)) -- TODO: get this from genesis
connectClient :: ConnectClient
connectClient = benchmarkConnectTxSubmit
iom
(btConnect_ tracers)
(btSubmission_ tracers)
(configCodec pInfoConfig)
(getNetworkMagic $ configBlock pInfoConfig)
funding :: Funding era
funding = secureFunds
(btTxSubmit_ tracers)
localConnectInfo
networkId
shelleyBasedGenesis
benchmarkAction :: BenchmarkAction era
benchmarkAction = runBenchmark (btTxSubmit_ tracers) (btN2N_ tracers) networkId connectClient
networkId = if is_addr_mn
then Mainnet
else Testnet $ getNetworkMagic $ configBlock pInfoConfig
mangleLocalProtocolDefinition _ _ _ _ _ _ = error "mkCallbacks"