-
Notifications
You must be signed in to change notification settings - Fork 721
/
Aeson.hs
243 lines (215 loc) · 9.93 KB
/
Aeson.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
{-# OPTIONS_GHC -Wno-orphans #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}
module Cardano.Benchmarking.Script.Aeson
where
import Data.Aeson
import Data.Aeson.Encode.Pretty
import Data.Aeson.Types
import qualified Data.Attoparsec.ByteString as Atto
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BS (lines)
import qualified Data.ByteString.Lazy as BSL
import Data.Dependent.Sum
import Data.Functor.Identity
import qualified Data.HashMap.Strict as HashMap (lookup, toList)
import Data.Text (Text)
import qualified Data.Text as Text
import Prelude
import System.Exit
import Cardano.Api (ScriptData, ScriptDataJsonSchema (..), scriptDataFromJson,
scriptDataToJson)
import Cardano.CLI.Types (SigningKeyFile (..))
import Cardano.Benchmarking.Script.Env
import Cardano.Benchmarking.Script.Setters
import Cardano.Benchmarking.Script.Store
import Cardano.Benchmarking.Script.Types
import Cardano.Benchmarking.Types (NumberOfTxs (..), TPSRate (..))
testJSONRoundTrip :: [Action] -> Maybe String
testJSONRoundTrip l = case fromJSON $ toJSON l of
Success r -> if l == r then Nothing else Just "compare: not equal"
Error err -> Just err
prettyPrint :: [Action] -> BSL.ByteString
prettyPrint = encodePretty' conf
where
conf = defConfig {confCompare = keyOrder actionNames }
actionNames :: [Text]
actionNames =
[ "startProtocol", "readSigningKey", "secureGenesisFund", "splitFund"
, "splitFundToList", "delay", "prepareTxList"
, "runBenchmark", "asyncBenchmark", "waitBenchmark", "cancelBenchmark"
, "reserved" ]
jsonOptionsUnTaggedSum :: Options
jsonOptionsUnTaggedSum = defaultOptions { sumEncoding = ObjectWithSingleField }
-- Orphan instance used in the tx-generator
instance ToJSON ScriptData where
toJSON = scriptDataToJson ScriptDataJsonNoSchema
instance FromJSON ScriptData where
parseJSON v = case scriptDataFromJson ScriptDataJsonNoSchema v of
Right r -> return r
Left err -> fail $ show err
instance ToJSON SubmitMode where
toJSON = genericToJSON jsonOptionsUnTaggedSum
toEncoding = genericToEncoding jsonOptionsUnTaggedSum
instance FromJSON SubmitMode where
parseJSON = genericParseJSON jsonOptionsUnTaggedSum
instance ToJSON PayMode where
toJSON = genericToJSON jsonOptionsUnTaggedSum
toEncoding = genericToEncoding jsonOptionsUnTaggedSum
instance FromJSON PayMode where
parseJSON = genericParseJSON jsonOptionsUnTaggedSum
instance ToJSON SpendMode where
toJSON = genericToJSON jsonOptionsUnTaggedSum
toEncoding = genericToEncoding jsonOptionsUnTaggedSum
instance FromJSON SpendMode where
parseJSON = genericParseJSON jsonOptionsUnTaggedSum
instance ToJSON (DSum Tag Identity) where
toEncoding = error "DSum Tag Identity"
toJSON = error "DSum Tag Identity"
instance FromJSON (DSum Tag Identity) where
parseJSON = error "fromJSON"
instance ToJSON Sum where
toEncoding = genericToEncoding defaultOptions
instance FromJSON Sum
actionToJSON :: Action -> Value
actionToJSON a = case a of
Set keyVal -> keyValToJSONCompact keyVal -- Remove the inner/ nested Object and add "set" -prefix.
StartProtocol filePath -> singleton "startProtocol" filePath
ReadSigningKey (KeyName name) (SigningKeyFile filePath)
-> object ["readSigningKey" .= name, "filePath" .= filePath]
SecureGenesisFund (FundName fundName) (KeyName fundKey) (KeyName genesisKey)
-> object ["secureGenesisFund" .= fundName, "fundKey" .= fundKey, "genesisKey" .= genesisKey ]
SplitFund newFunds (KeyName newKey) (FundName sourceFund)
-> object ["splitFund" .= names, "newKey" .= newKey, "sourceFund" .= sourceFund]
where names = [n | FundName n <- newFunds]
SplitFundToList (FundListName fundList) (KeyName destKey) (FundName sourceFund)
-> object ["splitFundToList" .= fundList, "newKey" .= destKey, "sourceFund" .= sourceFund ]
Delay t -> object ["delay" .= t ]
PrepareTxList (TxListName name) (KeyName key) (FundListName fund)
-> object ["prepareTxList" .= name, "newKey" .= key, "fundList" .= fund ]
AsyncBenchmark (ThreadName t) (TxListName txs) (TPSRate tps)
-> object ["asyncBenchmark" .= t, "txList" .= txs, "tps" .= tps]
ImportGenesisFund submitMode (KeyName genesisKey) (KeyName fundKey)
-> object ["importGenesisFund" .= genesisKey, "submitMode" .= submitMode, "fundKey" .= fundKey ]
CreateChange submitMode payMode value count
-> object ["createChange" .= value, "payMode" .= payMode, "submitMode" .= submitMode, "count" .= count ]
RunBenchmark submitMode spendMode (ThreadName t) (NumberOfTxs txCount) (TPSRate tps)
-> object ["runBenchmark" .= t, "submitMode" .= submitMode, "spendMode" .= spendMode, "txCount" .= txCount, "tps" .= tps]
WaitBenchmark (ThreadName t) -> singleton "waitBenchmark" t
CancelBenchmark (ThreadName t) -> singleton "cancelBenchmark" t
WaitForEra era -> singleton "waitForEra" era
Reserved l -> singleton "reserved" l
where
singleton k v = object [ k .= v ]
keyValToJSONCompact :: SetKeyVal -> Value
keyValToJSONCompact keyVal = case parseEither (withObject "internal Error" parseSum) v of
Right c -> c
Left err -> error err
where
v = toJSON $ runIdentity $ taggedToSum keyVal
parseSum obj = do
key <- obj .: "tag"
(val :: Value) <- obj .: "contents"
return $ object [("set" <> Text.tail key) .= val]
instance ToJSON Action where toJSON = actionToJSON
instance FromJSON Action where parseJSON = jsonToAction
jsonToAction :: Value -> Parser Action
jsonToAction = withObject "Error: Action is not a JSON object." objectToAction
objectToAction :: Object -> Parser Action
objectToAction obj = case obj of
(HashMap.lookup "startProtocol" -> Just v)
-> (withText "Error parsing startProtocol" $ \t -> return $ StartProtocol $ Text.unpack t) v
(HashMap.lookup "readSigningKey" -> Just v) -> parseReadSigningKey v
(HashMap.lookup "secureGenesisFund" -> Just v) -> parseSecureGenesisFund v
(HashMap.lookup "splitFund" -> Just v) -> parseSplitFund v
(HashMap.lookup "splitFundToList" -> Just v) -> parseSplitFundToList v
(HashMap.lookup "delay" -> Just v) -> Delay <$> parseJSON v
(HashMap.lookup "prepareTxList" -> Just v) -> parsePrepareTxList v
(HashMap.lookup "asyncBenchmark" -> Just v) -> parseAsyncBenchmark v
(HashMap.lookup "importGenesisFund" -> Just v) -> parseImportGenesisFund v
(HashMap.lookup "createChange" -> Just v) -> parseCreateChange v
(HashMap.lookup "runBenchmark" -> Just v) -> parseRunBenchmark v
(HashMap.lookup "waitBenchmark" -> Just v) -> WaitBenchmark <$> parseThreadName v
(HashMap.lookup "cancelBenchmark" -> Just v) -> CancelBenchmark <$> parseThreadName v
(HashMap.lookup "waitForEra" -> Just v) -> WaitForEra <$> parseJSON v
(HashMap.lookup "reserved" -> Just v) -> Reserved <$> parseJSON v
(HashMap.toList -> [(k, v)] ) -> parseSetter k v
_ -> parseFail "Error: cannot parse action Object."
where
parseSetter k v = case k of
(Text.stripPrefix "set" -> Just tag) -> do
s <- parseJSON $ object [ "tag" .= ("S" <> tag), "contents" .= v]
return $ Set $ sumToTaggged s
_ -> parseFail $ "Error: cannot parse action Object with key " <> Text.unpack k
parseKey f = KeyName <$> parseField obj f
parseFund f = FundName <$> parseField obj f
parseThreadName
= withText "Error parsing ThreadName" $ \t -> return $ ThreadName $ Text.unpack t
parseReadSigningKey v = ReadSigningKey
<$> ( KeyName <$> parseJSON v )
<*> ( SigningKeyFile <$> parseField obj "filePath" )
parseSecureGenesisFund v = SecureGenesisFund
<$> ( FundName <$> parseJSON v )
<*> parseKey "fundKey"
<*> parseKey "genesisKey"
parseSplitFund v = do
l <- parseJSON v
k <- parseKey "newKey"
f <- parseFund "sourceFund"
return $ SplitFund (map FundName l) k f
parseSplitFundToList v = SplitFundToList
<$> ( FundListName <$> parseJSON v )
<*> parseKey "newKey"
<*> parseFund "sourceFund"
parsePrepareTxList v = PrepareTxList
<$> ( TxListName <$> parseJSON v )
<*> parseKey "newKey"
<*> ( FundListName <$>parseField obj "fundList" )
parseAsyncBenchmark v = AsyncBenchmark
<$> ( ThreadName <$> parseJSON v )
<*> ( TxListName <$> parseField obj "txList" )
<*> ( TPSRate <$> parseField obj "tps" )
parseRunBenchmark v = RunBenchmark
<$> parseField obj "submitMode"
<*> parseField obj "spendMode"
<*> ( ThreadName <$> parseJSON v )
<*> ( NumberOfTxs <$> parseField obj "txCount" )
<*> ( TPSRate <$> parseField obj "tps" )
parseImportGenesisFund v = ImportGenesisFund
<$> parseField obj "submitMode"
<*> ( KeyName <$> parseJSON v )
<*> parseKey "fundKey"
parseCreateChange v = CreateChange
<$> parseField obj "submitMode"
<*> parseField obj "payMode"
<*> parseJSON v
<*> parseField obj "count"
parseScriptFile :: FilePath -> IO [Action]
parseScriptFile filePath = do
input <- BS.readFile filePath
case Atto.parse Data.Aeson.json input of
Atto.Fail rest _context msg -> die errorMsg
where
consumed = BS.take (BS.length input - BS.length rest) input
lineNumber = length $ BS.lines consumed
errorMsg = concat [
"error while parsing json value :\n"
, "file :" , filePath , "\n"
, "line number ", show lineNumber ,"\n"
, "message : ", msg, "\n"
]
Atto.Partial _ -> die $ concat [
"error while parsing json value :\n"
, "file :" , filePath , "\n"
, "truncated input file\n"
]
-- Atto.Done extra _ | (not $ BS.null extra) -> die $ concat [
-- "error while parsing json value :\n"
-- , "file :" , filePath , "\n"
-- , "leftover data"
-- ]
Atto.Done _ value -> case fromJSON value of
Error err -> die err
Success script -> return script