futur.blue
objective categorical abstract machine language personal data server
1open Alcotest
2open Hermes_cli
3
4let contains s1 s2 =
5 try
6 let len = String.length s2 in
7 for i = 0 to String.length s1 - len do
8 if String.sub s1 i len = s2 then raise Exit
9 done ;
10 false
11 with Exit -> true
12
13(* create a simple lexicon doc for testing *)
14let make_lexicon id defs =
15 {Lexicon_types.lexicon= 1; id; revision= None; description= None; defs}
16
17let make_def name type_def = {Lexicon_types.name; type_def}
18
19let make_object_spec properties required =
20 { Lexicon_types.properties
21 ; required= Some required
22 ; nullable= None
23 ; description= None }
24
25let make_property type_def = {Lexicon_types.type_def; description= None}
26
27let string_type =
28 Lexicon_types.String
29 { format= None
30 ; min_length= None
31 ; max_length= None
32 ; min_graphemes= None
33 ; max_graphemes= None
34 ; known_values= None
35 ; enum= None
36 ; const= None
37 ; default= None
38 ; description= None }
39
40let int_type =
41 Lexicon_types.Integer
42 { minimum= None
43 ; maximum= None
44 ; enum= None
45 ; const= None
46 ; default= None
47 ; description= None }
48
49let[@warning "-32"] _bool_type =
50 Lexicon_types.Boolean {const= None; default= None; description= None}
51
52(* test generating a simple object type *)
53let test_gen_simple_object () =
54 let obj_spec =
55 make_object_spec
56 [("name", make_property string_type); ("age", make_property int_type)]
57 ["name"; "age"]
58 in
59 let doc =
60 make_lexicon "com.example.test"
61 [make_def "main" (Lexicon_types.Object obj_spec)]
62 in
63 let code = Codegen.gen_lexicon_module doc in
64 check bool "contains type main" true (contains code "type main =") ;
65 check bool "contains name field" true (contains code "name: string") ;
66 check bool "contains age field" true (contains code "age: int") ;
67 check bool "contains deriving" true (contains code "[@@deriving yojson")
68
69(* test generating object with optional fields *)
70let test_gen_optional_fields () =
71 let obj_spec =
72 make_object_spec
73 [ ("required_field", make_property string_type)
74 ; ("optional_field", make_property string_type) ]
75 ["required_field"]
76 (* only required_field is required *)
77 in
78 let doc =
79 make_lexicon "com.example.optional"
80 [make_def "main" (Lexicon_types.Object obj_spec)]
81 in
82 let code = Codegen.gen_lexicon_module doc in
83 check bool "required not option" true
84 (contains code "required_field: string;") ;
85 check bool "optional is option" true
86 (contains code "optional_field: string option")
87
88(* test generating with key annotation *)
89let test_gen_key_annotation () =
90 let obj_spec =
91 make_object_spec [("firstName", make_property string_type)] ["firstName"]
92 in
93 let doc =
94 make_lexicon "com.example.key"
95 [make_def "main" (Lexicon_types.Object obj_spec)]
96 in
97 let code = Codegen.gen_lexicon_module doc in
98 check bool "has snake_case field" true (contains code "first_name:") ;
99 check bool "has key annotation" true (contains code "[@key \"firstName\"]")
100
101(* test generating union type *)
102let test_gen_union_type () =
103 let union_spec =
104 { Lexicon_types.refs= ["#typeA"; "#typeB"]
105 ; closed= Some false
106 ; description= None }
107 in
108 let doc =
109 make_lexicon "com.example.union"
110 [make_def "result" (Lexicon_types.Union union_spec)]
111 in
112 let code = Codegen.gen_lexicon_module doc in
113 check bool "contains type result" true (contains code "type result_ =") ;
114 check bool "contains TypeA variant" true (contains code "| TypeA of") ;
115 check bool "contains TypeB variant" true (contains code "| TypeB of") ;
116 check bool "contains Unknown (open)" true
117 (contains code "| Unknown of Yojson.Safe.t")
118
119(* test generating closed union *)
120let test_gen_closed_union () =
121 let union_spec =
122 { Lexicon_types.refs= ["#typeA"; "#typeB"]
123 ; closed= Some true
124 ; description= None }
125 in
126 let doc =
127 make_lexicon "com.example.closed"
128 [make_def "result" (Lexicon_types.Union union_spec)]
129 in
130 let code = Codegen.gen_lexicon_module doc in
131 check bool "no Unknown variant" false (contains code "| Unknown of")
132
133(* test generating query module *)
134let test_gen_query_module () =
135 let params_spec =
136 { Lexicon_types.properties= [("userId", make_property string_type)]
137 ; required= Some ["userId"]
138 ; description= None }
139 in
140 let output_schema =
141 Lexicon_types.Object
142 (make_object_spec [("name", make_property string_type)] ["name"])
143 in
144 let output_body =
145 { Lexicon_types.encoding= "application/json"
146 ; schema= Some output_schema
147 ; description= None }
148 in
149 let query_spec =
150 { Lexicon_types.parameters= Some params_spec
151 ; output= Some output_body
152 ; errors= None
153 ; description= Some "Get user by ID" }
154 in
155 let doc =
156 make_lexicon "com.example.getUser"
157 [make_def "main" (Lexicon_types.Query query_spec)]
158 in
159 let code = Codegen.gen_lexicon_module doc in
160 check bool "contains module Main" true (contains code "module Main = struct") ;
161 check bool "contains nsid" true
162 (contains code "let nsid = \"com.example.getUser\"") ;
163 check bool "contains type params" true (contains code "type params =") ;
164 check bool "contains type output" true (contains code "type output =") ;
165 check bool "contains call function" true (contains code "let call") ;
166 check bool "contains ~user_id param" true (contains code "~user_id") ;
167 check bool "calls Hermes.query" true (contains code "Hermes.query")
168
169(* test generating procedure module *)
170let test_gen_procedure_module () =
171 let input_schema =
172 Lexicon_types.Object
173 (make_object_spec
174 [ ("name", make_property string_type)
175 ; ("email", make_property string_type) ]
176 ["name"; "email"] )
177 in
178 let input_body =
179 { Lexicon_types.encoding= "application/json"
180 ; schema= Some input_schema
181 ; description= None }
182 in
183 let output_schema =
184 Lexicon_types.Object
185 (make_object_spec [("id", make_property string_type)] ["id"])
186 in
187 let output_body =
188 { Lexicon_types.encoding= "application/json"
189 ; schema= Some output_schema
190 ; description= None }
191 in
192 let proc_spec =
193 { Lexicon_types.parameters= None
194 ; input= Some input_body
195 ; output= Some output_body
196 ; errors= None
197 ; description= Some "Create user" }
198 in
199 let doc =
200 make_lexicon "com.example.createUser"
201 [make_def "main" (Lexicon_types.Procedure proc_spec)]
202 in
203 let code = Codegen.gen_lexicon_module doc in
204 check bool "contains module Main" true (contains code "module Main = struct") ;
205 check bool "contains type input" true (contains code "type input =") ;
206 check bool "contains type output" true (contains code "type output =") ;
207 check bool "contains call function" true (contains code "let call") ;
208 check bool "contains ~name param" true (contains code "~name") ;
209 check bool "contains ~email param" true (contains code "~email") ;
210 check bool "calls Hermes.procedure" true (contains code "Hermes.procedure")
211
212(* test type ordering with dependencies *)
213let test_type_ordering () =
214 (* create types where typeB depends on typeA *)
215 let type_a_spec =
216 make_object_spec [("value", make_property string_type)] ["value"]
217 in
218 let type_b_spec =
219 make_object_spec
220 [ ( "a"
221 , make_property (Lexicon_types.Ref {ref_= "#typeA"; description= None})
222 ) ]
223 ["a"]
224 in
225 let doc =
226 make_lexicon "com.example.order"
227 [ make_def "typeB" (Lexicon_types.Object type_b_spec)
228 ; make_def "typeA" (Lexicon_types.Object type_a_spec) ]
229 in
230 let code = Codegen.gen_lexicon_module doc in
231 (* typeA should appear before typeB in the generated code *)
232 let pos_a =
233 try Some (Str.search_forward (Str.regexp "type type_a") code 0)
234 with Not_found -> None
235 in
236 let pos_b =
237 try Some (Str.search_forward (Str.regexp "type type_b") code 0)
238 with Not_found -> None
239 in
240 match (pos_a, pos_b) with
241 | Some a, Some b ->
242 check bool "typeA before typeB" true (a < b)
243 | _ ->
244 fail "both types should be present"
245
246(* test generating token *)
247let test_gen_token () =
248 let token_spec : Lexicon_types.token_spec =
249 {description= Some "A token value"}
250 in
251 let doc =
252 make_lexicon "com.example.tokens"
253 [make_def "myToken" (Lexicon_types.Token token_spec)]
254 in
255 let code = Codegen.gen_lexicon_module doc in
256 check bool "contains let my_token" true (contains code "let my_token =") ;
257 check bool "contains full URI" true
258 (contains code "com.example.tokens#myToken")
259
260(* test generating inline union (union as property type) *)
261let test_gen_inline_union () =
262 let union_type =
263 Lexicon_types.Union
264 {refs= ["#typeA"; "#typeB"]; closed= Some false; description= None}
265 in
266 let obj_spec =
267 make_object_spec [("status", make_property union_type)] ["status"]
268 in
269 let doc =
270 make_lexicon "com.example.inline"
271 [make_def "main" (Lexicon_types.Object obj_spec)]
272 in
273 let code = Codegen.gen_lexicon_module doc in
274 (* inline union should get its own type named after the property *)
275 check bool "contains type status" true (contains code "type status =") ;
276 check bool "contains TypeA variant" true (contains code "| TypeA of") ;
277 check bool "contains TypeB variant" true (contains code "| TypeB of") ;
278 (* main type should reference the inline union *)
279 check bool "main uses status type" true (contains code "status: status")
280
281(* test generating inline union in array (field_item context) *)
282let test_gen_inline_union_in_array () =
283 let union_type =
284 Lexicon_types.Union
285 {refs= ["#typeA"; "#typeB"]; closed= Some true; description= None}
286 in
287 let array_type =
288 Lexicon_types.Array
289 {items= union_type; min_length= None; max_length= None; description= None}
290 in
291 let obj_spec =
292 make_object_spec [("items", make_property array_type)] ["items"]
293 in
294 let doc =
295 make_lexicon "com.example.arrayunion"
296 [make_def "main" (Lexicon_types.Object obj_spec)]
297 in
298 let code = Codegen.gen_lexicon_module doc in
299 (* inline union in array should be named field_item *)
300 check bool "contains type items_item" true (contains code "type items_item =") ;
301 check bool "items is items_item list" true (contains code "items_item list")
302
303(* test generating empty object as unit *)
304let test_gen_empty_object () =
305 let empty_spec =
306 { Lexicon_types.properties= []
307 ; required= None
308 ; nullable= None
309 ; description= None }
310 in
311 let doc =
312 make_lexicon "com.example.empty"
313 [make_def "main" (Lexicon_types.Object empty_spec)]
314 in
315 let code = Codegen.gen_lexicon_module doc in
316 check bool "contains type main = unit" true (contains code "type main = unit") ;
317 check bool "contains main_of_yojson _ = Ok ()" true
318 (contains code "main_of_yojson _ = Ok ()")
319
320(* test generating nullable fields (different from optional) *)
321let test_gen_nullable_fields () =
322 let obj_spec =
323 { Lexicon_types.properties=
324 [ ("required_nullable", make_property string_type)
325 ; ("required_not_nullable", make_property string_type) ]
326 ; required= Some ["required_nullable"; "required_not_nullable"]
327 ; nullable= Some ["required_nullable"]
328 ; description= None }
329 in
330 let doc =
331 make_lexicon "com.example.nullable"
332 [make_def "main" (Lexicon_types.Object obj_spec)]
333 in
334 let code = Codegen.gen_lexicon_module doc in
335 (* required + nullable = option *)
336 check bool "nullable is option" true
337 (contains code "required_nullable: string option") ;
338 (* required + not nullable = not option *)
339 check bool "not nullable is not option" true
340 (contains code "required_not_nullable: string;")
341
342(* test generating mutually recursive types *)
343let test_gen_mutually_recursive () =
344 (* typeA has a field of typeB, typeB has a field of typeA *)
345 let type_a_spec =
346 make_object_spec
347 [ ("name", make_property string_type)
348 ; ( "b"
349 , make_property (Lexicon_types.Ref {ref_= "#typeB"; description= None})
350 ) ]
351 ["name"]
352 in
353 let type_b_spec =
354 make_object_spec
355 [ ("value", make_property int_type)
356 ; ( "a"
357 , make_property (Lexicon_types.Ref {ref_= "#typeA"; description= None})
358 ) ]
359 ["value"]
360 in
361 let doc =
362 make_lexicon "com.example.recursive"
363 [ make_def "typeA" (Lexicon_types.Object type_a_spec)
364 ; make_def "typeB" (Lexicon_types.Object type_b_spec) ]
365 in
366 let code = Codegen.gen_lexicon_module doc in
367 (* should use "type ... and ..." syntax *)
368 check bool "has type keyword" true (contains code "type type_a =") ;
369 check bool "has and keyword" true (contains code "and type_b =") ;
370 (* deriving should appear after the last type in the group *)
371 check bool "has deriving after and block" true
372 (contains code "[@@deriving yojson")
373
374(* test generating record type *)
375let test_gen_record () =
376 let record_spec : Lexicon_types.record_spec =
377 { key= "tid"
378 ; record= make_object_spec [("text", make_property string_type)] ["text"]
379 ; description= Some "A simple record" }
380 in
381 let doc =
382 make_lexicon "com.example.record"
383 [make_def "main" (Lexicon_types.Record record_spec)]
384 in
385 let code = Codegen.gen_lexicon_module doc in
386 check bool "contains type main" true (contains code "type main =") ;
387 check bool "contains text field" true (contains code "text: string")
388
389(* test generating external ref *)
390let test_gen_external_ref () =
391 let obj_spec =
392 make_object_spec
393 [ ( "user"
394 , make_property
395 (Lexicon_types.Ref {ref_= "com.other.defs#user"; description= None})
396 ) ]
397 ["user"]
398 in
399 let doc =
400 make_lexicon "com.example.extref"
401 [make_def "main" (Lexicon_types.Object obj_spec)]
402 in
403 let code = Codegen.gen_lexicon_module doc in
404 (* should generate qualified module reference *)
405 check bool "contains qualified ref" true (contains code "Com_other_defs.user")
406
407(* test generating string type with known values *)
408let test_gen_string_known_values () =
409 let string_spec : Lexicon_types.string_spec =
410 { format= None
411 ; min_length= None
412 ; max_length= None
413 ; min_graphemes= None
414 ; max_graphemes= None
415 ; known_values= Some ["pending"; "active"; "completed"]
416 ; enum= None
417 ; const= None
418 ; default= None
419 ; description= Some "Status values" }
420 in
421 let doc =
422 make_lexicon "com.example.status"
423 [make_def "status" (Lexicon_types.String string_spec)]
424 in
425 let code = Codegen.gen_lexicon_module doc in
426 check bool "contains type status = string" true
427 (contains code "type status = string") ;
428 check bool "contains status_of_yojson" true (contains code "status_of_yojson")
429
430(* test generating permission-set module *)
431let test_gen_permission_set () =
432 let perm1 : Lexicon_types.lex_permission =
433 { resource= "rpc"
434 ; extra=
435 [("lxm", `List [`String "com.example.foo"]); ("inheritAud", `Bool true)]
436 }
437 in
438 let perm2 : Lexicon_types.lex_permission =
439 { resource= "repo"
440 ; extra= [("collection", `List [`String "com.example.data"])] }
441 in
442 let ps_spec : Lexicon_types.permission_set_spec =
443 { title= Some "Test Permissions"
444 ; title_lang= Some [("de", "Test Berechtigungen")]
445 ; detail= Some "Access to test features"
446 ; detail_lang= None
447 ; permissions= [perm1; perm2]
448 ; description= None }
449 in
450 let doc =
451 make_lexicon "com.example.perms"
452 [make_def "main" (Lexicon_types.PermissionSet ps_spec)]
453 in
454 let code = Codegen.gen_lexicon_module doc in
455 check bool "contains type permission" true (contains code "type permission =") ;
456 check bool "contains resource field" true (contains code "resource: string") ;
457 check bool "contains lxm field" true (contains code "lxm: string list option") ;
458 check bool "contains inherit_aud field" true
459 (contains code "inherit_aud: bool option") ;
460 check bool "contains type main" true (contains code "type main =") ;
461 check bool "contains title field" true (contains code "title: string option") ;
462 check bool "contains permissions field" true
463 (contains code "permissions: permission list") ;
464 check bool "contains deriving" true (contains code "[@@deriving yojson")
465
466(* test generating query with bytes output (like getBlob) *)
467let test_gen_query_bytes_output () =
468 let params_spec =
469 { Lexicon_types.properties=
470 [("did", make_property string_type); ("cid", make_property string_type)]
471 ; required= Some ["did"; "cid"]
472 ; description= None }
473 in
474 let output_body =
475 { Lexicon_types.encoding= "*/*" (* bytes output *)
476 ; schema= None
477 ; description= None }
478 in
479 let query_spec =
480 { Lexicon_types.parameters= Some params_spec
481 ; output= Some output_body
482 ; errors= None
483 ; description= Some "Get a blob" }
484 in
485 let doc =
486 make_lexicon "com.atproto.sync.getBlob"
487 [make_def "main" (Lexicon_types.Query query_spec)]
488 in
489 let code = Codegen.gen_lexicon_module doc in
490 check bool "contains module Main" true (contains code "module Main = struct") ;
491 check bool "output is bytes * string tuple" true
492 (contains code "type output = bytes * string") ;
493 check bool "calls Hermes.query_bytes" true
494 (contains code "Hermes.query_bytes")
495
496(* test generating procedure with bytes input (like importRepo) *)
497let test_gen_procedure_bytes_input () =
498 let input_body =
499 { Lexicon_types.encoding= "application/vnd.ipld.car" (* bytes input *)
500 ; schema= None
501 ; description= None }
502 in
503 let proc_spec =
504 { Lexicon_types.parameters= None
505 ; input= Some input_body
506 ; output= None
507 ; errors= None
508 ; description= Some "Import a repo" }
509 in
510 let doc =
511 make_lexicon "com.atproto.repo.importRepo"
512 [make_def "main" (Lexicon_types.Procedure proc_spec)]
513 in
514 let code = Codegen.gen_lexicon_module doc in
515 check bool "contains module Main" true (contains code "module Main = struct") ;
516 check bool "has ?input param" true (contains code "?input") ;
517 check bool "calls Hermes.procedure_bytes" true
518 (contains code "Hermes.procedure_bytes") ;
519 check bool "has content_type" true (contains code "application/vnd.ipld.car")
520
521(** tests *)
522
523let object_tests =
524 [ ("simple object", `Quick, test_gen_simple_object)
525 ; ("optional fields", `Quick, test_gen_optional_fields)
526 ; ("key annotation", `Quick, test_gen_key_annotation)
527 ; ("empty object", `Quick, test_gen_empty_object)
528 ; ("nullable fields", `Quick, test_gen_nullable_fields)
529 ; ("external ref", `Quick, test_gen_external_ref)
530 ; ("record type", `Quick, test_gen_record) ]
531
532let union_tests =
533 [ ("open union", `Quick, test_gen_union_type)
534 ; ("closed union", `Quick, test_gen_closed_union)
535 ; ("inline union", `Quick, test_gen_inline_union)
536 ; ("inline union in array", `Quick, test_gen_inline_union_in_array) ]
537
538let xrpc_tests =
539 [ ("query module", `Quick, test_gen_query_module)
540 ; ("procedure module", `Quick, test_gen_procedure_module)
541 ; ("query with bytes output", `Quick, test_gen_query_bytes_output)
542 ; ("procedure with bytes input", `Quick, test_gen_procedure_bytes_input) ]
543
544let ordering_tests =
545 [ ("type ordering", `Quick, test_type_ordering)
546 ; ("mutually recursive", `Quick, test_gen_mutually_recursive) ]
547
548let token_tests = [("token generation", `Quick, test_gen_token)]
549
550let string_tests =
551 [("string with known values", `Quick, test_gen_string_known_values)]
552
553let permission_set_tests =
554 [("generate permission-set", `Quick, test_gen_permission_set)]
555
556let () =
557 run "Codegen"
558 [ ("objects", object_tests)
559 ; ("unions", union_tests)
560 ; ("xrpc", xrpc_tests)
561 ; ("ordering", ordering_tests)
562 ; ("tokens", token_tests)
563 ; ("strings", string_tests)
564 ; ("permission-set", permission_set_tests) ]