-
Notifications
You must be signed in to change notification settings - Fork 36
/
piqobj_of_xml.ml
342 lines (278 loc) · 10 KB
/
piqobj_of_xml.ml
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
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
(*
Copyright 2009, 2010, 2011, 2012, 2013, 2014, 2017 Anton Lavrik
Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
*)
module C = Piqi_common
open C
open Piqobj_common
type xml = Piqi_xml_type.xml
type xml_elem = Piqi_xml_type.xml_elem
let handle_unknown_field = Piqobj_of_json.handle_unknown_field
let check_duplicate = Piqobj_of_piq.check_duplicate
let parse_scalar xml_elem err_string =
let _name, l = xml_elem in
match l with
| [`Data s] -> s
| _ -> error xml_elem err_string
let parse_string_scalar xml_elem err_string =
let _name, l = xml_elem in
match l with
| [] -> (* empty element content means empty string *)
let res = "" in
Piqloc.addrefret xml_elem res
| [`Data s] -> s
| _ -> error xml_elem err_string
let parse_int xml_elem =
let s = parse_scalar xml_elem "int constant expected" in
try
match s.[0] with
| '-' -> `int (Int64.of_string s) (* negative integer *)
| _ -> `uint (Piq_parser.parse_uint s)
with Failure _ ->
(* NOTE: actually, there can be two errors here: invalid integer literal
* and integer overflow *)
error xml_elem "invalid int constant"
let parse_float xml_elem =
let s = parse_scalar xml_elem "float constant expected" in
match s with
| "NaN" -> Pervasives.nan
| "Infinity" -> Pervasives.infinity
| "-Infinity" -> Pervasives.neg_infinity
| _ ->
try float_of_string s
with Failure _ ->
error xml_elem "invalid float constant"
let parse_bool xml_elem =
let err = "bool constant expected" in
let s = parse_scalar xml_elem err in
match s with
| "true" -> true
| "false" -> false
| _ ->
error xml_elem err
let parse_string xml_elem =
parse_string_scalar xml_elem "string constant expected"
let parse_binary xml_elem =
let s = parse_string_scalar xml_elem "binary constant expected" in
try Piqi_base64.decode s
with Invalid_argument _ ->
error xml_elem "invalid base64-encoded string"
(* get the list of XML elements from the node *)
let get_record_elements (l: xml list) :xml_elem list =
List.map (fun xml ->
match xml with
| `Elem x -> x
| `Data s ->
error xml "XML element is expected as a record field") l
let rec parse_obj (t: T.piqtype) (x: xml_elem) :Piqobj.obj =
match t with
(* built-in types *)
| `int -> parse_int x
| `float -> `float (parse_float x)
| `bool -> `bool (parse_bool x)
| `string -> `string (parse_string x)
| `binary -> `binary (parse_binary x)
| `any -> `any (parse_any x)
(* custom types *)
| `record t -> `record (parse_record t x)
| `variant t -> `variant (parse_variant t x)
| `enum t -> `enum (parse_enum t x)
| `list t -> `list (parse_list t x)
| `alias t -> `alias (parse_alias t x)
and parse_any xml_elem =
match xml_elem with
| _name, (`Elem ("piqi-type", [`Data "piqi-any"])) :: rem -> (* extended piqi-any format *)
let rem = get_record_elements rem in
(* manually parsing the piqi-any record, so that we could extract the
* symbolic xml representation *)
(* XXX: check correspondence between typed protobuf and typed xml? *)
let typename_obj, rem = parse_optional_field "type" `string None rem in
let protobuf_obj, rem = parse_optional_field "protobuf" `binary None rem in
let xml_obj, rem = parse_optional_field "xml" `any None rem in
let piq_obj, rem = parse_optional_field "piq" `string None rem in
(* issue warnings on unparsed fields *)
List.iter handle_unknown_field rem;
let typename =
match typename_obj with
| Some (`string x) -> Some x
| _ -> None
in
let protobuf =
match protobuf_obj with
| Some (`binary x) -> Some x
| _ -> None
in
let xml_ast =
match xml_obj with
| Some (`any {Any.xml_ast = xml_ast}) -> xml_ast
| _ -> None
in
let piq_ast =
match piq_obj with
| Some (`string x) ->
let piq_ast = !Piqobj.piq_of_string x in
Some piq_ast
| _ -> None
in
Any.({
Piqobj.default_any with
typename = typename;
pb = protobuf;
xml_ast = xml_ast;
piq_ast = piq_ast;
})
| _ -> (* regular symbolic piqi-any *)
Any.({
Piqobj.default_any with
xml_ast = Some xml_elem;
})
and parse_record t xml_elem =
debug "do_parse_record: %s\n" (some_of t.T.Record.name);
(* get the list of XML elements from the node *)
let _name, l = xml_elem in
let l = get_record_elements l in
(* NOTE: passing locating information as a separate parameter since empty
* list is unboxed and doesn't provide correct location information *)
let loc = xml_elem in
let fields_spec = t.T.Record.field in
let fields, rem =
List.fold_left (parse_field loc) ([], l) fields_spec in
(* issue warnings on unparsed fields *)
List.iter handle_unknown_field rem;
(* put required fields back at the top *)
R.({t = t; field = List.rev fields; unparsed_piq_fields_ref = None})
and parse_field loc (accu, rem) t =
let fields, rem = do_parse_field loc t rem in
(List.rev_append fields accu, rem)
and do_parse_field loc t l =
let open T.Field in
let name = C.name_of_field t in
debug "do_parse_field: %s\n" name;
let field_type = some_of t.piqtype in
let values, rem =
match t.mode with
| `required ->
let x, rem = parse_required_field loc name field_type l in
[x], rem
| `optional ->
let x, rem = parse_optional_field name field_type t.default l in
let res = (match x with Some x -> [x] | None -> []) in
res, rem
| `repeated ->
parse_repeated_field name field_type l
in
let fields =
List.map (fun x -> F.({t = t; obj = Some x})) values
in
fields, rem
and parse_required_field loc name field_type l =
let res, rem = find_fields name l in
match res with
| [] -> error loc ("missing field " ^ U.quote name)
| x::tail ->
check_duplicate name tail;
parse_obj field_type x, rem
(* find field by name, return found fields and remaining fields *)
and find_fields (name:string) (l:xml_elem list) :(xml_elem list * xml_elem list) =
let rec aux accu rem = function
| [] -> List.rev accu, List.rev rem
| ((n, _) as h)::t when n = name -> aux (h::accu) rem t
| h::t -> aux accu (h::rem) t
in
aux [] [] l
and parse_optional_field name field_type default l =
let res, rem = find_fields name l in
match res with
| [] -> Piqobj_common.parse_default field_type default, rem
| x::tail ->
check_duplicate name tail;
Some (parse_obj field_type x), rem
(* parse repeated variant field allowing variant names if field name is
* unspecified *)
and parse_repeated_field name field_type l =
let res, rem = find_fields name l in
match res with
| [] -> [], rem (* allowing repeated field to be actually missing *)
| l ->
let res = List.map (parse_obj field_type) l in
res, rem
and parse_variant t xml_elem =
debug "parse_variant: %s\n" (some_of t.T.Variant.name);
let _name, l = xml_elem in
match l with
| [`Elem ((name, _) as xml_elem)] ->
let options = t.T.Variant.option in
let option =
try
let o = List.find (fun o -> name = C.name_of_option o) options in
parse_option o xml_elem
with Not_found ->
error xml_elem ("unknown variant option: " ^ U.quote name)
in
V.({t = t; option = option})
| _ ->
error xml_elem "exactly one XML element expected as a variant value"
and parse_option t xml_elem =
let open T.Option in
let name, l = xml_elem in
match t.piqtype, l with
| None, [] ->
O.({ t = t; obj = None})
| None, _ ->
error name ("no value expected for option flag " ^ U.quote name)
| Some option_type, _ ->
let obj = parse_obj option_type xml_elem in
O.({t = t; obj = Some obj})
and parse_enum t xml_elem =
debug "parse_enum: %s\n" (some_of t.T.Enum.name);
let name =
parse_scalar xml_elem "exactly one XML CDATA expected as an enum value"
in
let options = t.T.Enum.option in
let option =
try
let o = List.find (fun o -> some_of o.T.Option.name = name) options in
O.({t = o; obj = None})
with Not_found ->
error name ("unknown enum option: " ^ U.quote name)
in
E.({t = t; option = option})
and parse_list t xml_elem =
debug "parse_list: %s\n" (some_of t.T.Piqi_list.name);
let obj_type = some_of t.T.Piqi_list.piqtype in
let _name, l = xml_elem in
let contents = List.map (parse_list_item obj_type) l in
L.({t = t; obj = contents})
and parse_list_item obj_type xml =
debug "parse_list_item\n";
match xml with
| `Elem (("item", l) as xml_elem) ->
parse_obj obj_type xml_elem
| _ ->
error xml "<item> XML element expected as a list item value"
(* XXX: roll-up multiple enclosed aliases into one? *)
and parse_alias t x =
let open T.Alias in
let obj_type = some_of t.piqtype in
debug "parse_alias: %s\n" (some_of t.T.Alias.name);
let obj = parse_obj obj_type x in
A.({t = t; obj = obj})
let _ =
Piqobj.of_xml := parse_obj
(* parse top-level Piq object formatted as XML *)
let parse_obj t xml =
(* NOTE: we don't bother checking the name of the root element -- it doesn't
* have any meaning anyway *)
match xml with
| `Elem xml_elem ->
parse_obj t xml_elem
| _ ->
error xml "XML root element expected"