-
Notifications
You must be signed in to change notification settings - Fork 0
/
Run.hs
191 lines (172 loc) · 7.42 KB
/
Run.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
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -Wno-all-missed-specialisations -Wno-orphans #-}
module Cardano.Benchmarking.Run
( parseCommand
, parserInfo
, runCommand
) where
import Prelude (String, error)
import Prelude qualified
import Data.Version (showVersion)
import Data.Text (pack, unpack)
import Cardano.Prelude hiding (option)
import Control.Monad (fail)
import Control.Monad.Trans.Except.Extra (firstExceptT)
import Control.Tracer (traceWith)
import Options.Applicative qualified as Opt
import Options.Applicative
import Paths_cardano_tx_generator (version)
import Cardano.Chain.Genesis qualified as Genesis
import Ouroboros.Network.Block (MaxSlotNo(..))
import Ouroboros.Network.NodeToClient (IOManager, withIOManager)
import Ouroboros.Consensus.Block.Abstract (BlockProtocol)
import Ouroboros.Consensus.Cardano (Protocol, ProtocolCardano)
import Cardano.Api.Protocol qualified as Api
import Cardano.Api.Typed
import Cardano.Api.TxSubmit
import Cardano.Node.Configuration.Logging
import Cardano.Node.Configuration.POM
import Cardano.Node.Protocol.Cardano
import Cardano.Node.Types
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
import Cardano.Benchmarking.GeneratorTx.LocalProtocolDefinition
data ProtocolError =
IncorrectProtocolSpecified !Api.Protocol
| ProtocolInstantiationError !Text
| GenesisBenchmarkRunnerError !TxGenError
| ConfigNotFoundError !FilePath
deriving stock Show
data CliError =
GenesisReadError !FilePath !Genesis.GenesisDataError
| GenerateTxsError !ProtocolError
| FileNotFoundError !FilePath
deriving stock Show
data GeneratorCmd =
GenerateTxs FilePath
SocketPath
AnyCardanoEra
PartialBenchmark
(Maybe NetworkMagic)
Bool
GeneratorFunds
parserInfo :: String -> Opt.ParserInfo GeneratorCmd
parserInfo t =
Opt.info
(parseCommand Opt.<**> Opt.helper)
(Opt.fullDesc <> Opt.header t)
defaultEra :: AnyCardanoEra
defaultEra = AnyCardanoEra ShelleyEra
parseCommand :: Opt.Parser GeneratorCmd
parseCommand =
GenerateTxs
<$> parseConfigFile
"config"
"Configuration file for the cardano-node"
<*> parseSocketPath
"socket-path"
"Path to a cardano-node socket"
<*> ( fromMaybe defaultEra <$>
(
eraFlag "shelley" ShelleyEra
<|> eraFlag "mary" MaryEra
<|> eraFlag "allegra" AllegraEra
)
)
<*> parsePartialBenchmark
<*> optional pMagicOverride
<*> ( flag False True
(long "addr-mainnet" <> help "Override address discriminator to mainnet.")
)
<*> parseGeneratorFunds
where
pMagicOverride :: Opt.Parser NetworkMagic
pMagicOverride =
NetworkMagic <$>
Opt.option Opt.auto
( Opt.long "n2n-magic-override"
<> Opt.metavar "NATURAL"
<> Opt.help "Override the network magic for the node-to-node protocol."
)
eraFlag name tag = flag Nothing (Just $ AnyCardanoEra tag)
(long name <> help ("Initialise Cardano in " ++ name ++" submode."))
runCommand :: GeneratorCmd -> ExceptT CliError IO ()
runCommand (GenerateTxs logConfigFp
socketFp
benchmarkEra
cliPartialBenchmark
nmagic_opt
is_addr_mn
fundOptions) =
withIOManagerE $ \iocp -> do
benchmark <- case mkBenchmark (defaultBenchmark <> cliPartialBenchmark) of
Left e -> fail $ "Incomplete benchmark spec (is defaultBenchmark complete?): " <> unpack e
Right b -> return b
let configFp = ConfigYamlFilePath logConfigFp
filesPc = defaultPartialNodeConfiguration
{ pncProtocolFiles = Last . Just $
ProtocolFilepaths
{ byronCertFile = Just ""
, byronKeyFile = Just ""
, shelleyKESFile = Just ""
, shelleyVRFFile = Just ""
, shelleyCertFile = Just ""
, shelleyBulkCredsFile = Just ""
}
, pncValidateDB = Last $ Just False
, pncShutdownIPC = Last $ Just Nothing
, pncShutdownOnSlotSynced = Last $ Just NoMaxSlotNo
, pncConfigFile = Last $ Just configFp
}
configYamlPc <- liftIO . parseNodeConfigurationFP . Just $ configFp
nc <- case makeNodeConfiguration $ configYamlPc <> filesPc of
Left err -> panic $ "Error in creating the NodeConfiguration: " <> pack err
Right nc' -> return nc'
case ncProtocolConfig nc of
NodeProtocolConfigurationByron _ -> error "NodeProtocolConfigurationByron not supported"
NodeProtocolConfigurationShelley _ -> error "NodeProtocolConfigurationShelley not supported"
NodeProtocolConfigurationCardano byC shC hfC -> firstExceptT GenerateTxsError $ do
ptcl :: Protocol IO CardanoBlock ProtocolCardano <- firstExceptT (ProtocolInstantiationError . pack . show) $
mkConsensusProtocolCardano byC shC hfC Nothing
loggingLayer <- mkLoggingLayer nc ptcl
let tracers :: BenchTracers IO CardanoBlock
tracers = createTracers loggingLayer
myTracer msg = traceWith (btTxSubmit_ tracers) $ TraceBenchTxSubDebug msg
runAll :: forall era. IsShelleyBasedEra era => Proxy era -> Benchmark -> GeneratorFunds -> ExceptT TxGenError IO ()
runAll = mangleLocalProtocolDefinition ptcl nmagic_opt is_addr_mn iocp socketFp tracers
firstExceptT GenesisBenchmarkRunnerError $ case benchmarkEra of
AnyCardanoEra ByronEra -> error "ByronEra not supported"
AnyCardanoEra ShelleyEra -> do
liftIO $ myTracer "runBenchmark :: ShelleyEra"
runAll (Proxy @ ShelleyEra) benchmark fundOptions
AnyCardanoEra AllegraEra -> do
liftIO $ myTracer "runBenchmark :: AllegraEra"
runAll (Proxy @ AllegraEra) benchmark fundOptions
AnyCardanoEra MaryEra -> do
liftIO $ myTracer "runBenchmark :: MaryEra"
runAll (Proxy @ MaryEra) benchmark fundOptions
_ -> return () -- ???? redundant but type error if left out ??
liftIO $ do
threadDelay (200*1000) -- Let the logging layer print out everything.
shutdownLoggingLayer loggingLayer
where
mkLoggingLayer :: NodeConfiguration -> Protocol IO blk (BlockProtocol blk) -> ExceptT ProtocolError IO LoggingLayer
mkLoggingLayer nc ptcl =
firstExceptT (\(ConfigErrorFileNotFound fp) -> ConfigNotFoundError fp) $
createLoggingLayer (pack $ showVersion version) nc ptcl
----------------------------------------------------------------------------
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 (InAnyCardanoEra _ tx) -> Prelude.show tx