objective categorical abstract machine language personal data server
1(* parse lexicon json files into lexicon_types *)
2
3open Lexicon_types
4
5let get_string_opt key json =
6 match json with
7 | `Assoc pairs -> (
8 match List.assoc_opt key pairs with Some (`String s) -> Some s | _ -> None )
9 | _ ->
10 None
11
12let get_string key json =
13 match get_string_opt key json with
14 | Some s ->
15 s
16 | None ->
17 failwith ("missing required string field: " ^ key)
18
19let get_int_opt key json =
20 match json with
21 | `Assoc pairs -> (
22 match List.assoc_opt key pairs with Some (`Int i) -> Some i | _ -> None )
23 | _ ->
24 None
25
26let get_int key json =
27 match get_int_opt key json with
28 | Some i ->
29 i
30 | None ->
31 failwith ("missing required int field: " ^ key)
32
33let get_bool_opt key json =
34 match json with
35 | `Assoc pairs -> (
36 match List.assoc_opt key pairs with Some (`Bool b) -> Some b | _ -> None )
37 | _ ->
38 None
39
40let get_list_opt key json =
41 match json with
42 | `Assoc pairs -> (
43 match List.assoc_opt key pairs with Some (`List l) -> Some l | _ -> None )
44 | _ ->
45 None
46
47let get_string_list_opt key json =
48 match get_list_opt key json with
49 | Some l ->
50 Some (List.filter_map (function `String s -> Some s | _ -> None) l)
51 | None ->
52 None
53
54let get_int_list_opt key json =
55 match get_list_opt key json with
56 | Some l ->
57 Some (List.filter_map (function `Int i -> Some i | _ -> None) l)
58 | None ->
59 None
60
61let get_assoc key json =
62 match json with
63 | `Assoc pairs -> (
64 match List.assoc_opt key pairs with
65 | Some (`Assoc _ as a) ->
66 Some a
67 | _ ->
68 None )
69 | _ ->
70 None
71
72(* parse type definition from json *)
73let rec parse_type_def json : type_def =
74 let type_str = get_string "type" json in
75 match type_str with
76 | "string" ->
77 String
78 { format= get_string_opt "format" json
79 ; min_length= get_int_opt "minLength" json
80 ; max_length= get_int_opt "maxLength" json
81 ; min_graphemes= get_int_opt "minGraphemes" json
82 ; max_graphemes= get_int_opt "maxGraphemes" json
83 ; known_values= get_string_list_opt "knownValues" json
84 ; enum= get_string_list_opt "enum" json
85 ; const= get_string_opt "const" json
86 ; default= get_string_opt "default" json
87 ; description= get_string_opt "description" json }
88 | "integer" ->
89 Integer
90 { minimum= get_int_opt "minimum" json
91 ; maximum= get_int_opt "maximum" json
92 ; enum= get_int_list_opt "enum" json
93 ; const= get_int_opt "const" json
94 ; default= get_int_opt "default" json
95 ; description= get_string_opt "description" json }
96 | "boolean" ->
97 Boolean
98 { const= get_bool_opt "const" json
99 ; default= get_bool_opt "default" json
100 ; description= get_string_opt "description" json }
101 | "bytes" ->
102 Bytes
103 { min_length= get_int_opt "minLength" json
104 ; max_length= get_int_opt "maxLength" json
105 ; description= get_string_opt "description" json }
106 | "blob" ->
107 Blob
108 { accept= get_string_list_opt "accept" json
109 ; max_size= get_int_opt "maxSize" json
110 ; description= get_string_opt "description" json }
111 | "cid-link" ->
112 CidLink {description= get_string_opt "description" json}
113 | "array" ->
114 let items_json =
115 match get_assoc "items" json with
116 | Some j ->
117 j
118 | None ->
119 failwith "array type missing items"
120 in
121 Array
122 { items= parse_type_def items_json
123 ; min_length= get_int_opt "minLength" json
124 ; max_length= get_int_opt "maxLength" json
125 ; description= get_string_opt "description" json }
126 | "object" ->
127 Object (parse_object_spec json)
128 | "ref" ->
129 Ref
130 { ref_= get_string "ref" json
131 ; description= get_string_opt "description" json }
132 | "union" ->
133 Union
134 { refs=
135 ( match get_string_list_opt "refs" json with
136 | Some l ->
137 l
138 | None ->
139 [] )
140 ; closed= get_bool_opt "closed" json
141 ; description= get_string_opt "description" json }
142 | "token" ->
143 Token {description= get_string_opt "description" json}
144 | "unknown" ->
145 Unknown {description= get_string_opt "description" json}
146 | "query" ->
147 Query (parse_query_spec json)
148 | "procedure" ->
149 Procedure (parse_procedure_spec json)
150 | "subscription" ->
151 Subscription (parse_subscription_spec json)
152 | "record" ->
153 Record (parse_record_spec json)
154 | "permission-set" ->
155 PermissionSet (parse_permission_set_spec json)
156 | t ->
157 failwith ("unknown type: " ^ t)
158
159and parse_object_spec json : object_spec =
160 let properties =
161 match get_assoc "properties" json with
162 | Some (`Assoc pairs) ->
163 List.map
164 (fun (name, prop_json) ->
165 let type_def = parse_type_def prop_json in
166 let description = get_string_opt "description" prop_json in
167 (name, {type_def; description}) )
168 pairs
169 | _ ->
170 []
171 in
172 { properties
173 ; required= get_string_list_opt "required" json
174 ; nullable= get_string_list_opt "nullable" json
175 ; description= get_string_opt "description" json }
176
177and parse_params_spec json : params_spec =
178 let properties =
179 match get_assoc "properties" json with
180 | Some (`Assoc pairs) ->
181 List.map
182 (fun (name, prop_json) ->
183 let type_def = parse_type_def prop_json in
184 let description = get_string_opt "description" prop_json in
185 (name, {type_def; description}) )
186 pairs
187 | _ ->
188 []
189 in
190 { properties
191 ; required= get_string_list_opt "required" json
192 ; description= get_string_opt "description" json }
193
194and parse_body_def json : body_def =
195 { encoding= get_string "encoding" json
196 ; schema=
197 ( match get_assoc "schema" json with
198 | Some j ->
199 Some (parse_type_def j)
200 | None ->
201 None )
202 ; description= get_string_opt "description" json }
203
204and parse_error_def json : error_def =
205 {name= get_string "name" json; description= get_string_opt "description" json}
206
207and parse_query_spec json : query_spec =
208 let parameters =
209 match get_assoc "parameters" json with
210 | Some j ->
211 Some (parse_params_spec j)
212 | None ->
213 None
214 in
215 let output =
216 match get_assoc "output" json with
217 | Some j ->
218 Some (parse_body_def j)
219 | None ->
220 None
221 in
222 let errors =
223 match get_list_opt "errors" json with
224 | Some l ->
225 Some
226 (List.map
227 (function
228 | `Assoc _ as j ->
229 parse_error_def j
230 | _ ->
231 failwith "invalid error def" )
232 l )
233 | None ->
234 None
235 in
236 {parameters; output; errors; description= get_string_opt "description" json}
237
238and parse_procedure_spec json : procedure_spec =
239 let parameters =
240 match get_assoc "parameters" json with
241 | Some j ->
242 Some (parse_params_spec j)
243 | None ->
244 None
245 in
246 let input =
247 match get_assoc "input" json with
248 | Some j ->
249 Some (parse_body_def j)
250 | None ->
251 None
252 in
253 let output =
254 match get_assoc "output" json with
255 | Some j ->
256 Some (parse_body_def j)
257 | None ->
258 None
259 in
260 let errors =
261 match get_list_opt "errors" json with
262 | Some l ->
263 Some
264 (List.map
265 (function
266 | `Assoc _ as j ->
267 parse_error_def j
268 | _ ->
269 failwith "invalid error def" )
270 l )
271 | None ->
272 None
273 in
274 { parameters
275 ; input
276 ; output
277 ; errors
278 ; description= get_string_opt "description" json }
279
280and parse_subscription_spec json : subscription_spec =
281 let parameters =
282 match get_assoc "parameters" json with
283 | Some j ->
284 Some (parse_params_spec j)
285 | None ->
286 None
287 in
288 let message =
289 match get_assoc "message" json with
290 | Some j ->
291 Some (parse_body_def j)
292 | None ->
293 None
294 in
295 let errors =
296 match get_list_opt "errors" json with
297 | Some l ->
298 Some
299 (List.map
300 (function
301 | `Assoc _ as j ->
302 parse_error_def j
303 | _ ->
304 failwith "invalid error def" )
305 l )
306 | None ->
307 None
308 in
309 {parameters; message; errors; description= get_string_opt "description" json}
310
311and parse_record_spec json : record_spec =
312 let key = get_string "key" json in
313 let record_json =
314 match get_assoc "record" json with
315 | Some j ->
316 j
317 | None ->
318 failwith "record type missing record field"
319 in
320 { key
321 ; record= parse_object_spec record_json
322 ; description= get_string_opt "description" json }
323
324and parse_permission json : lex_permission =
325 let resource = get_string "resource" json in
326 let extra =
327 match json with
328 | `Assoc pairs ->
329 List.filter (fun (k, _) -> k <> "resource") pairs
330 | _ ->
331 []
332 in
333 {resource; extra}
334
335and parse_lang_map key json : (string * string) list option =
336 match json with
337 | `Assoc pairs ->
338 let prefix = key ^ ":" in
339 let lang_pairs =
340 List.filter_map
341 (fun (k, v) ->
342 if String.starts_with ~prefix k then
343 let lang =
344 String.sub k (String.length prefix)
345 (String.length k - String.length prefix)
346 in
347 match v with `String s -> Some (lang, s) | _ -> None
348 else None )
349 pairs
350 in
351 if lang_pairs = [] then None else Some lang_pairs
352 | _ ->
353 None
354
355and parse_permission_set_spec json : permission_set_spec =
356 let permissions =
357 match get_list_opt "permissions" json with
358 | Some l ->
359 List.map
360 (function
361 | `Assoc _ as j ->
362 parse_permission j
363 | _ ->
364 failwith "invalid permission" )
365 l
366 | None ->
367 []
368 in
369 { title= get_string_opt "title" json
370 ; title_lang= parse_lang_map "title" json
371 ; detail= get_string_opt "detail" json
372 ; detail_lang= parse_lang_map "detail" json
373 ; permissions
374 ; description= get_string_opt "description" json }
375
376(* parse complete lexicon document *)
377let parse_lexicon_doc json : lexicon_doc =
378 let lexicon = get_int "lexicon" json in
379 let id = get_string "id" json in
380 let revision = get_int_opt "revision" json in
381 let description = get_string_opt "description" json in
382 let defs =
383 match get_assoc "defs" json with
384 | Some (`Assoc pairs) ->
385 List.map
386 (fun (name, def_json) -> {name; type_def= parse_type_def def_json})
387 pairs
388 | _ ->
389 []
390 in
391 {lexicon; id; revision; description; defs}
392
393(* parse lexicon file *)
394let parse_file path : parse_result =
395 try
396 let json = Yojson.Safe.from_file path in
397 Ok (parse_lexicon_doc json)
398 with
399 | Yojson.Json_error e ->
400 Error ("JSON parse error: " ^ e)
401 | Failure e ->
402 Error ("Parse error: " ^ e)
403 | e ->
404 Error ("Unexpected error: " ^ Printexc.to_string e)
405
406(* parse json string *)
407let parse_string content : parse_result =
408 try
409 let json = Yojson.Safe.from_string content in
410 Ok (parse_lexicon_doc json)
411 with
412 | Yojson.Json_error e ->
413 Error ("JSON parse error: " ^ e)
414 | Failure e ->
415 Error ("Parse error: " ^ e)
416 | e ->
417 Error ("Unexpected error: " ^ Printexc.to_string e)