+7
bin/dune
+7
bin/dune
+308
-50
bin/jmap.ml
+308
-50
bin/jmap.ml
···
30
30
|> List.filter_map (fun (k, v) -> if v then Some k else None)
31
31
|> String.concat " "
32
32
33
+
(* Helpers for optional Email fields *)
34
+
let email_id (e : Jmap.Proto.Email.t) =
35
+
match e.id with Some id -> Jmap.Proto.Id.to_string id | None -> "?"
36
+
37
+
let email_received_at (e : Jmap.Proto.Email.t) =
38
+
match e.received_at with Some t -> ptime_to_string t | None -> "?"
39
+
40
+
let email_keywords (e : Jmap.Proto.Email.t) =
41
+
Option.value ~default:[] e.keywords
42
+
43
+
let email_preview (e : Jmap.Proto.Email.t) =
44
+
Option.value ~default:"" e.preview
45
+
46
+
let email_thread_id (e : Jmap.Proto.Email.t) =
47
+
match e.thread_id with Some id -> Jmap.Proto.Id.to_string id | None -> "?"
48
+
49
+
let email_size (e : Jmap.Proto.Email.t) =
50
+
Option.value ~default:0L e.size
51
+
52
+
let email_mailbox_ids (e : Jmap.Proto.Email.t) =
53
+
Option.value ~default:[] e.mailbox_ids
54
+
33
55
(** {1 Session Command} *)
34
56
35
57
let session_cmd =
···
98
120
result.state;
99
121
(* Sort by sort_order then name *)
100
122
let sorted = List.sort (fun (a : Jmap.Proto.Mailbox.t) (b : Jmap.Proto.Mailbox.t) ->
101
-
let cmp = Int64.compare a.sort_order b.sort_order in
102
-
if cmp <> 0 then cmp else String.compare a.name b.name
123
+
let sort_a = Option.value ~default:0L a.sort_order in
124
+
let sort_b = Option.value ~default:0L b.sort_order in
125
+
let cmp = Int64.compare sort_a sort_b in
126
+
let name_a = Option.value ~default:"" a.name in
127
+
let name_b = Option.value ~default:"" b.name in
128
+
if cmp <> 0 then cmp else String.compare name_a name_b
103
129
) result.list in
104
130
List.iter (fun (mbox : Jmap.Proto.Mailbox.t) ->
105
131
let role_str = match mbox.role with
106
132
| Some role -> Printf.sprintf " [%s]" (Jmap.Proto.Mailbox.role_to_string role)
107
133
| None -> ""
108
134
in
135
+
let id_str = match mbox.id with
136
+
| Some id -> Jmap.Proto.Id.to_string id
137
+
| None -> "?"
138
+
in
139
+
let name = Option.value ~default:"(unnamed)" mbox.name in
140
+
let total = Option.value ~default:0L mbox.total_emails in
141
+
let unread = Option.value ~default:0L mbox.unread_emails in
109
142
Fmt.pr " %a %s%a (%Ld total, %Ld unread)@,"
110
-
Fmt.(styled `Cyan string) (Jmap.Proto.Id.to_string mbox.id)
111
-
mbox.name
143
+
Fmt.(styled `Cyan string) id_str
144
+
name
112
145
Fmt.(styled `Yellow string) role_str
113
-
mbox.total_emails mbox.unread_emails
146
+
total unread
114
147
) sorted;
115
148
Fmt.pr "@]@."
116
149
in
···
228
261
| None -> "(unknown)"
229
262
in
230
263
let subject = Option.value email.subject ~default:"(no subject)" in
231
-
let flags = format_keywords email.keywords in
264
+
let keywords = Option.value ~default:[] email.keywords in
265
+
let flags = format_keywords keywords in
232
266
let flag_str = if flags = "" then "" else " [" ^ flags ^ "]" in
267
+
let id_str = match email.id with
268
+
| Some id -> Jmap.Proto.Id.to_string id
269
+
| None -> "?"
270
+
in
271
+
let received = match email.received_at with
272
+
| Some t -> ptime_to_string t
273
+
| None -> "?"
274
+
in
275
+
let preview = Option.value ~default:"" email.preview in
233
276
Fmt.pr " %a %s@,"
234
-
Fmt.(styled `Cyan string) (Jmap.Proto.Id.to_string email.id)
235
-
(ptime_to_string email.received_at);
277
+
Fmt.(styled `Cyan string) id_str
278
+
received;
236
279
Fmt.pr " From: %s@," (truncate_string 60 from_str);
237
280
Fmt.pr " Subject: %a%s@,"
238
281
Fmt.(styled `White string) (truncate_string 60 subject)
239
282
flag_str;
240
283
Fmt.pr " Preview: %s@,@,"
241
-
(truncate_string 70 email.preview);
284
+
(truncate_string 70 preview);
242
285
) get_result.list;
243
286
Fmt.pr "@]@."
244
287
)
···
349
392
| None -> "(unknown)"
350
393
in
351
394
let subject = Option.value email.subject ~default:"(no subject)" in
395
+
let id_str = match email.id with
396
+
| Some id -> Jmap.Proto.Id.to_string id
397
+
| None -> "?"
398
+
in
399
+
let received = match email.received_at with
400
+
| Some t -> ptime_to_string t
401
+
| None -> "?"
402
+
in
403
+
let preview = Option.value ~default:"" email.preview in
352
404
Fmt.pr " %a %s@,"
353
-
Fmt.(styled `Cyan string) (Jmap.Proto.Id.to_string email.id)
354
-
(ptime_to_string email.received_at);
405
+
Fmt.(styled `Cyan string) id_str
406
+
received;
355
407
Fmt.pr " From: %s@," (truncate_string 60 from_str);
356
408
Fmt.pr " Subject: %a@,"
357
409
Fmt.(styled `White string) (truncate_string 60 subject);
358
410
Fmt.pr " Preview: %s@,@,"
359
-
(truncate_string 70 email.preview);
411
+
(truncate_string 70 preview);
360
412
) get_result.list;
361
413
Fmt.pr "@]@."
362
414
)
···
460
512
| _ -> "?"
461
513
in
462
514
let subject = Option.value email.subject ~default:"(no subject)" in
463
-
let flags = format_keywords email.keywords in
515
+
let flags = format_keywords (email_keywords email) in
464
516
Printf.printf "%s\t%s\t%s\t%s\t%s\n"
465
-
(Jmap.Proto.Id.to_string email.id)
466
-
(ptime_to_string email.received_at)
517
+
(email_id email)
518
+
(email_received_at email)
467
519
(truncate_string 20 from_str)
468
520
(truncate_string 50 subject)
469
521
flags
···
485
537
| _ -> "?"
486
538
in
487
539
let subject = Option.value email.subject ~default:"(no subject)" in
488
-
let flags = format_keywords email.keywords in
540
+
let flags = format_keywords (email_keywords email) in
489
541
let id_short =
490
-
let id = Jmap.Proto.Id.to_string email.id in
542
+
let id = email_id email in
491
543
if String.length id > 12 then String.sub id 0 12 else id
492
544
in
493
545
Fmt.pr "%-12s %s %-20s %-40s %s@,"
494
546
id_short
495
-
(ptime_to_string email.received_at)
547
+
(email_received_at email)
496
548
(truncate_string 20 from_str)
497
549
(truncate_string 40 subject)
498
550
flags
···
517
569
| None -> ""
518
570
in
519
571
let subject = Option.value email.subject ~default:"(no subject)" in
520
-
let flags = format_keywords email.keywords in
521
-
let mailbox_count = List.length email.mailbox_ids in
572
+
let flags = format_keywords (email_keywords email) in
573
+
let mailbox_count = List.length (email_mailbox_ids email) in
522
574
523
575
Fmt.pr "@[<v 2>%a Email %d of %d@,"
524
576
Fmt.(styled `Bold string) "---"
525
577
(i + 1) (List.length get_result.list);
526
578
Fmt.pr "ID: %a@,"
527
-
Fmt.(styled `Cyan string) (Jmap.Proto.Id.to_string email.id);
528
-
Fmt.pr "Thread: %s@," (Jmap.Proto.Id.to_string email.thread_id);
529
-
Fmt.pr "Date: %s@," (ptime_to_string email.received_at);
579
+
Fmt.(styled `Cyan string) (email_id email);
580
+
Fmt.pr "Thread: %s@," (email_thread_id email);
581
+
Fmt.pr "Date: %s@," (email_received_at email);
530
582
Fmt.pr "From: %s@," from_str;
531
583
if to_str <> "" then Fmt.pr "To: %s@," to_str;
532
584
if cc_str <> "" then Fmt.pr "Cc: %s@," cc_str;
533
585
Fmt.pr "Subject: %a@,"
534
586
Fmt.(styled `White string) subject;
535
-
Fmt.pr "Size: %Ld bytes@," email.size;
587
+
Fmt.pr "Size: %Ld bytes@," (email_size email);
536
588
Fmt.pr "Mailboxes: %d@," mailbox_count;
537
589
if flags <> "" then Fmt.pr "Flags: %s@," flags;
538
-
Fmt.pr "Preview: %s@]@,@," email.preview;
590
+
Fmt.pr "Preview: %s@]@,@," (email_preview email);
539
591
) get_result.list;
540
592
Fmt.pr "@]@."
541
593
)
···
557
609
let client = Jmap_eio.Cli.create_client ~sw env cfg in
558
610
let account_id = Jmap_eio.Cli.get_account_id cfg client in
559
611
560
-
let email_id = Jmap.Proto.Id.of_string_exn email_id_str in
612
+
let target_email_id = Jmap.Proto.Id.of_string_exn email_id_str in
561
613
562
614
(* First get the email to find its thread ID - include required properties *)
563
615
let get_inv = Jmap_eio.Client.Build.email_get
564
616
~call_id:"e1"
565
617
~account_id
566
-
~ids:[email_id]
618
+
~ids:[target_email_id]
567
619
~properties:["id"; "blobId"; "threadId"; "mailboxIds"; "size"; "receivedAt"]
568
620
()
569
621
in
···
588
640
Fmt.epr "Email not found: %s@." email_id_str;
589
641
exit 1
590
642
| email :: _ ->
591
-
let thread_id = email.thread_id in
643
+
let thread_id = match email.thread_id with
644
+
| Some id -> id
645
+
| None ->
646
+
Fmt.epr "Email has no thread ID@.";
647
+
exit 1
648
+
in
592
649
Jmap_eio.Cli.debug cfg "Thread ID: %s" (Jmap.Proto.Id.to_string thread_id);
593
650
594
651
(* Get the thread *)
···
619
676
Fmt.epr "Thread not found@.";
620
677
exit 1
621
678
| thread :: _ ->
622
-
let email_ids = thread.email_ids in
679
+
let thread_id_str = match thread.id with
680
+
| Some id -> Jmap.Proto.Id.to_string id
681
+
| None -> "?"
682
+
in
683
+
let email_ids = Option.value ~default:[] thread.email_ids in
623
684
Fmt.pr "@[<v>%a %s (%d emails)@,@,"
624
685
Fmt.(styled `Bold string) "Thread"
625
-
(Jmap.Proto.Id.to_string thread.id)
686
+
thread_id_str
626
687
(List.length email_ids);
627
688
628
689
(* Fetch all emails in thread *)
···
657
718
in
658
719
let subject = Option.value email.subject ~default:"(no subject)" in
659
720
Fmt.pr " %a %s@,"
660
-
Fmt.(styled `Cyan string) (Jmap.Proto.Id.to_string email.id)
661
-
(ptime_to_string email.received_at);
721
+
Fmt.(styled `Cyan string) (email_id email)
722
+
(email_received_at email);
662
723
Fmt.pr " From: %s@," (truncate_string 60 from_str);
663
724
Fmt.pr " Subject: %a@,@,"
664
725
Fmt.(styled `White string) (truncate_string 60 subject);
···
701
762
Fmt.(styled `Bold string) "Identities"
702
763
result.state;
703
764
List.iter (fun (ident : Jmap.Proto.Identity.t) ->
765
+
let ident_id = match ident.id with Some id -> Jmap.Proto.Id.to_string id | None -> "?" in
766
+
let ident_name = Option.value ~default:"(unnamed)" ident.name in
767
+
let ident_email = Option.value ~default:"(no email)" ident.email in
768
+
let ident_sig = Option.value ~default:"" ident.text_signature in
769
+
let ident_may_delete = Option.value ~default:false ident.may_delete in
704
770
Fmt.pr " %a@,"
705
-
Fmt.(styled `Cyan string) (Jmap.Proto.Id.to_string ident.id);
706
-
Fmt.pr " Name: %s@," ident.name;
771
+
Fmt.(styled `Cyan string) ident_id;
772
+
Fmt.pr " Name: %s@," ident_name;
707
773
Fmt.pr " Email: %a@,"
708
-
Fmt.(styled `Green string) ident.email;
709
-
if ident.text_signature <> "" then
710
-
Fmt.pr " Signature: %s@," (truncate_string 50 ident.text_signature);
711
-
Fmt.pr " May delete: %b@,@," ident.may_delete
774
+
Fmt.(styled `Green string) ident_email;
775
+
if ident_sig <> "" then
776
+
Fmt.pr " Signature: %s@," (truncate_string 50 ident_sig);
777
+
Fmt.pr " May delete: %b@,@," ident_may_delete
712
778
) result.list;
713
779
Fmt.pr "@]@."
714
780
in
···
760
826
Fmt.epr "No inbox found@.";
761
827
exit 1
762
828
| Some inbox ->
763
-
Jmap_eio.Cli.debug cfg "Found inbox: %s" (Jmap.Proto.Id.to_string inbox.id);
829
+
let inbox_id = match inbox.id with
830
+
| Some id -> id
831
+
| None ->
832
+
Fmt.epr "Inbox has no ID@.";
833
+
exit 1
834
+
in
835
+
Jmap_eio.Cli.debug cfg "Found inbox: %s" (Jmap.Proto.Id.to_string inbox_id);
764
836
765
837
(* Now use Chain API to query and get emails in one request *)
766
838
let open Jmap_eio.Chain in
767
839
let filter_cond : Jmap.Proto.Email.Filter_condition.t = {
768
-
in_mailbox = Some inbox.id;
840
+
in_mailbox = Some inbox_id;
769
841
in_mailbox_other_than = None;
770
842
before = None; after = None;
771
843
min_size = None; max_size = None;
···
819
891
| _ -> "?"
820
892
in
821
893
let subject = Option.value email.subject ~default:"(no subject)" in
822
-
let flags = format_keywords email.keywords in
894
+
let flags = format_keywords (email_keywords email) in
823
895
Fmt.pr " %a %s@,"
824
-
Fmt.(styled `Cyan string) (Jmap.Proto.Id.to_string email.id)
825
-
(ptime_to_string email.received_at);
896
+
Fmt.(styled `Cyan string) (email_id email)
897
+
(email_received_at email);
826
898
Fmt.pr " From: %s@," (truncate_string 40 from_str);
827
899
Fmt.pr " Subject: %a%s@,"
828
900
Fmt.(styled `White string) (truncate_string 50 subject)
···
902
974
(* Group emails by thread *)
903
975
let threads_map = Hashtbl.create 16 in
904
976
List.iter (fun (email : Jmap.Proto.Email.t) ->
905
-
let tid = Jmap.Proto.Id.to_string email.thread_id in
977
+
let tid = email_thread_id email in
906
978
let existing = try Hashtbl.find threads_map tid with Not_found -> [] in
907
979
Hashtbl.replace threads_map tid (email :: existing)
908
980
) emails_result.list;
···
917
989
(* Print threads *)
918
990
Hashtbl.iter (fun _tid emails ->
919
991
let emails = List.sort (fun (a : Jmap.Proto.Email.t) (b : Jmap.Proto.Email.t) ->
920
-
Ptime.compare a.received_at b.received_at
992
+
let a_time = Option.value ~default:Ptime.epoch a.received_at in
993
+
let b_time = Option.value ~default:Ptime.epoch b.received_at in
994
+
Ptime.compare a_time b_time
921
995
) emails in
922
996
let first_email = List.hd emails in
923
997
let subject = Option.value first_email.subject ~default:"(no subject)" in
···
931
1005
| _ -> "?"
932
1006
in
933
1007
Fmt.pr " %s %s %s@,"
934
-
(Jmap.Proto.Id.to_string email.id |> truncate_string 12)
935
-
(ptime_to_string email.received_at)
1008
+
(email_id email |> truncate_string 12)
1009
+
(email_received_at email)
936
1010
(truncate_string 30 from_str)
937
1011
) emails;
938
1012
Fmt.pr "@,"
···
1213
1287
in
1214
1288
let subject = Option.value email.subject ~default:"(no subject)" in
1215
1289
Fmt.pr " + %s %s %s@,"
1216
-
(Jmap.Proto.Id.to_string email.id |> truncate_string 12)
1290
+
(email_id email |> truncate_string 12)
1217
1291
(truncate_string 20 from_str)
1218
1292
(truncate_string 40 subject)
1219
1293
) created_result.list;
···
1225
1299
Fmt.(styled `Yellow string) "Updated emails"
1226
1300
(List.length updated_result.list);
1227
1301
List.iter (fun (email : Jmap.Proto.Email.t) ->
1228
-
let flags = format_keywords email.keywords in
1302
+
let flags = format_keywords (email_keywords email) in
1229
1303
Fmt.pr " ~ %s [%s]@,"
1230
-
(Jmap.Proto.Id.to_string email.id |> truncate_string 12)
1304
+
(email_id email |> truncate_string 12)
1231
1305
flags
1232
1306
) updated_result.list;
1233
1307
Fmt.pr "@,"
···
1254
1328
let info = Cmd.info "sync" ~doc in
1255
1329
Cmd.v info Term.(const run $ Jmap_eio.Cli.config_term $ state_term)
1256
1330
1331
+
(** Headers command - demonstrates RFC 8621 §4.1 header property queries *)
1332
+
let headers_cmd =
1333
+
let email_id_term =
1334
+
let doc = "Email ID to get headers for" in
1335
+
Arg.(required & pos 0 (some string) None & info [] ~docv:"EMAIL_ID" ~doc)
1336
+
in
1337
+
1338
+
(* Format a header value for display *)
1339
+
let format_header_value = function
1340
+
| Jmap.Proto.Email_header.String_single None -> "(null)"
1341
+
| Jmap.Proto.Email_header.String_single (Some s) -> s
1342
+
| Jmap.Proto.Email_header.String_all [] -> "(empty list)"
1343
+
| Jmap.Proto.Email_header.String_all strs -> String.concat "; " strs
1344
+
| Jmap.Proto.Email_header.Addresses_single None -> "(null)"
1345
+
| Jmap.Proto.Email_header.Addresses_single (Some []) -> "(empty)"
1346
+
| Jmap.Proto.Email_header.Addresses_single (Some addrs) ->
1347
+
String.concat ", " (List.map (fun a ->
1348
+
match a.Jmap.Proto.Email_address.name with
1349
+
| Some n -> Printf.sprintf "%s <%s>" n a.email
1350
+
| None -> a.email
1351
+
) addrs)
1352
+
| Jmap.Proto.Email_header.Addresses_all [] -> "(empty list)"
1353
+
| Jmap.Proto.Email_header.Addresses_all groups ->
1354
+
String.concat " | " (List.map (fun addrs ->
1355
+
String.concat ", " (List.map (fun a ->
1356
+
match a.Jmap.Proto.Email_address.name with
1357
+
| Some n -> Printf.sprintf "%s <%s>" n a.email
1358
+
| None -> a.email
1359
+
) addrs)
1360
+
) groups)
1361
+
| Jmap.Proto.Email_header.Grouped_single None -> "(null)"
1362
+
| Jmap.Proto.Email_header.Grouped_single (Some groups) ->
1363
+
String.concat "; " (List.map (fun g ->
1364
+
let name = Option.value ~default:"(ungrouped)" g.Jmap.Proto.Email_address.Group.name in
1365
+
let addrs = String.concat ", " (List.map (fun a ->
1366
+
match a.Jmap.Proto.Email_address.name with
1367
+
| Some n -> Printf.sprintf "%s <%s>" n a.email
1368
+
| None -> a.email
1369
+
) g.addresses) in
1370
+
Printf.sprintf "%s: %s" name addrs
1371
+
) groups)
1372
+
| Jmap.Proto.Email_header.Grouped_all _ -> "(grouped addresses list)"
1373
+
| Jmap.Proto.Email_header.Date_single None -> "(null)"
1374
+
| Jmap.Proto.Email_header.Date_single (Some t) -> ptime_to_string t
1375
+
| Jmap.Proto.Email_header.Date_all [] -> "(empty list)"
1376
+
| Jmap.Proto.Email_header.Date_all dates ->
1377
+
String.concat "; " (List.map (function
1378
+
| None -> "(null)"
1379
+
| Some t -> ptime_to_string t
1380
+
) dates)
1381
+
| Jmap.Proto.Email_header.Strings_single None -> "(null)"
1382
+
| Jmap.Proto.Email_header.Strings_single (Some []) -> "(empty)"
1383
+
| Jmap.Proto.Email_header.Strings_single (Some strs) -> String.concat ", " strs
1384
+
| Jmap.Proto.Email_header.Strings_all [] -> "(empty list)"
1385
+
| Jmap.Proto.Email_header.Strings_all groups ->
1386
+
String.concat " | " (List.map (function
1387
+
| None -> "(null)"
1388
+
| Some strs -> String.concat ", " strs
1389
+
) groups)
1390
+
in
1391
+
1392
+
let run cfg email_id_str =
1393
+
Eio_main.run @@ fun env ->
1394
+
Eio.Switch.run @@ fun sw ->
1395
+
let client = Jmap_eio.Cli.create_client ~sw env cfg in
1396
+
let account_id = Jmap_eio.Cli.get_account_id cfg client in
1397
+
let target_email_id = Jmap.Proto.Id.of_string_exn email_id_str in
1398
+
1399
+
Jmap_eio.Cli.debug cfg "Fetching headers for email %s" email_id_str;
1400
+
1401
+
(* Demonstrate various header forms from RFC 8621 §4.1.2:
1402
+
- header:name - Raw value
1403
+
- header:name:asText - Text decoded
1404
+
- header:name:asAddresses - Address list
1405
+
- header:name:asGroupedAddresses - Address groups
1406
+
- header:name:asMessageIds - Message-ID list
1407
+
- header:name:asDate - RFC 3339 date
1408
+
- header:name:asURLs - URL list
1409
+
- header:name:all - All values (not just first)
1410
+
*)
1411
+
let header_props = [
1412
+
(* Raw and text forms *)
1413
+
"header:Subject";
1414
+
"header:Subject:asText";
1415
+
(* Address headers *)
1416
+
"header:From:asAddresses";
1417
+
"header:To:asAddresses";
1418
+
"header:Cc:asAddresses";
1419
+
"header:Bcc:asAddresses";
1420
+
"header:Reply-To:asAddresses";
1421
+
"header:Sender:asAddresses";
1422
+
(* Grouped addresses *)
1423
+
"header:From:asGroupedAddresses";
1424
+
(* Message ID headers *)
1425
+
"header:Message-ID:asMessageIds";
1426
+
"header:In-Reply-To:asMessageIds";
1427
+
"header:References:asMessageIds";
1428
+
(* Date header *)
1429
+
"header:Date:asDate";
1430
+
(* List headers as URLs *)
1431
+
"header:List-Unsubscribe:asURLs";
1432
+
"header:List-Post:asURLs";
1433
+
"header:List-Archive:asURLs";
1434
+
(* Custom headers *)
1435
+
"header:X-Mailer:asText";
1436
+
"header:X-Priority";
1437
+
"header:X-Spam-Status:asText";
1438
+
"header:Content-Type";
1439
+
"header:MIME-Version";
1440
+
(* Get all Received headers (typically multiple) *)
1441
+
"header:Received:all";
1442
+
] in
1443
+
1444
+
let properties = "id" :: "threadId" :: "subject" :: header_props in
1445
+
1446
+
let get_inv = Jmap_eio.Client.Build.email_get
1447
+
~call_id:"h1"
1448
+
~account_id
1449
+
~ids:[target_email_id]
1450
+
~properties
1451
+
()
1452
+
in
1453
+
let req = Jmap_eio.Client.Build.(
1454
+
make_request
1455
+
~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail]
1456
+
[get_inv]
1457
+
) in
1458
+
1459
+
match Jmap_eio.Client.request client req with
1460
+
| Error e ->
1461
+
Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e);
1462
+
exit 1
1463
+
| Ok response ->
1464
+
match Jmap_eio.Client.Parse.parse_email_get ~call_id:"h1" response with
1465
+
| Error e ->
1466
+
Fmt.epr "Parse error: %s@." (Jsont.Error.to_string e);
1467
+
exit 1
1468
+
| Ok email_result ->
1469
+
match email_result.list with
1470
+
| [] ->
1471
+
Fmt.epr "Email not found: %s@." email_id_str;
1472
+
exit 1
1473
+
| email :: _ ->
1474
+
Fmt.pr "@[<v>%a@," Fmt.(styled `Bold string) "Email Headers (RFC 8621 §4.1)";
1475
+
Fmt.pr "ID: %s@," (email_id email);
1476
+
Fmt.pr "Thread: %s@," (email_thread_id email);
1477
+
(match email.subject with
1478
+
| Some s -> Fmt.pr "Subject (convenience): %s@," s
1479
+
| None -> ());
1480
+
Fmt.pr "@,";
1481
+
1482
+
(* Print dynamic headers grouped by category *)
1483
+
let raw_headers = Jmap.Proto.Email.dynamic_headers_raw email in
1484
+
if raw_headers = [] then
1485
+
Fmt.pr "%a@," Fmt.(styled `Yellow string) "No dynamic headers returned"
1486
+
else begin
1487
+
Fmt.pr "%a (%d properties)@,@,"
1488
+
Fmt.(styled `Bold string) "Dynamic Header Properties"
1489
+
(List.length raw_headers);
1490
+
1491
+
List.iter (fun (name, json) ->
1492
+
match Jmap.Proto.Email.decode_header_value name json with
1493
+
| None ->
1494
+
Fmt.pr " %a: (decode failed)@,"
1495
+
Fmt.(styled `Red string) name
1496
+
| Some value ->
1497
+
let formatted = format_header_value value in
1498
+
if String.length formatted > 80 then
1499
+
Fmt.pr " %a:@, %s@,"
1500
+
Fmt.(styled `Cyan string) name
1501
+
formatted
1502
+
else
1503
+
Fmt.pr " %a: %s@,"
1504
+
Fmt.(styled `Cyan string) name
1505
+
formatted
1506
+
) raw_headers
1507
+
end;
1508
+
Fmt.pr "@]@."
1509
+
in
1510
+
let doc = "Show email headers in various forms (demonstrates RFC 8621 §4.1)" in
1511
+
let info = Cmd.info "headers" ~doc in
1512
+
Cmd.v info Term.(const run $ Jmap_eio.Cli.config_term $ email_id_term)
1513
+
1257
1514
(** {1 Main Command Group} *)
1258
1515
1259
1516
let main_cmd =
···
1280
1537
recent_cmd;
1281
1538
threads_cmd;
1282
1539
identities_cmd;
1540
+
headers_cmd;
1283
1541
(* Chain API examples *)
1284
1542
inbox_cmd;
1285
1543
thread_view_cmd;
+434
bin/jmapq.ml
+434
bin/jmapq.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** JMAPQ - Specialist JMAP workflow commands *)
7
+
8
+
open Cmdliner
9
+
10
+
(** {1 Helpers} *)
11
+
12
+
let ptime_to_string t =
13
+
let (y, m, d), ((hh, mm, ss), _tz) = Ptime.to_date_time t in
14
+
Printf.sprintf "%04d-%02d-%02d %02d:%02d:%02d" y m d hh mm ss
15
+
16
+
let truncate_string max_len s =
17
+
if String.length s <= max_len then s
18
+
else String.sub s 0 (max_len - 3) ^ "..."
19
+
20
+
(** {1 Zulip Types and Codec} *)
21
+
22
+
(** Parsed information from a Zulip notification email subject.
23
+
Subject format: "#Channel > topic [Server Name]" *)
24
+
module Zulip_message = struct
25
+
type t = {
26
+
id : string;
27
+
date : Ptime.t;
28
+
thread_id : string;
29
+
channel : string;
30
+
topic : string;
31
+
server : string;
32
+
is_read : bool;
33
+
labels : string list;
34
+
}
35
+
36
+
(** Parse a Zulip subject line of the form "#Channel > topic [Server Name]" *)
37
+
let parse_subject subject =
38
+
(* Pattern: #<channel> > <topic> [<server>] *)
39
+
let channel_re = Re.Pcre.regexp {|^#(.+?)\s*>\s*(.+?)\s*\[(.+?)\]$|} in
40
+
match Re.exec_opt channel_re subject with
41
+
| Some groups ->
42
+
let channel = Re.Group.get groups 1 in
43
+
let topic = Re.Group.get groups 2 in
44
+
let server = Re.Group.get groups 3 in
45
+
Some (channel, topic, server)
46
+
| None -> None
47
+
48
+
(** Check if an email has the $seen keyword *)
49
+
let is_seen keywords =
50
+
List.exists (fun (k, v) -> k = "$seen" && v) keywords
51
+
52
+
(** Extract label strings from keywords, excluding standard JMAP keywords *)
53
+
let extract_labels keywords =
54
+
keywords
55
+
|> List.filter_map (fun (k, v) ->
56
+
if v && not (String.length k > 0 && k.[0] = '$') then
57
+
Some k
58
+
else if v && k = "$flagged" then
59
+
Some "flagged"
60
+
else
61
+
None)
62
+
63
+
(** Create a Zulip_message from a JMAP Email *)
64
+
let of_email (email : Jmap.Proto.Email.t) : t option =
65
+
let id = match email.id with
66
+
| Some id -> Jmap.Proto.Id.to_string id
67
+
| None -> ""
68
+
in
69
+
let date = match email.received_at with
70
+
| Some t -> t
71
+
| None -> Ptime.epoch
72
+
in
73
+
let thread_id = match email.thread_id with
74
+
| Some id -> Jmap.Proto.Id.to_string id
75
+
| None -> ""
76
+
in
77
+
let subject = Option.value ~default:"" email.subject in
78
+
match parse_subject subject with
79
+
| None -> None
80
+
| Some (channel, topic, server) ->
81
+
let keywords = Option.value ~default:[] email.keywords in
82
+
let is_read = is_seen keywords in
83
+
let labels = extract_labels keywords in
84
+
Some { id; date; thread_id; channel; topic; server; is_read; labels }
85
+
86
+
(** Jsont codec for Ptime.t - reuse the library's UTC date codec *)
87
+
let ptime_jsont : Ptime.t Jsont.t = Jmap.Proto.Date.Utc.jsont
88
+
89
+
(** Jsont codec for a single Zulip message *)
90
+
let jsont : t Jsont.t =
91
+
let kind = "ZulipMessage" in
92
+
let make id date thread_id channel topic server is_read labels =
93
+
{ id; date; thread_id; channel; topic; server; is_read; labels }
94
+
in
95
+
Jsont.Object.map ~kind make
96
+
|> Jsont.Object.mem "id" Jsont.string ~enc:(fun t -> t.id)
97
+
|> Jsont.Object.mem "date" ptime_jsont ~enc:(fun t -> t.date)
98
+
|> Jsont.Object.mem "thread_id" Jsont.string ~enc:(fun t -> t.thread_id)
99
+
|> Jsont.Object.mem "channel" Jsont.string ~enc:(fun t -> t.channel)
100
+
|> Jsont.Object.mem "topic" Jsont.string ~enc:(fun t -> t.topic)
101
+
|> Jsont.Object.mem "server" Jsont.string ~enc:(fun t -> t.server)
102
+
|> Jsont.Object.mem "is_read" Jsont.bool ~enc:(fun t -> t.is_read)
103
+
|> Jsont.Object.mem "labels" (Jsont.list Jsont.string) ~enc:(fun t -> t.labels)
104
+
|> Jsont.Object.finish
105
+
106
+
(** Jsont codec for a list of Zulip messages *)
107
+
let list_jsont : t list Jsont.t = Jsont.list jsont
108
+
end
109
+
110
+
(** {1 Zulip List Command} *)
111
+
112
+
let zulip_list_cmd =
113
+
let json_term =
114
+
let doc = "Output as JSON" in
115
+
Arg.(value & flag & info ["json"] ~doc)
116
+
in
117
+
let limit_term =
118
+
let doc = "Maximum number of messages to fetch (default: all)" in
119
+
Arg.(value & opt (some int) None & info ["limit"; "n"] ~docv:"N" ~doc)
120
+
in
121
+
let run cfg json_output limit =
122
+
Eio_main.run @@ fun env ->
123
+
Eio.Switch.run @@ fun sw ->
124
+
let client = Jmap_eio.Cli.create_client ~sw env cfg in
125
+
let account_id = Jmap_eio.Cli.get_account_id cfg client in
126
+
127
+
Jmap_eio.Cli.debug cfg "Searching for Zulip notification emails";
128
+
129
+
(* Build filter for emails from noreply@zulip.com *)
130
+
let cond : Jmap.Proto.Email.Filter_condition.t = {
131
+
in_mailbox = None; in_mailbox_other_than = None;
132
+
before = None; after = None;
133
+
min_size = None; max_size = None;
134
+
all_in_thread_have_keyword = None;
135
+
some_in_thread_have_keyword = None;
136
+
none_in_thread_have_keyword = None;
137
+
has_keyword = None; not_keyword = None;
138
+
has_attachment = None;
139
+
text = None;
140
+
from = Some "noreply@zulip.com";
141
+
to_ = None;
142
+
cc = None; bcc = None; subject = None;
143
+
body = None; header = None;
144
+
} in
145
+
let filter = Jmap.Proto.Filter.Condition cond in
146
+
let sort = [Jmap.Proto.Filter.comparator ~is_ascending:false "receivedAt"] in
147
+
148
+
(* Query for all Zulip emails *)
149
+
let query_limit = match limit with
150
+
| Some n -> Int64.of_int n
151
+
| None -> Int64.of_int 10000 (* Large default to get "all" *)
152
+
in
153
+
let query_inv = Jmap_eio.Client.Build.email_query
154
+
~call_id:"q1"
155
+
~account_id
156
+
~filter
157
+
~sort
158
+
~limit:query_limit
159
+
()
160
+
in
161
+
162
+
let req = Jmap_eio.Client.Build.(
163
+
make_request
164
+
~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail]
165
+
[query_inv]
166
+
) in
167
+
168
+
match Jmap_eio.Client.request client req with
169
+
| Error e ->
170
+
Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e);
171
+
exit 1
172
+
| Ok response ->
173
+
match Jmap_eio.Client.Parse.parse_email_query ~call_id:"q1" response with
174
+
| Error e ->
175
+
Fmt.epr "Parse error: %s@." (Jsont.Error.to_string e);
176
+
exit 1
177
+
| Ok query_result ->
178
+
let email_ids = query_result.ids in
179
+
Jmap_eio.Cli.debug cfg "Found %d Zulip email IDs" (List.length email_ids);
180
+
181
+
if List.length email_ids = 0 then (
182
+
if json_output then
183
+
Fmt.pr "[]@."
184
+
else
185
+
Fmt.pr "No Zulip notification emails found.@."
186
+
) else (
187
+
(* Fetch email details *)
188
+
let get_inv = Jmap_eio.Client.Build.email_get
189
+
~call_id:"g1"
190
+
~account_id
191
+
~ids:email_ids
192
+
~properties:["id"; "blobId"; "threadId"; "mailboxIds"; "keywords";
193
+
"size"; "receivedAt"; "subject"; "from"]
194
+
()
195
+
in
196
+
let req2 = Jmap_eio.Client.Build.(
197
+
make_request
198
+
~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail]
199
+
[get_inv]
200
+
) in
201
+
202
+
match Jmap_eio.Client.request client req2 with
203
+
| Error e ->
204
+
Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e);
205
+
exit 1
206
+
| Ok response2 ->
207
+
match Jmap_eio.Client.Parse.parse_email_get ~call_id:"g1" response2 with
208
+
| Error e ->
209
+
Fmt.epr "Parse error: %s@." (Jsont.Error.to_string e);
210
+
exit 1
211
+
| Ok get_result ->
212
+
(* Parse Zulip subjects and filter successful parses *)
213
+
let zulip_messages =
214
+
get_result.list
215
+
|> List.filter_map Zulip_message.of_email
216
+
in
217
+
218
+
Jmap_eio.Cli.debug cfg "Parsed %d Zulip messages from %d emails"
219
+
(List.length zulip_messages)
220
+
(List.length get_result.list);
221
+
222
+
if json_output then (
223
+
(* Output as JSON *)
224
+
match Jsont_bytesrw.encode_string' ~format:Jsont.Indent Zulip_message.list_jsont zulip_messages with
225
+
| Ok json_str -> Fmt.pr "%s@." json_str
226
+
| Error e -> Fmt.epr "JSON encoding error: %s@." (Jsont.Error.to_string e)
227
+
) else (
228
+
(* Human-readable output *)
229
+
Fmt.pr "@[<v>%a (%d messages)@,@,"
230
+
Fmt.(styled `Bold string) "Zulip Notifications"
231
+
(List.length zulip_messages);
232
+
233
+
(* Group by server, then by channel *)
234
+
let by_server = Hashtbl.create 8 in
235
+
List.iter (fun (msg : Zulip_message.t) ->
236
+
let existing = try Hashtbl.find by_server msg.server with Not_found -> [] in
237
+
Hashtbl.replace by_server msg.server (msg :: existing)
238
+
) zulip_messages;
239
+
240
+
Hashtbl.iter (fun server msgs ->
241
+
Fmt.pr "%a [%s]@,"
242
+
Fmt.(styled `Bold string) "Server:"
243
+
server;
244
+
245
+
(* Group by channel within server *)
246
+
let by_channel = Hashtbl.create 8 in
247
+
List.iter (fun (msg : Zulip_message.t) ->
248
+
let existing = try Hashtbl.find by_channel msg.channel with Not_found -> [] in
249
+
Hashtbl.replace by_channel msg.channel (msg :: existing)
250
+
) msgs;
251
+
252
+
Hashtbl.iter (fun channel channel_msgs ->
253
+
Fmt.pr " %a #%s (%d)@,"
254
+
Fmt.(styled `Cyan string) "Channel:"
255
+
channel
256
+
(List.length channel_msgs);
257
+
258
+
(* Sort by date descending *)
259
+
let sorted = List.sort (fun a b ->
260
+
Ptime.compare b.Zulip_message.date a.Zulip_message.date
261
+
) channel_msgs in
262
+
263
+
List.iter (fun (msg : Zulip_message.t) ->
264
+
let read_marker = if msg.is_read then " " else "*" in
265
+
let labels_str = match msg.labels with
266
+
| [] -> ""
267
+
| ls -> " [" ^ String.concat ", " ls ^ "]"
268
+
in
269
+
Fmt.pr " %s %s %a %s%s@,"
270
+
read_marker
271
+
(ptime_to_string msg.date)
272
+
Fmt.(styled `Yellow string) (truncate_string 40 msg.topic)
273
+
(truncate_string 12 msg.id)
274
+
labels_str
275
+
) sorted;
276
+
Fmt.pr "@,"
277
+
) by_channel
278
+
) by_server;
279
+
280
+
Fmt.pr "@]@."
281
+
)
282
+
)
283
+
in
284
+
let doc = "List Zulip notification emails with parsed channel/topic info" in
285
+
let man = [
286
+
`S Manpage.s_description;
287
+
`P "Lists all emails from noreply@zulip.com and parses the subject line to extract \
288
+
the Zulip channel, topic, and server name.";
289
+
`P "Subject format expected: \"#Channel > topic [Server Name]\"";
290
+
`S Manpage.s_examples;
291
+
`P "List all Zulip notifications:";
292
+
`Pre " jmapq zulip-list";
293
+
`P "Output as JSON:";
294
+
`Pre " jmapq zulip-list --json";
295
+
`P "Limit to 50 most recent:";
296
+
`Pre " jmapq zulip-list -n 50";
297
+
] in
298
+
let info = Cmd.info "zulip-list" ~doc ~man in
299
+
Cmd.v info Term.(const run $ Jmap_eio.Cli.config_term $ json_term $ limit_term)
300
+
301
+
(** {1 Zulip Timeout Command} *)
302
+
303
+
(** The keyword used to mark Zulip notifications as processed *)
304
+
let zulip_processed_keyword = "zulip-processed"
305
+
306
+
let zulip_timeout_cmd =
307
+
let email_ids_term =
308
+
let doc = "Email IDs to mark as processed" in
309
+
Arg.(non_empty & pos_all string [] & info [] ~docv:"EMAIL_ID" ~doc)
310
+
in
311
+
let run cfg email_id_strs =
312
+
Eio_main.run @@ fun env ->
313
+
Eio.Switch.run @@ fun sw ->
314
+
let client = Jmap_eio.Cli.create_client ~sw env cfg in
315
+
let account_id = Jmap_eio.Cli.get_account_id cfg client in
316
+
let email_ids = List.map Jmap.Proto.Id.of_string_exn email_id_strs in
317
+
318
+
Jmap_eio.Cli.debug cfg "Marking %d email(s) with '%s' keyword"
319
+
(List.length email_ids) zulip_processed_keyword;
320
+
321
+
(* Build patch to add the zulip-processed keyword *)
322
+
let patch =
323
+
let open Jmap_eio.Chain in
324
+
json_obj [("keywords/" ^ zulip_processed_keyword, json_bool true)]
325
+
in
326
+
327
+
(* Build updates list: each email ID gets the same patch *)
328
+
let updates = List.map (fun id -> (id, patch)) email_ids in
329
+
330
+
let open Jmap_eio.Chain in
331
+
let request, set_h = build
332
+
~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail]
333
+
begin
334
+
email_set ~account_id
335
+
~update:updates
336
+
()
337
+
end in
338
+
339
+
match Jmap_eio.Client.request client request with
340
+
| Error e ->
341
+
Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e);
342
+
exit 1
343
+
| Ok response ->
344
+
(* Check for JMAP method-level errors first *)
345
+
let call_id = Jmap_eio.Chain.call_id set_h in
346
+
(match Jmap.Proto.Response.find_response call_id response with
347
+
| None ->
348
+
Fmt.epr "Error: No response found for call_id %s@." call_id;
349
+
exit 1
350
+
| Some inv when Jmap.Proto.Response.is_error inv ->
351
+
(match Jmap.Proto.Response.get_error inv with
352
+
| Some err ->
353
+
Fmt.epr "JMAP Error: %s%s@."
354
+
(Jmap.Proto.Error.method_error_type_to_string err.type_)
355
+
(match err.description with Some d -> " - " ^ d | None -> "");
356
+
exit 1
357
+
| None ->
358
+
Fmt.epr "JMAP Error: Unknown error@.";
359
+
exit 1)
360
+
| Some _ ->
361
+
match parse set_h response with
362
+
| Error e ->
363
+
Fmt.epr "Parse error: %s@." (Jsont.Error.to_string e);
364
+
exit 1
365
+
| Ok result ->
366
+
(* Report successes *)
367
+
let updated_ids =
368
+
result.updated
369
+
|> Option.value ~default:[]
370
+
|> List.map (fun (id, _) -> Jmap.Proto.Id.to_string id)
371
+
in
372
+
if List.length updated_ids > 0 then begin
373
+
Fmt.pr "@[<v>%a %d email(s) with '%s':@,"
374
+
Fmt.(styled `Green string) "Marked"
375
+
(List.length updated_ids)
376
+
zulip_processed_keyword;
377
+
List.iter (fun id -> Fmt.pr " %s@," id) updated_ids;
378
+
Fmt.pr "@]@."
379
+
end;
380
+
381
+
(* Report failures *)
382
+
let not_updated = Option.value ~default:[] result.not_updated in
383
+
if not_updated <> [] then begin
384
+
Fmt.epr "@[<v>%a to mark %d email(s):@,"
385
+
Fmt.(styled `Red string) "Failed"
386
+
(List.length not_updated);
387
+
List.iter (fun (id, err) ->
388
+
let open Jmap.Proto.Error in
389
+
let err_type = set_error_type_to_string err.type_ in
390
+
let err_desc = Option.value ~default:"" err.description in
391
+
Fmt.epr " %s: %s%s@,"
392
+
(Jmap.Proto.Id.to_string id)
393
+
err_type
394
+
(if err_desc = "" then "" else " - " ^ err_desc)
395
+
) not_updated;
396
+
Fmt.epr "@]@.";
397
+
exit 1
398
+
end)
399
+
in
400
+
let doc = "Mark Zulip notification emails as processed" in
401
+
let man = [
402
+
`S Manpage.s_description;
403
+
`P (Printf.sprintf "Adds the '%s' keyword to the specified email(s). \
404
+
This keyword can be used to filter processed Zulip notifications \
405
+
or set up server-side rules to auto-archive them."
406
+
zulip_processed_keyword);
407
+
`S Manpage.s_examples;
408
+
`P "Mark a single email as processed:";
409
+
`Pre " jmapq zulip-timeout StrrDTS_WEa3";
410
+
`P "Mark multiple emails as processed:";
411
+
`Pre " jmapq zulip-timeout StrrDTS_WEa3 StrsGZ7P8Dpc StrsGuCSXJ3Z";
412
+
] in
413
+
let info = Cmd.info "zulip-timeout" ~doc ~man in
414
+
Cmd.v info Term.(const run $ Jmap_eio.Cli.config_term $ email_ids_term)
415
+
416
+
(** {1 Main Command Group} *)
417
+
418
+
let main_cmd =
419
+
let doc = "JMAPQ - Specialist JMAP workflow commands" in
420
+
let man = [
421
+
`S Manpage.s_description;
422
+
`P "A collection of specialist workflow commands for JMAP email processing.";
423
+
`S Manpage.s_environment;
424
+
`P Jmap_eio.Cli.env_docs;
425
+
] in
426
+
let info = Cmd.info "jmapq" ~version:"0.1.0" ~doc ~man in
427
+
Cmd.group info [
428
+
zulip_list_cmd;
429
+
zulip_timeout_cmd;
430
+
]
431
+
432
+
let () =
433
+
Fmt_tty.setup_std_outputs ();
434
+
exit (Cmd.eval main_cmd)
+7
doc/dune
+7
doc/dune
+13
doc/index.mld
+13
doc/index.mld
···
1
+
{0 jmap}
2
+
3
+
{!modules: Jmap Jmap_top}
4
+
5
+
{1 Tutorial}
6
+
7
+
See the {!page-tutorial} for a comprehensive guide to using JMAP with OCaml,
8
+
including how types map to JSON and practical examples.
9
+
10
+
{1 Browser Support}
11
+
12
+
For browser-based applications, see the [jmap-brr] package which provides
13
+
a JMAP client using the Brr library and js_of_ocaml.
+494
doc/tutorial.mld
+494
doc/tutorial.mld
···
1
+
{0 JMAP Tutorial}
2
+
3
+
This tutorial introduces JMAP (JSON Meta Application Protocol) and
4
+
demonstrates the [jmap] OCaml library through interactive examples. JMAP
5
+
is defined in {{:https://www.rfc-editor.org/rfc/rfc8620}RFC 8620} (core)
6
+
and {{:https://www.rfc-editor.org/rfc/rfc8621}RFC 8621} (mail).
7
+
8
+
{1 What is JMAP?}
9
+
10
+
JMAP is a modern, efficient protocol for synchronizing mail and other
11
+
data. It's designed as a better alternative to IMAP, addressing many of
12
+
IMAP's limitations:
13
+
14
+
{ul
15
+
{- {b Stateless over HTTP}: Unlike IMAP's persistent TCP connections, JMAP
16
+
uses standard HTTP POST requests with JSON payloads.}
17
+
{- {b Efficient batching}: Multiple operations can be combined into a single
18
+
request, reducing round-trips.}
19
+
{- {b Result references}: The output of one method call can be used as input
20
+
to another in the same request.}
21
+
{- {b Push support}: Built-in mechanisms for real-time notifications.}
22
+
{- {b Binary data handling}: Separate upload/download endpoints for large
23
+
attachments.}}
24
+
25
+
The core protocol (RFC 8620) defines the general structure, while RFC 8621
26
+
extends it specifically for email, mailboxes, threads, and related objects.
27
+
28
+
{1 Setup}
29
+
30
+
First, let's set up our environment. In the toplevel, load the library
31
+
with [#require "jmap.top";;] which will automatically install pretty
32
+
printers.
33
+
34
+
{@ocaml[
35
+
# Jmap_top.install ();;
36
+
- : unit = ()
37
+
# open Jmap;;
38
+
]}
39
+
40
+
For parsing and encoding JSON, we'll use some helper functions:
41
+
42
+
{@ocaml[
43
+
# let parse_json s =
44
+
match Jsont_bytesrw.decode_string Jsont.json s with
45
+
| Ok json -> json
46
+
| Error e -> failwith e;;
47
+
val parse_json : string -> Jsont.json = <fun>
48
+
# let json_to_string json =
49
+
match Jsont_bytesrw.encode_string ~format:Jsont.Indent Jsont.json json with
50
+
| Ok s -> s
51
+
| Error e -> failwith e;;
52
+
val json_to_string : Jsont.json -> string = <fun>
53
+
]}
54
+
55
+
{1 JMAP Identifiers}
56
+
57
+
From {{:https://www.rfc-editor.org/rfc/rfc8620#section-1.2}RFC 8620 Section 1.2}:
58
+
59
+
{i An "Id" is a String of at least 1 and a maximum of 255 octets in size,
60
+
and it MUST only contain characters from the "URL and Filename Safe"
61
+
base64 alphabet.}
62
+
63
+
The {!Jmap.Id} module provides type-safe identifiers:
64
+
65
+
{@ocaml[
66
+
# let id = Id.of_string_exn "abc123";;
67
+
val id : Id.t = abc123
68
+
# Id.to_string id;;
69
+
- : string = "abc123"
70
+
]}
71
+
72
+
Invalid identifiers are rejected:
73
+
74
+
{@ocaml[
75
+
# Id.of_string "";;
76
+
- : (Id.t, string) result = Error "Id cannot be empty"
77
+
# Id.of_string (String.make 256 'x');;
78
+
- : (Id.t, string) result = Error "Id cannot exceed 255 characters"
79
+
]}
80
+
81
+
{1 Keywords}
82
+
83
+
Email keywords are string flags that indicate message state. RFC 8621
84
+
defines standard keywords, and the library represents them as polymorphic
85
+
variants for type safety.
86
+
87
+
{2 Standard Keywords}
88
+
89
+
From {{:https://www.rfc-editor.org/rfc/rfc8621#section-4.1.1}RFC 8621
90
+
Section 4.1.1}:
91
+
92
+
{@ocaml[
93
+
# Keyword.of_string "$seen";;
94
+
- : Keyword.t = $seen
95
+
# Keyword.of_string "$flagged";;
96
+
- : Keyword.t = $flagged
97
+
# Keyword.of_string "$draft";;
98
+
- : Keyword.t = $draft
99
+
# Keyword.of_string "$answered";;
100
+
- : Keyword.t = $answered
101
+
]}
102
+
103
+
The standard keywords are:
104
+
105
+
{ul
106
+
{- [`Seen] - The email has been read}
107
+
{- [`Flagged] - The email has been flagged for attention}
108
+
{- [`Draft] - The email is a draft being composed}
109
+
{- [`Answered] - The email has been replied to}
110
+
{- [`Forwarded] - The email has been forwarded}
111
+
{- [`Phishing] - The email is likely phishing}
112
+
{- [`Junk] - The email is spam}
113
+
{- [`NotJunk] - The email is definitely not spam}}
114
+
115
+
{2 Extended Keywords}
116
+
117
+
The library also supports draft-ietf-mailmaint extended keywords:
118
+
119
+
{@ocaml[
120
+
# Keyword.of_string "$notify";;
121
+
- : Keyword.t = $notify
122
+
# Keyword.of_string "$muted";;
123
+
- : Keyword.t = $muted
124
+
# Keyword.of_string "$hasattachment";;
125
+
- : Keyword.t = $hasattachment
126
+
]}
127
+
128
+
{2 Custom Keywords}
129
+
130
+
Unknown keywords are preserved as [`Custom]:
131
+
132
+
{@ocaml[
133
+
# Keyword.of_string "$my_custom_flag";;
134
+
- : Keyword.t = $my_custom_flag
135
+
]}
136
+
137
+
{2 Converting Back to Strings}
138
+
139
+
{@ocaml[
140
+
# Keyword.to_string `Seen;;
141
+
- : string = "$seen"
142
+
# Keyword.to_string `Flagged;;
143
+
- : string = "$flagged"
144
+
# Keyword.to_string (`Custom "$important");;
145
+
- : string = "$important"
146
+
]}
147
+
148
+
{1 Mailbox Roles}
149
+
150
+
Mailboxes can have special roles that indicate their purpose. From
151
+
{{:https://www.rfc-editor.org/rfc/rfc8621#section-2}RFC 8621 Section 2}:
152
+
153
+
{@ocaml[
154
+
# Role.of_string "inbox";;
155
+
- : Role.t = inbox
156
+
# Role.of_string "sent";;
157
+
- : Role.t = sent
158
+
# Role.of_string "drafts";;
159
+
- : Role.t = drafts
160
+
# Role.of_string "trash";;
161
+
- : Role.t = trash
162
+
# Role.of_string "junk";;
163
+
- : Role.t = junk
164
+
# Role.of_string "archive";;
165
+
- : Role.t = archive
166
+
]}
167
+
168
+
Custom roles are also supported:
169
+
170
+
{@ocaml[
171
+
# Role.of_string "receipts";;
172
+
- : Role.t = receipts
173
+
]}
174
+
175
+
{1 Capabilities}
176
+
177
+
JMAP uses capability URIs to indicate supported features. From
178
+
{{:https://www.rfc-editor.org/rfc/rfc8620#section-2}RFC 8620 Section 2}:
179
+
180
+
{@ocaml[
181
+
# Capability.core_uri;;
182
+
- : string = "urn:ietf:params:jmap:core"
183
+
# Capability.mail_uri;;
184
+
- : string = "urn:ietf:params:jmap:mail"
185
+
# Capability.submission_uri;;
186
+
- : string = "urn:ietf:params:jmap:submission"
187
+
]}
188
+
189
+
{@ocaml[
190
+
# Capability.of_string Capability.core_uri;;
191
+
- : Capability.t = urn:ietf:params:jmap:core
192
+
# Capability.of_string Capability.mail_uri;;
193
+
- : Capability.t = urn:ietf:params:jmap:mail
194
+
# Capability.of_string "urn:example:custom";;
195
+
- : Capability.t = urn:example:custom
196
+
]}
197
+
198
+
{1 Understanding JMAP JSON Structure}
199
+
200
+
One of the key benefits of JMAP over IMAP is its use of JSON. Let's see
201
+
how OCaml types map to the wire format.
202
+
203
+
{2 Requests}
204
+
205
+
A JMAP request contains:
206
+
- [using]: List of capability URIs required
207
+
- [methodCalls]: Array of method invocations
208
+
209
+
Each method invocation is a triple: [methodName], [arguments], [callId].
210
+
211
+
Here's how a simple request is structured:
212
+
213
+
{x@ocaml[
214
+
# let req = Jmap.Proto.Request.create
215
+
~using:[Capability.core_uri; Capability.mail_uri]
216
+
~method_calls:[
217
+
Jmap.Proto.Invocation.create
218
+
~name:"Mailbox/get"
219
+
~arguments:(parse_json {|{"accountId": "abc123"}|})
220
+
~call_id:"c0"
221
+
]
222
+
();;
223
+
Line 7, characters 18-22:
224
+
Error: The function applied to this argument has type
225
+
method_call_id:string -> Proto.Invocation.t
226
+
This argument cannot be applied with label ~call_id
227
+
# Jmap_top.encode Jmap.Proto.Request.jsont req |> json_to_string |> print_endline;;
228
+
Line 1, characters 42-45:
229
+
Error: Unbound value req
230
+
Hint: Did you mean ref?
231
+
]x}
232
+
233
+
{2 Email Filter Conditions}
234
+
235
+
Filters demonstrate how complex query conditions map to JSON. From
236
+
{{:https://www.rfc-editor.org/rfc/rfc8621#section-4.4.1}RFC 8621
237
+
Section 4.4.1}:
238
+
239
+
{x@ocaml[
240
+
# let filter_condition : Jmap.Proto.Email.Filter_condition.t = {
241
+
in_mailbox = Some (Id.of_string_exn "inbox123");
242
+
in_mailbox_other_than = None;
243
+
before = None;
244
+
after = None;
245
+
min_size = None;
246
+
max_size = None;
247
+
all_in_thread_have_keyword = None;
248
+
some_in_thread_have_keyword = None;
249
+
none_in_thread_have_keyword = None;
250
+
has_keyword = Some "$flagged";
251
+
not_keyword = None;
252
+
has_attachment = Some true;
253
+
text = None;
254
+
from = Some "alice@";
255
+
to_ = None;
256
+
cc = None;
257
+
bcc = None;
258
+
subject = Some "urgent";
259
+
body = None;
260
+
header = None;
261
+
};;
262
+
Line 2, characters 23-52:
263
+
Error: This expression has type Id.t but an expression was expected of type
264
+
Proto.Id.t
265
+
# Jmap_top.encode Jmap.Proto.Email.Filter_condition.jsont filter_condition
266
+
|> json_to_string |> print_endline;;
267
+
Line 1, characters 57-73:
268
+
Error: Unbound value filter_condition
269
+
]x}
270
+
271
+
Notice how:
272
+
- OCaml record fields use [snake_case], but JSON uses [camelCase]
273
+
- [None] values are omitted from JSON (not sent as [null])
274
+
- The filter only includes non-empty conditions
275
+
276
+
{2 Filter Operators}
277
+
278
+
Filters can be combined with AND, OR, and NOT operators:
279
+
280
+
{x@ocaml[
281
+
# let combined_filter = Jmap.Proto.Filter.Operator {
282
+
operator = `And;
283
+
conditions = [
284
+
Condition filter_condition;
285
+
Condition { filter_condition with has_keyword = Some "$seen" }
286
+
]
287
+
};;
288
+
Line 4, characters 17-33:
289
+
Error: Unbound value filter_condition
290
+
]x}
291
+
292
+
{1 Method Chaining}
293
+
294
+
One of JMAP's most powerful features is result references - using the
295
+
output of one method as input to another. The {!Jmap.Chain} module
296
+
provides a monadic interface for building such requests.
297
+
298
+
From {{:https://www.rfc-editor.org/rfc/rfc8620#section-3.7}RFC 8620
299
+
Section 3.7}:
300
+
301
+
{i A method argument may use the result of a previous method invocation
302
+
in the same request.}
303
+
304
+
{2 Basic Example}
305
+
306
+
Query for emails, then fetch their details:
307
+
308
+
{[
309
+
open Jmap.Chain
310
+
311
+
let request, handle = build ~capabilities:[core; mail] begin
312
+
let* query = email_query ~account_id
313
+
~filter:(Condition { in_mailbox = Some inbox_id; (* ... *) })
314
+
~limit:50L ()
315
+
in
316
+
let* emails = email_get ~account_id
317
+
~ids:(from_query query) (* Reference query results! *)
318
+
~properties:["subject"; "from"; "receivedAt"]
319
+
()
320
+
in
321
+
return emails
322
+
end
323
+
][
324
+
{err@mdx-error[
325
+
Line 3, characters 46-50:
326
+
Error: Unbound value core
327
+
]err}]}
328
+
329
+
The key insight is [from_query query] - this creates a reference to the
330
+
[ids] array from the query response. The server processes both calls in
331
+
sequence, substituting the reference with actual IDs.
332
+
333
+
{2 Creation and Submission}
334
+
335
+
Create a draft and send it in one request:
336
+
337
+
{[
338
+
let* set_h, draft_cid = email_set ~account_id
339
+
~create:[("draft1", draft_email_json)]
340
+
()
341
+
in
342
+
let* _ = email_submission_set ~account_id
343
+
~create:[("sub1", submission_json
344
+
~email_id:(created_id_of_string "draft1") (* Reference creation! *)
345
+
~identity_id)]
346
+
()
347
+
in
348
+
return set_h
349
+
][
350
+
{err@mdx-error[
351
+
Line 1, characters 1-5:
352
+
Error: Unbound value ( let* )
353
+
]err}]}
354
+
355
+
{2 The RFC 8620 Example}
356
+
357
+
The RFC provides a complex example: fetch from/date/subject for all
358
+
emails in the first 10 threads in the inbox:
359
+
360
+
{[
361
+
let* q = email_query ~account_id
362
+
~filter:(Condition { in_mailbox = Some inbox_id; (* ... *) })
363
+
~sort:[comparator ~is_ascending:false "receivedAt"]
364
+
~collapse_threads:true ~limit:10L ()
365
+
in
366
+
let* e1 = email_get ~account_id
367
+
~ids:(from_query q)
368
+
~properties:["threadId"]
369
+
()
370
+
in
371
+
let* threads = thread_get ~account_id
372
+
~ids:(from_get_field e1 "threadId") (* Get threadIds from emails *)
373
+
()
374
+
in
375
+
let* e2 = email_get ~account_id
376
+
~ids:(from_get_field threads "emailIds") (* Get all emailIds in threads *)
377
+
~properties:["from"; "receivedAt"; "subject"]
378
+
()
379
+
in
380
+
return e2
381
+
][
382
+
{err@mdx-error[
383
+
Line 1, characters 1-5:
384
+
Error: Unbound value ( let* )
385
+
]err}]}
386
+
387
+
This entire flow executes in a {e single HTTP request}!
388
+
389
+
{1 Error Handling}
390
+
391
+
JMAP has a structured error system with three levels:
392
+
393
+
{2 Request-Level Errors}
394
+
395
+
These are returned with HTTP error status codes and RFC 7807 Problem
396
+
Details. From {{:https://www.rfc-editor.org/rfc/rfc8620#section-3.6.1}RFC
397
+
8620 Section 3.6.1}:
398
+
399
+
{@ocaml[
400
+
# Error.to_string (`Request {
401
+
Error.type_ = "urn:ietf:params:jmap:error:unknownCapability";
402
+
status = Some 400;
403
+
title = Some "Unknown Capability";
404
+
detail = Some "The server does not support 'urn:example:unsupported'";
405
+
limit = None;
406
+
});;
407
+
- : string =
408
+
"Request error: urn:ietf:params:jmap:error:unknownCapability (status 400): The server does not support 'urn:example:unsupported'"
409
+
]}
410
+
411
+
{2 Method-Level Errors}
412
+
413
+
Individual method calls can fail while others succeed:
414
+
415
+
{@ocaml[
416
+
# Error.to_string (`Method {
417
+
Error.type_ = "invalidArguments";
418
+
description = Some "The 'filter' argument is malformed";
419
+
});;
420
+
- : string =
421
+
"Method error: invalidArguments: The 'filter' argument is malformed"
422
+
]}
423
+
424
+
{2 SetError}
425
+
426
+
Object-level errors in /set responses:
427
+
428
+
{@ocaml[
429
+
# Error.to_string (`Set ("draft1", {
430
+
Error.type_ = "invalidProperties";
431
+
description = Some "Unknown property: foobar";
432
+
properties = Some ["foobar"];
433
+
}));;
434
+
- : string =
435
+
"Set error for draft1: invalidProperties: Unknown property: foobar"
436
+
]}
437
+
438
+
{1 Using with FastMail}
439
+
440
+
FastMail is a popular JMAP provider. Here's how to connect:
441
+
442
+
{[
443
+
(* Get a token from https://app.fastmail.com/settings/tokens *)
444
+
let token = "your-api-token"
445
+
446
+
(* The session URL for FastMail *)
447
+
let session_url = "https://api.fastmail.com/jmap/session"
448
+
449
+
(* For browser applications using jmap-brr: *)
450
+
let main () =
451
+
let open Fut.Syntax in
452
+
let* conn = Jmap_brr.get_session
453
+
~url:(Jstr.v session_url)
454
+
~token:(Jstr.v token)
455
+
in
456
+
match conn with
457
+
| Error e -> Brr.Console.(error [str "Error:"; e]); Fut.return ()
458
+
| Ok conn ->
459
+
let session = Jmap_brr.session conn in
460
+
Brr.Console.(log [str "Connected as:";
461
+
str (Jmap.Session.username session)]);
462
+
Fut.return ()
463
+
][
464
+
{err@mdx-error[
465
+
Line 9, characters 14-17:
466
+
Error: Unbound module Fut
467
+
Hint: Did you mean Fun?
468
+
]err}]}
469
+
470
+
{1 Summary}
471
+
472
+
JMAP (RFC 8620/8621) provides a modern, efficient protocol for email:
473
+
474
+
{ol
475
+
{- {b Sessions}: Discover capabilities and account information via GET request}
476
+
{- {b Batching}: Combine multiple method calls in one request}
477
+
{- {b References}: Use results from one method as input to another}
478
+
{- {b Type Safety}: The [jmap] library uses polymorphic variants for keywords and roles}
479
+
{- {b JSON Mapping}: OCaml types map cleanly to JMAP JSON structure}
480
+
{- {b Browser Support}: The [jmap-brr] package enables browser-based clients}}
481
+
482
+
The [jmap] library provides:
483
+
{ul
484
+
{- {!Jmap} - High-level interface with abstract types}
485
+
{- {!Jmap.Proto} - Low-level protocol types matching the RFCs}
486
+
{- {!Jmap.Chain} - Monadic interface for request chaining}
487
+
{- [Jmap_brr] - Browser support via Brr/js_of_ocaml (separate package)}}
488
+
489
+
{2 Key RFC References}
490
+
491
+
{ul
492
+
{- {{:https://www.rfc-editor.org/rfc/rfc8620}RFC 8620}: JMAP Core}
493
+
{- {{:https://www.rfc-editor.org/rfc/rfc8621}RFC 8621}: JMAP for Mail}
494
+
{- {{:https://www.rfc-editor.org/rfc/rfc7807}RFC 7807}: Problem Details for HTTP APIs}}
+12
dune-project
+12
dune-project
···
1
1
(lang dune 3.20)
2
2
3
+
(using mdx 0.4)
4
+
3
5
(name jmap)
4
6
5
7
(generate_opam_files true)
···
36
38
(jsont (>= 0.2.0))
37
39
eio
38
40
requests))
41
+
42
+
(package
43
+
(name jmap-brr)
44
+
(synopsis "JMAP client for browsers")
45
+
(description "JMAP client using Brr for browser-based email clients with js_of_ocaml.")
46
+
(depends
47
+
(ocaml (>= 5.4.0))
48
+
(jmap (= :version))
49
+
(jsont (>= 0.2.0))
50
+
(brr (>= 0.0.6))))
+35
jmap-brr.opam
+35
jmap-brr.opam
···
1
+
# This file is generated by dune, edit dune-project instead
2
+
opam-version: "2.0"
3
+
synopsis: "JMAP client for browsers"
4
+
description:
5
+
"JMAP client using Brr for browser-based email clients with js_of_ocaml."
6
+
maintainer: ["Anil Madhavapeddy <anil@recoil.org>"]
7
+
authors: ["Anil Madhavapeddy <anil@recoil.org>"]
8
+
license: "ISC"
9
+
homepage: "https://github.com/avsm/ocaml-jmap"
10
+
doc: "https://avsm.github.io/ocaml-jmap"
11
+
bug-reports: "https://github.com/avsm/ocaml-jmap/issues"
12
+
depends: [
13
+
"dune" {>= "3.20"}
14
+
"ocaml" {>= "5.4.0"}
15
+
"jmap" {= version}
16
+
"jsont" {>= "0.2.0"}
17
+
"brr" {>= "0.0.6"}
18
+
"odoc" {with-doc}
19
+
]
20
+
build: [
21
+
["dune" "subst"] {dev}
22
+
[
23
+
"dune"
24
+
"build"
25
+
"-p"
26
+
name
27
+
"-j"
28
+
jobs
29
+
"@install"
30
+
"@runtest" {with-test}
31
+
"@doc" {with-doc}
32
+
]
33
+
]
34
+
dev-repo: "git+https://github.com/avsm/ocaml-jmap.git"
35
+
x-maintenance-intent: ["(latest)"]
+9
-6
lib/core/jmap.ml
+9
-6
lib/core/jmap.ml
···
216
216
217
217
(** Get active keywords as polymorphic variants. *)
218
218
let keywords e =
219
-
let kw_map = Proto.Email.keywords e in
220
-
List.filter_map (fun (k, v) ->
221
-
if v then Some (Keyword.of_string k) else None
222
-
) kw_map
219
+
match Proto.Email.keywords e with
220
+
| None -> []
221
+
| Some kw_map ->
222
+
List.filter_map (fun (k, v) ->
223
+
if v then Some (Keyword.of_string k) else None
224
+
) kw_map
223
225
224
226
(** Check if email has a specific keyword. *)
225
227
let has_keyword kw e =
226
228
let kw_str = Keyword.to_string kw in
227
-
let kw_map = Proto.Email.keywords e in
228
-
List.exists (fun (k, v) -> k = kw_str && v) kw_map
229
+
match Proto.Email.keywords e with
230
+
| None -> false
231
+
| Some kw_map -> List.exists (fun (k, v) -> k = kw_str && v) kw_map
229
232
230
233
let from e = Proto.Email.from e
231
234
let to_ e = Proto.Email.to_ e
+46
-39
lib/core/jmap.mli
+46
-39
lib/core/jmap.mli
···
267
267
val create : ?name:string -> string -> t
268
268
end
269
269
270
-
(** Email mailbox. *)
270
+
(** Email mailbox.
271
+
All accessors return option types since responses only include requested properties. *)
271
272
module Mailbox : sig
272
273
type t
273
274
274
-
val id : t -> Id.t
275
-
val name : t -> string
275
+
val id : t -> Id.t option
276
+
val name : t -> string option
276
277
val parent_id : t -> Id.t option
277
-
val sort_order : t -> int64
278
-
val total_emails : t -> int64
279
-
val unread_emails : t -> int64
280
-
val total_threads : t -> int64
281
-
val unread_threads : t -> int64
282
-
val is_subscribed : t -> bool
278
+
val sort_order : t -> int64 option
279
+
val total_emails : t -> int64 option
280
+
val unread_emails : t -> int64 option
281
+
val total_threads : t -> int64 option
282
+
val unread_threads : t -> int64 option
283
+
val is_subscribed : t -> bool option
283
284
val role : t -> Role.t option
284
285
285
286
(** Mailbox rights. *)
···
297
298
val may_submit : t -> bool
298
299
end
299
300
300
-
val my_rights : t -> Rights.t
301
+
val my_rights : t -> Rights.t option
301
302
end
302
303
303
-
(** Email thread. *)
304
+
(** Email thread.
305
+
All accessors return option types since responses only include requested properties. *)
304
306
module Thread : sig
305
307
type t
306
308
307
-
val id : t -> Id.t
308
-
val email_ids : t -> Id.t list
309
+
val id : t -> Id.t option
310
+
val email_ids : t -> Id.t list option
309
311
end
310
312
311
313
(** Email message. *)
···
331
333
val value_is_encoding_problem : value -> bool
332
334
end
333
335
336
+
(** All accessors return option types since responses only include requested properties. *)
334
337
type t
335
338
336
-
val id : t -> Id.t
337
-
val blob_id : t -> Id.t
338
-
val thread_id : t -> Id.t
339
-
val mailbox_ids : t -> (Id.t * bool) list
340
-
val size : t -> int64
341
-
val received_at : t -> Ptime.t
339
+
val id : t -> Id.t option
340
+
val blob_id : t -> Id.t option
341
+
val thread_id : t -> Id.t option
342
+
val mailbox_ids : t -> (Id.t * bool) list option
343
+
val size : t -> int64 option
344
+
val received_at : t -> Ptime.t option
342
345
val message_id : t -> string list option
343
346
val in_reply_to : t -> string list option
344
347
val references : t -> string list option
345
348
val subject : t -> string option
346
349
val sent_at : t -> Ptime.t option
347
-
val has_attachment : t -> bool
348
-
val preview : t -> string
350
+
val has_attachment : t -> bool option
351
+
val preview : t -> string option
349
352
350
-
(** Get active keywords as polymorphic variants. *)
353
+
(** Get active keywords as polymorphic variants.
354
+
Returns empty list if keywords property was not requested. *)
351
355
val keywords : t -> Keyword.t list
352
356
353
-
(** Check if email has a specific keyword. *)
357
+
(** Check if email has a specific keyword.
358
+
Returns false if keywords property was not requested. *)
354
359
val has_keyword : Keyword.t -> t -> bool
355
360
356
361
val from : t -> Email_address.t list option
···
366
371
val body_values : t -> (string * Body.value) list option
367
372
end
368
373
369
-
(** Email identity for sending. *)
374
+
(** Email identity for sending.
375
+
All accessors return option types since responses only include requested properties. *)
370
376
module Identity : sig
371
377
type t
372
378
373
-
val id : t -> Id.t
374
-
val name : t -> string
375
-
val email : t -> string
379
+
val id : t -> Id.t option
380
+
val name : t -> string option
381
+
val email : t -> string option
376
382
val reply_to : t -> Email_address.t list option
377
383
val bcc : t -> Email_address.t list option
378
-
val text_signature : t -> string
379
-
val html_signature : t -> string
380
-
val may_delete : t -> bool
384
+
val text_signature : t -> string option
385
+
val html_signature : t -> string option
386
+
val may_delete : t -> bool option
381
387
end
382
388
383
-
(** Email submission for outgoing mail. *)
389
+
(** Email submission for outgoing mail.
390
+
All accessors return option types since responses only include requested properties. *)
384
391
module Submission : sig
385
392
type t
386
393
387
-
val id : t -> Id.t
388
-
val identity_id : t -> Id.t
389
-
val email_id : t -> Id.t
390
-
val thread_id : t -> Id.t
391
-
val send_at : t -> Ptime.t
392
-
val undo_status : t -> Proto.Submission.undo_status
394
+
val id : t -> Id.t option
395
+
val identity_id : t -> Id.t option
396
+
val email_id : t -> Id.t option
397
+
val thread_id : t -> Id.t option
398
+
val send_at : t -> Ptime.t option
399
+
val undo_status : t -> Proto.Submission.undo_status option
393
400
val delivery_status : t -> (string * Proto.Submission.Delivery_status.t) list option
394
-
val dsn_blob_ids : t -> Id.t list
395
-
val mdn_blob_ids : t -> Id.t list
401
+
val dsn_blob_ids : t -> Id.t list option
402
+
val mdn_blob_ids : t -> Id.t list option
396
403
end
397
404
398
405
(** Vacation auto-response. *)
+7
lib/js/dune
+7
lib/js/dune
+174
lib/js/jmap_brr.ml
+174
lib/js/jmap_brr.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
open Brr
7
+
open Fut.Syntax
8
+
9
+
type connection = {
10
+
session : Jmap.Proto.Session.t;
11
+
api_url : Jstr.t;
12
+
token : Jstr.t;
13
+
}
14
+
15
+
let session conn = conn.session
16
+
let api_url conn = conn.api_url
17
+
18
+
(* JSON logging callbacks *)
19
+
let on_request : (string -> string -> unit) option ref = ref None
20
+
let on_response : (string -> string -> unit) option ref = ref None
21
+
22
+
let set_request_logger f = on_request := Some f
23
+
let set_response_logger f = on_response := Some f
24
+
25
+
let log_request label json =
26
+
match !on_request with
27
+
| Some f -> f label json
28
+
| None -> ()
29
+
30
+
let log_response label json =
31
+
match !on_response with
32
+
| Some f -> f label json
33
+
| None -> ()
34
+
35
+
(* JSON encoding/decoding using jsont.brr *)
36
+
37
+
let encode_request req =
38
+
Jsont_brr.encode Jmap.Proto.Request.jsont req
39
+
40
+
let encode_response resp =
41
+
Jsont_brr.encode Jmap.Proto.Response.jsont resp
42
+
43
+
let encode_session session =
44
+
Jsont_brr.encode Jmap.Proto.Session.jsont session
45
+
46
+
let decode_json s =
47
+
match Brr.Json.decode s with
48
+
| Ok jv -> Ok (Obj.magic jv : Jsont.json) (* Jv.t and Jsont.json are compatible *)
49
+
| Error e -> Error e
50
+
51
+
let encode_json json =
52
+
Ok (Brr.Json.encode (Obj.magic json : Jv.t))
53
+
54
+
let pp_json ppf json =
55
+
match encode_json json with
56
+
| Ok s -> Format.pp_print_string ppf (Jstr.to_string s)
57
+
| Error _ -> Format.pp_print_string ppf "<json encoding error>"
58
+
59
+
(* HTTP helpers *)
60
+
61
+
let make_headers token =
62
+
Brr_io.Fetch.Headers.of_assoc [
63
+
Jstr.v "Authorization", Jstr.(v "Bearer " + token);
64
+
Jstr.v "Content-Type", Jstr.v "application/json";
65
+
Jstr.v "Accept", Jstr.v "application/json";
66
+
]
67
+
68
+
let fetch_json ~url ~meth ~headers ?body () =
69
+
Console.(log [str ">>> Request:"; str (Jstr.to_string meth); str (Jstr.to_string url)]);
70
+
(match body with
71
+
| Some b -> Console.(log [str ">>> Body:"; b])
72
+
| None -> Console.(log [str ">>> No body"]));
73
+
let init = Brr_io.Fetch.Request.init
74
+
~method':meth
75
+
~headers
76
+
?body
77
+
()
78
+
in
79
+
let req = Brr_io.Fetch.Request.v ~init url in
80
+
let* response = Brr_io.Fetch.request req in
81
+
match response with
82
+
| Error e ->
83
+
Console.(error [str "<<< Fetch error:"; e]);
84
+
Fut.return (Error e)
85
+
| Ok resp ->
86
+
let status = Brr_io.Fetch.Response.status resp in
87
+
Console.(log [str "<<< Response status:"; str (Jstr.of_int status)]);
88
+
if not (Brr_io.Fetch.Response.ok resp) then begin
89
+
let msg = Jstr.(v "HTTP error: " + of_int status) in
90
+
(* Try to get response body for error details *)
91
+
let body = Brr_io.Fetch.Response.as_body resp in
92
+
let* text = Brr_io.Fetch.Body.text body in
93
+
(match text with
94
+
| Ok t -> Console.(error [str "<<< Error body:"; str (Jstr.to_string t)])
95
+
| Error _ -> ());
96
+
Fut.return (Error (Jv.Error.v msg))
97
+
end else begin
98
+
let body = Brr_io.Fetch.Response.as_body resp in
99
+
let* text = Brr_io.Fetch.Body.text body in
100
+
match text with
101
+
| Error e ->
102
+
Console.(error [str "<<< Body read error:"; e]);
103
+
Fut.return (Error e)
104
+
| Ok text ->
105
+
Console.(log [str "<<< Response body:"; str (Jstr.to_string text)]);
106
+
Fut.return (Ok text)
107
+
end
108
+
109
+
(* Session establishment *)
110
+
111
+
let get_session ~url ~token =
112
+
Console.(log [str "get_session: token length ="; str (Jstr.of_int (Jstr.length token))]);
113
+
log_request "GET Session" (Printf.sprintf "{\"url\": \"%s\"}" (Jstr.to_string url));
114
+
let headers = make_headers token in
115
+
let* result = fetch_json ~url ~meth:(Jstr.v "GET") ~headers () in
116
+
match result with
117
+
| Error e -> Fut.return (Error e)
118
+
| Ok text ->
119
+
log_response "Session" (Jstr.to_string text);
120
+
match Jsont_brr.decode Jmap.Proto.Session.jsont text with
121
+
| Error e -> Fut.return (Error e)
122
+
| Ok session ->
123
+
let api_url = Jstr.v (Jmap.Proto.Session.api_url session) in
124
+
Fut.return (Ok { session; api_url; token })
125
+
126
+
(* Making requests *)
127
+
128
+
let request conn req =
129
+
let headers = make_headers conn.token in
130
+
match Jsont_brr.encode Jmap.Proto.Request.jsont req with
131
+
| Error e -> Fut.return (Error e)
132
+
| Ok body_str ->
133
+
log_request "JMAP Request" (Jstr.to_string body_str);
134
+
let body = Brr_io.Fetch.Body.of_jstr body_str in
135
+
let* result = fetch_json
136
+
~url:conn.api_url
137
+
~meth:(Jstr.v "POST")
138
+
~headers
139
+
~body
140
+
()
141
+
in
142
+
match result with
143
+
| Error e -> Fut.return (Error e)
144
+
| Ok text ->
145
+
log_response "JMAP Response" (Jstr.to_string text);
146
+
match Jsont_brr.decode Jmap.Proto.Response.jsont text with
147
+
| Error e -> Fut.return (Error e)
148
+
| Ok response -> Fut.return (Ok response)
149
+
150
+
let request_json conn json =
151
+
let headers = make_headers conn.token in
152
+
match encode_json json with
153
+
| Error e -> Fut.return (Error e)
154
+
| Ok body_str ->
155
+
let body = Brr_io.Fetch.Body.of_jstr body_str in
156
+
let* result = fetch_json
157
+
~url:conn.api_url
158
+
~meth:(Jstr.v "POST")
159
+
~headers
160
+
~body
161
+
()
162
+
in
163
+
match result with
164
+
| Error e -> Fut.return (Error e)
165
+
| Ok text ->
166
+
match decode_json text with
167
+
| Error e -> Fut.return (Error e)
168
+
| Ok json -> Fut.return (Ok json)
169
+
170
+
(* Toplevel support *)
171
+
172
+
let install_printers () =
173
+
(* In browser context, printers are registered via the OCaml console *)
174
+
Console.(log [str "JMAP printers installed"])
+107
lib/js/jmap_brr.mli
+107
lib/js/jmap_brr.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** JMAP client for browsers using Brr.
7
+
8
+
This module provides a JMAP client that runs in web browsers using
9
+
the Fetch API. It can be used with js_of_ocaml to build browser-based
10
+
email clients.
11
+
12
+
{2 Example}
13
+
14
+
{[
15
+
open Fut.Syntax
16
+
17
+
let main () =
18
+
let* session = Jmap_brr.get_session
19
+
~url:(Jstr.v "https://api.fastmail.com/jmap/session")
20
+
~token:(Jstr.v "your-api-token")
21
+
in
22
+
match session with
23
+
| Error e -> Brr.Console.(error [str "Session error:"; e]); Fut.return ()
24
+
| Ok session ->
25
+
Brr.Console.(log [str "Connected as:"; str (Jmap.Session.username session)]);
26
+
Fut.return ()
27
+
28
+
let () = ignore (main ())
29
+
]} *)
30
+
31
+
(** {1 Connection} *)
32
+
33
+
type connection
34
+
(** A JMAP connection to a server. *)
35
+
36
+
val session : connection -> Jmap.Proto.Session.t
37
+
(** [session conn] returns the session information. *)
38
+
39
+
val api_url : connection -> Jstr.t
40
+
(** [api_url conn] returns the API URL for requests. *)
41
+
42
+
(** {1 Session Establishment} *)
43
+
44
+
val get_session :
45
+
url:Jstr.t ->
46
+
token:Jstr.t ->
47
+
(connection, Jv.Error.t) result Fut.t
48
+
(** [get_session ~url ~token] establishes a JMAP session.
49
+
50
+
[url] is the session URL (e.g., ["https://api.fastmail.com/jmap/session"]).
51
+
[token] is the Bearer authentication token. *)
52
+
53
+
(** {1 Making Requests} *)
54
+
55
+
val request :
56
+
connection ->
57
+
Jmap.Proto.Request.t ->
58
+
(Jmap.Proto.Response.t, Jv.Error.t) result Fut.t
59
+
(** [request conn req] sends a JMAP request and returns the response. *)
60
+
61
+
val request_json :
62
+
connection ->
63
+
Jsont.json ->
64
+
(Jsont.json, Jv.Error.t) result Fut.t
65
+
(** [request_json conn json] sends a raw JSON request and returns the
66
+
JSON response. Useful for debugging or custom requests. *)
67
+
68
+
(** {1 JSON Encoding Utilities}
69
+
70
+
These functions help visualize how OCaml types map to JMAP JSON,
71
+
useful for the tutorial and debugging. *)
72
+
73
+
val encode_request : Jmap.Proto.Request.t -> (Jstr.t, Jv.Error.t) result
74
+
(** [encode_request req] encodes a request to JSON string. *)
75
+
76
+
val encode_response : Jmap.Proto.Response.t -> (Jstr.t, Jv.Error.t) result
77
+
(** [encode_response resp] encodes a response to JSON string. *)
78
+
79
+
val encode_session : Jmap.Proto.Session.t -> (Jstr.t, Jv.Error.t) result
80
+
(** [encode_session session] encodes a session to JSON string. *)
81
+
82
+
val decode_json : Jstr.t -> (Jsont.json, Jv.Error.t) result
83
+
(** [decode_json s] parses a JSON string to a Jsont.json value. *)
84
+
85
+
val encode_json : Jsont.json -> (Jstr.t, Jv.Error.t) result
86
+
(** [encode_json json] encodes a Jsont.json value to a string. *)
87
+
88
+
val pp_json : Format.formatter -> Jsont.json -> unit
89
+
(** [pp_json ppf json] pretty-prints JSON. For toplevel use. *)
90
+
91
+
(** {1 Protocol Logging} *)
92
+
93
+
val set_request_logger : (string -> string -> unit) -> unit
94
+
(** [set_request_logger f] registers a callback [f label json] that will be
95
+
called with each outgoing JMAP request. Useful for debugging and
96
+
educational displays. *)
97
+
98
+
val set_response_logger : (string -> string -> unit) -> unit
99
+
(** [set_response_logger f] registers a callback [f label json] that will be
100
+
called with each incoming JMAP response. Useful for debugging and
101
+
educational displays. *)
102
+
103
+
(** {1 Toplevel Support} *)
104
+
105
+
val install_printers : unit -> unit
106
+
(** [install_printers ()] installs toplevel pretty printers for JMAP types.
107
+
This is useful when using the OCaml console in the browser. *)
+311
-66
lib/mail/mail_email.ml
+311
-66
lib/mail/mail_email.ml
···
45
45
| `Gray
46
46
]
47
47
48
-
(* Flag color bitmask:
49
-
- 000 = red, 100 = orange, 010 = yellow, 111 = green
50
-
- 001 = blue, 101 = purple, 011 = gray *)
51
48
let flag_color_to_keywords = function
52
-
| `Red -> [] (* 000 - no bits set *)
53
-
| `Orange -> [mail_flag_bit0] (* 100 *)
54
-
| `Yellow -> [mail_flag_bit1] (* 010 *)
55
-
| `Green -> [mail_flag_bit0; mail_flag_bit1; mail_flag_bit2] (* 111 *)
56
-
| `Blue -> [mail_flag_bit2] (* 001 *)
57
-
| `Purple -> [mail_flag_bit0; mail_flag_bit2] (* 101 *)
58
-
| `Gray -> [mail_flag_bit1; mail_flag_bit2] (* 011 *)
49
+
| `Red -> []
50
+
| `Orange -> [mail_flag_bit0]
51
+
| `Yellow -> [mail_flag_bit1]
52
+
| `Green -> [mail_flag_bit0; mail_flag_bit1; mail_flag_bit2]
53
+
| `Blue -> [mail_flag_bit2]
54
+
| `Purple -> [mail_flag_bit0; mail_flag_bit2]
55
+
| `Gray -> [mail_flag_bit1; mail_flag_bit2]
59
56
60
57
let flag_color_of_keywords keywords =
61
58
let has k = List.mem k keywords in
···
70
67
| (false, false, true) -> Some `Blue
71
68
| (true, false, true) -> Some `Purple
72
69
| (false, true, true) -> Some `Gray
73
-
| (true, true, false) -> None (* Invalid combination *)
70
+
| (true, true, false) -> None
74
71
end
75
72
73
+
(* Email property types *)
74
+
75
+
type metadata_property = [
76
+
| `Id
77
+
| `Blob_id
78
+
| `Thread_id
79
+
| `Mailbox_ids
80
+
| `Keywords
81
+
| `Size
82
+
| `Received_at
83
+
]
84
+
85
+
type header_convenience_property = [
86
+
| `Message_id
87
+
| `In_reply_to
88
+
| `References
89
+
| `Sender
90
+
| `From
91
+
| `To
92
+
| `Cc
93
+
| `Bcc
94
+
| `Reply_to
95
+
| `Subject
96
+
| `Sent_at
97
+
| `Headers
98
+
]
99
+
100
+
type body_property = [
101
+
| `Body_structure
102
+
| `Body_values
103
+
| `Text_body
104
+
| `Html_body
105
+
| `Attachments
106
+
| `Has_attachment
107
+
| `Preview
108
+
]
109
+
110
+
type standard_property = [
111
+
| metadata_property
112
+
| header_convenience_property
113
+
| body_property
114
+
]
115
+
116
+
type header_property = [ `Header of Mail_header.header_property ]
117
+
118
+
type property = [ standard_property | header_property ]
119
+
120
+
let standard_property_to_string : [< standard_property ] -> string = function
121
+
| `Id -> "id"
122
+
| `Blob_id -> "blobId"
123
+
| `Thread_id -> "threadId"
124
+
| `Mailbox_ids -> "mailboxIds"
125
+
| `Keywords -> "keywords"
126
+
| `Size -> "size"
127
+
| `Received_at -> "receivedAt"
128
+
| `Message_id -> "messageId"
129
+
| `In_reply_to -> "inReplyTo"
130
+
| `References -> "references"
131
+
| `Sender -> "sender"
132
+
| `From -> "from"
133
+
| `To -> "to"
134
+
| `Cc -> "cc"
135
+
| `Bcc -> "bcc"
136
+
| `Reply_to -> "replyTo"
137
+
| `Subject -> "subject"
138
+
| `Sent_at -> "sentAt"
139
+
| `Headers -> "headers"
140
+
| `Body_structure -> "bodyStructure"
141
+
| `Body_values -> "bodyValues"
142
+
| `Text_body -> "textBody"
143
+
| `Html_body -> "htmlBody"
144
+
| `Attachments -> "attachments"
145
+
| `Has_attachment -> "hasAttachment"
146
+
| `Preview -> "preview"
147
+
148
+
let property_to_string : [< property ] -> string = function
149
+
| `Header hp -> Mail_header.header_property_to_string hp
150
+
| #standard_property as p -> standard_property_to_string p
151
+
152
+
let standard_property_of_string s : standard_property option =
153
+
match s with
154
+
| "id" -> Some `Id
155
+
| "blobId" -> Some `Blob_id
156
+
| "threadId" -> Some `Thread_id
157
+
| "mailboxIds" -> Some `Mailbox_ids
158
+
| "keywords" -> Some `Keywords
159
+
| "size" -> Some `Size
160
+
| "receivedAt" -> Some `Received_at
161
+
| "messageId" -> Some `Message_id
162
+
| "inReplyTo" -> Some `In_reply_to
163
+
| "references" -> Some `References
164
+
| "sender" -> Some `Sender
165
+
| "from" -> Some `From
166
+
| "to" -> Some `To
167
+
| "cc" -> Some `Cc
168
+
| "bcc" -> Some `Bcc
169
+
| "replyTo" -> Some `Reply_to
170
+
| "subject" -> Some `Subject
171
+
| "sentAt" -> Some `Sent_at
172
+
| "headers" -> Some `Headers
173
+
| "bodyStructure" -> Some `Body_structure
174
+
| "bodyValues" -> Some `Body_values
175
+
| "textBody" -> Some `Text_body
176
+
| "htmlBody" -> Some `Html_body
177
+
| "attachments" -> Some `Attachments
178
+
| "hasAttachment" -> Some `Has_attachment
179
+
| "preview" -> Some `Preview
180
+
| _ -> None
181
+
182
+
let property_of_string s : property option =
183
+
match standard_property_of_string s with
184
+
| Some p -> Some (p :> property)
185
+
| None ->
186
+
match Mail_header.header_property_of_string s with
187
+
| Some hp -> Some (`Header hp)
188
+
| None -> None
189
+
190
+
(* Body part properties *)
191
+
192
+
type body_part_property = [
193
+
| `Part_id
194
+
| `Blob_id
195
+
| `Size
196
+
| `Part_headers
197
+
| `Name
198
+
| `Type
199
+
| `Charset
200
+
| `Disposition
201
+
| `Cid
202
+
| `Language
203
+
| `Location
204
+
| `Sub_parts
205
+
]
206
+
207
+
let body_part_property_to_string : [< body_part_property ] -> string = function
208
+
| `Part_id -> "partId"
209
+
| `Blob_id -> "blobId"
210
+
| `Size -> "size"
211
+
| `Part_headers -> "headers"
212
+
| `Name -> "name"
213
+
| `Type -> "type"
214
+
| `Charset -> "charset"
215
+
| `Disposition -> "disposition"
216
+
| `Cid -> "cid"
217
+
| `Language -> "language"
218
+
| `Location -> "location"
219
+
| `Sub_parts -> "subParts"
220
+
221
+
let body_part_property_of_string s : body_part_property option =
222
+
match s with
223
+
| "partId" -> Some `Part_id
224
+
| "blobId" -> Some `Blob_id
225
+
| "size" -> Some `Size
226
+
| "headers" -> Some `Part_headers
227
+
| "name" -> Some `Name
228
+
| "type" -> Some `Type
229
+
| "charset" -> Some `Charset
230
+
| "disposition" -> Some `Disposition
231
+
| "cid" -> Some `Cid
232
+
| "language" -> Some `Language
233
+
| "location" -> Some `Location
234
+
| "subParts" -> Some `Sub_parts
235
+
| _ -> None
236
+
237
+
(* Email type with optional fields *)
238
+
76
239
type t = {
77
-
id : Proto_id.t;
78
-
blob_id : Proto_id.t;
79
-
thread_id : Proto_id.t;
80
-
size : int64;
81
-
received_at : Ptime.t;
82
-
mailbox_ids : (Proto_id.t * bool) list;
83
-
keywords : (string * bool) list;
240
+
id : Proto_id.t option;
241
+
blob_id : Proto_id.t option;
242
+
thread_id : Proto_id.t option;
243
+
size : int64 option;
244
+
received_at : Ptime.t option;
245
+
mailbox_ids : (Proto_id.t * bool) list option;
246
+
keywords : (string * bool) list option;
84
247
message_id : string list option;
85
248
in_reply_to : string list option;
86
249
references : string list option;
···
98
261
text_body : Mail_body.Part.t list option;
99
262
html_body : Mail_body.Part.t list option;
100
263
attachments : Mail_body.Part.t list option;
101
-
has_attachment : bool;
102
-
preview : string;
264
+
has_attachment : bool option;
265
+
preview : string option;
266
+
dynamic_headers : (string * Jsont.json) list;
103
267
}
104
268
105
269
let id t = t.id
···
128
292
let attachments t = t.attachments
129
293
let has_attachment t = t.has_attachment
130
294
let preview t = t.preview
295
+
let dynamic_headers_raw t = t.dynamic_headers
296
+
297
+
(* Parse header property name to determine form and :all flag *)
298
+
let parse_header_prop name =
299
+
if not (String.length name > 7 && String.sub name 0 7 = "header:") then
300
+
None
301
+
else
302
+
let rest = String.sub name 7 (String.length name - 7) in
303
+
let parts = String.split_on_char ':' rest in
304
+
match parts with
305
+
| [] -> None
306
+
| [_name] -> Some (`Raw, false)
307
+
| [_name; second] ->
308
+
if second = "all" then Some (`Raw, true)
309
+
else (
310
+
match Mail_header.form_of_string second with
311
+
| Some form -> Some (form, false)
312
+
| None -> None
313
+
)
314
+
| [_name; form_str; "all"] ->
315
+
(match Mail_header.form_of_string form_str with
316
+
| Some form -> Some (form, true)
317
+
| None -> None)
318
+
| _ -> None
319
+
320
+
(* Decode a raw JSON header value into typed header_value *)
321
+
let decode_header_value prop_name json =
322
+
match parse_header_prop prop_name with
323
+
| None -> None
324
+
| Some (form, all) ->
325
+
let jsont = Mail_header.header_value_jsont ~form ~all in
326
+
match Jsont.Json.decode' jsont json with
327
+
| Ok v -> Some v
328
+
| Error _ -> None
329
+
330
+
let get_header t key =
331
+
match List.assoc_opt key t.dynamic_headers with
332
+
| None -> None
333
+
| Some json -> decode_header_value key json
334
+
335
+
let get_header_string t key =
336
+
match get_header t key with
337
+
| Some (Mail_header.String_single s) -> s
338
+
| _ -> None
339
+
340
+
let get_header_addresses t key =
341
+
match get_header t key with
342
+
| Some (Mail_header.Addresses_single addrs) -> addrs
343
+
| _ -> None
131
344
132
345
let make id blob_id thread_id size received_at mailbox_ids keywords
133
346
message_id in_reply_to references sender from to_ cc bcc reply_to
134
347
subject sent_at headers body_structure body_values text_body html_body
135
-
attachments has_attachment preview =
348
+
attachments has_attachment preview dynamic_headers =
136
349
{ id; blob_id; thread_id; size; received_at; mailbox_ids; keywords;
137
350
message_id; in_reply_to; references; sender; from; to_; cc; bcc;
138
351
reply_to; subject; sent_at; headers; body_structure; body_values;
139
-
text_body; html_body; attachments; has_attachment; preview }
352
+
text_body; html_body; attachments; has_attachment; preview; dynamic_headers }
353
+
354
+
(* Helper: null-safe list decoder - treats null as empty list.
355
+
This allows fields that may be null or array to decode successfully. *)
356
+
let null_safe_list inner_jsont =
357
+
Jsont.map
358
+
~dec:(function None -> [] | Some l -> l)
359
+
~enc:(fun l -> Some l)
360
+
(Jsont.option (Jsont.list inner_jsont))
361
+
362
+
module String_map = Map.Make(String)
363
+
364
+
(* Filter unknown members to only keep header:* properties *)
365
+
let filter_header_props (unknown : Jsont.json String_map.t) : (string * Jsont.json) list =
366
+
String_map.to_seq unknown
367
+
|> Seq.filter (fun (k, _) -> String.length k > 7 && String.sub k 0 7 = "header:")
368
+
|> List.of_seq
140
369
141
370
let jsont =
142
371
let kind = "Email" in
143
372
let body_values_jsont = Proto_json_map.of_string Mail_body.Value.jsont in
144
-
(* subject can be null per RFC 8621 Section 4.1.1 *)
145
-
let nullable_string = Jsont.(option string) in
146
-
Jsont.Object.map ~kind make
147
-
|> Jsont.Object.mem "id" Proto_id.jsont ~enc:id
148
-
|> Jsont.Object.mem "blobId" Proto_id.jsont ~enc:blob_id
149
-
|> Jsont.Object.mem "threadId" Proto_id.jsont ~enc:thread_id
150
-
|> Jsont.Object.mem "size" Proto_int53.Unsigned.jsont ~enc:size
151
-
|> Jsont.Object.mem "receivedAt" Proto_date.Utc.jsont ~enc:received_at
152
-
|> Jsont.Object.mem "mailboxIds" Proto_json_map.id_to_bool ~enc:mailbox_ids
153
-
|> Jsont.Object.mem "keywords" Proto_json_map.string_to_bool ~dec_absent:[] ~enc:keywords
154
-
(* Header fields can be absent or null per RFC 8621 *)
155
-
|> Jsont.Object.mem "messageId" Jsont.(option (list string))
156
-
~dec_absent:None ~enc_omit:Option.is_none ~enc:message_id
157
-
|> Jsont.Object.mem "inReplyTo" Jsont.(option (list string))
158
-
~dec_absent:None ~enc_omit:Option.is_none ~enc:in_reply_to
159
-
|> Jsont.Object.mem "references" Jsont.(option (list string))
160
-
~dec_absent:None ~enc_omit:Option.is_none ~enc:references
161
-
|> Jsont.Object.mem "sender" Jsont.(option (list Mail_address.jsont))
162
-
~dec_absent:None ~enc_omit:Option.is_none ~enc:sender
163
-
|> Jsont.Object.mem "from" Jsont.(option (list Mail_address.jsont))
164
-
~dec_absent:None ~enc_omit:Option.is_none ~enc:from
165
-
|> Jsont.Object.mem "to" Jsont.(option (list Mail_address.jsont))
166
-
~dec_absent:None ~enc_omit:Option.is_none ~enc:to_
167
-
|> Jsont.Object.mem "cc" Jsont.(option (list Mail_address.jsont))
168
-
~dec_absent:None ~enc_omit:Option.is_none ~enc:cc
169
-
|> Jsont.Object.mem "bcc" Jsont.(option (list Mail_address.jsont))
170
-
~dec_absent:None ~enc_omit:Option.is_none ~enc:bcc
171
-
|> Jsont.Object.mem "replyTo" Jsont.(option (list Mail_address.jsont))
172
-
~dec_absent:None ~enc_omit:Option.is_none ~enc:reply_to
173
-
|> Jsont.Object.mem "subject" nullable_string
174
-
~dec_absent:None ~enc_omit:Option.is_none ~enc:subject
373
+
(* Use null_safe_list for address fields that can be null *)
374
+
let addr_list = null_safe_list Mail_address.jsont in
375
+
let str_list = null_safe_list Jsont.string in
376
+
let part_list = null_safe_list Mail_body.Part.jsont in
377
+
let hdr_list = null_safe_list Mail_header.jsont in
378
+
Jsont.Object.map ~kind (fun id blob_id thread_id size received_at mailbox_ids keywords
379
+
message_id in_reply_to references sender from to_ cc bcc reply_to
380
+
subject sent_at headers body_structure body_values text_body html_body
381
+
attachments has_attachment preview unknown ->
382
+
let dynamic_headers = filter_header_props unknown in
383
+
make id blob_id thread_id size received_at mailbox_ids keywords
384
+
message_id in_reply_to references sender from to_ cc bcc reply_to
385
+
subject sent_at headers body_structure body_values text_body html_body
386
+
attachments has_attachment preview dynamic_headers)
387
+
|> Jsont.Object.opt_mem "id" Proto_id.jsont ~enc:id
388
+
|> Jsont.Object.opt_mem "blobId" Proto_id.jsont ~enc:blob_id
389
+
|> Jsont.Object.opt_mem "threadId" Proto_id.jsont ~enc:thread_id
390
+
|> Jsont.Object.opt_mem "size" Proto_int53.Unsigned.jsont ~enc:size
391
+
|> Jsont.Object.opt_mem "receivedAt" Proto_date.Utc.jsont ~enc:received_at
392
+
|> Jsont.Object.opt_mem "mailboxIds" Proto_json_map.id_to_bool ~enc:mailbox_ids
393
+
|> Jsont.Object.opt_mem "keywords" Proto_json_map.string_to_bool ~enc:keywords
394
+
|> Jsont.Object.opt_mem "messageId" str_list ~enc:message_id
395
+
|> Jsont.Object.opt_mem "inReplyTo" str_list ~enc:in_reply_to
396
+
|> Jsont.Object.opt_mem "references" str_list ~enc:references
397
+
|> Jsont.Object.opt_mem "sender" addr_list ~enc:sender
398
+
|> Jsont.Object.opt_mem "from" addr_list ~enc:from
399
+
|> Jsont.Object.opt_mem "to" addr_list ~enc:to_
400
+
|> Jsont.Object.opt_mem "cc" addr_list ~enc:cc
401
+
|> Jsont.Object.opt_mem "bcc" addr_list ~enc:bcc
402
+
|> Jsont.Object.opt_mem "replyTo" addr_list ~enc:reply_to
403
+
|> Jsont.Object.opt_mem "subject" Jsont.string ~enc:subject
175
404
|> Jsont.Object.opt_mem "sentAt" Proto_date.Rfc3339.jsont ~enc:sent_at
176
-
|> Jsont.Object.opt_mem "headers" (Jsont.list Mail_header.jsont) ~enc:headers
405
+
|> Jsont.Object.opt_mem "headers" hdr_list ~enc:headers
177
406
|> Jsont.Object.opt_mem "bodyStructure" Mail_body.Part.jsont ~enc:body_structure
178
407
|> Jsont.Object.opt_mem "bodyValues" body_values_jsont ~enc:body_values
179
-
|> Jsont.Object.opt_mem "textBody" (Jsont.list Mail_body.Part.jsont) ~enc:text_body
180
-
|> Jsont.Object.opt_mem "htmlBody" (Jsont.list Mail_body.Part.jsont) ~enc:html_body
181
-
|> Jsont.Object.opt_mem "attachments" (Jsont.list Mail_body.Part.jsont) ~enc:attachments
182
-
|> Jsont.Object.mem "hasAttachment" Jsont.bool ~dec_absent:false ~enc:has_attachment
183
-
|> Jsont.Object.mem "preview" Jsont.string ~dec_absent:"" ~enc:preview
408
+
|> Jsont.Object.opt_mem "textBody" part_list ~enc:text_body
409
+
|> Jsont.Object.opt_mem "htmlBody" part_list ~enc:html_body
410
+
|> Jsont.Object.opt_mem "attachments" part_list ~enc:attachments
411
+
|> Jsont.Object.opt_mem "hasAttachment" Jsont.bool ~enc:has_attachment
412
+
|> Jsont.Object.opt_mem "preview" Jsont.string ~enc:preview
413
+
|> Jsont.Object.keep_unknown
414
+
(Jsont.Object.Mems.string_map Jsont.json)
415
+
~enc:(fun t -> String_map.of_list t.dynamic_headers)
184
416
|> Jsont.Object.finish
185
417
186
418
module Filter_condition = struct
···
216
448
none_in_thread_have_keyword; has_keyword; not_keyword; has_attachment;
217
449
text; from; to_; cc; bcc; subject; body; header }
218
450
219
-
(* Header filter is encoded as [name] or [name, value] array *)
220
451
let header_jsont =
221
452
let kind = "HeaderFilter" in
222
453
let dec json =
···
262
493
end
263
494
264
495
type get_args_extra = {
265
-
body_properties : string list option;
496
+
body_properties : body_part_property list option;
266
497
fetch_text_body_values : bool;
267
498
fetch_html_body_values : bool;
268
499
fetch_all_body_values : bool;
269
500
max_body_value_bytes : int64 option;
270
501
}
271
502
272
-
let get_args_extra_make body_properties fetch_text_body_values
273
-
fetch_html_body_values fetch_all_body_values max_body_value_bytes =
503
+
let get_args_extra ?body_properties ?(fetch_text_body_values=false)
504
+
?(fetch_html_body_values=false) ?(fetch_all_body_values=false)
505
+
?max_body_value_bytes () =
274
506
{ body_properties; fetch_text_body_values; fetch_html_body_values;
275
507
fetch_all_body_values; max_body_value_bytes }
508
+
509
+
let body_part_property_list_jsont =
510
+
Jsont.list (Jsont.map ~kind:"body_part_property"
511
+
~dec:(fun s -> match body_part_property_of_string s with
512
+
| Some p -> p
513
+
| None -> Jsont.Error.msgf Jsont.Meta.none "Unknown body property: %s" s)
514
+
~enc:body_part_property_to_string
515
+
Jsont.string)
276
516
277
517
let get_args_extra_jsont =
278
518
let kind = "Email/get extra args" in
279
-
Jsont.Object.map ~kind get_args_extra_make
280
-
|> Jsont.Object.opt_mem "bodyProperties" (Jsont.list Jsont.string) ~enc:(fun a -> a.body_properties)
519
+
Jsont.Object.map ~kind (fun body_properties fetch_text_body_values
520
+
fetch_html_body_values fetch_all_body_values max_body_value_bytes ->
521
+
{ body_properties; fetch_text_body_values; fetch_html_body_values;
522
+
fetch_all_body_values; max_body_value_bytes })
523
+
|> Jsont.Object.opt_mem "bodyProperties" body_part_property_list_jsont
524
+
~enc:(fun a -> a.body_properties)
281
525
|> Jsont.Object.mem "fetchTextBodyValues" Jsont.bool ~dec_absent:false
282
526
~enc:(fun a -> a.fetch_text_body_values) ~enc_omit:(fun b -> not b)
283
527
|> Jsont.Object.mem "fetchHTMLBodyValues" Jsont.bool ~dec_absent:false
284
528
~enc:(fun a -> a.fetch_html_body_values) ~enc_omit:(fun b -> not b)
285
529
|> Jsont.Object.mem "fetchAllBodyValues" Jsont.bool ~dec_absent:false
286
530
~enc:(fun a -> a.fetch_all_body_values) ~enc_omit:(fun b -> not b)
287
-
|> Jsont.Object.opt_mem "maxBodyValueBytes" Proto_int53.Unsigned.jsont ~enc:(fun a -> a.max_body_value_bytes)
531
+
|> Jsont.Object.opt_mem "maxBodyValueBytes" Proto_int53.Unsigned.jsont
532
+
~enc:(fun a -> a.max_body_value_bytes)
288
533
|> Jsont.Object.finish
+176
-20
lib/mail/mail_email.mli
+176
-20
lib/mail/mail_email.mli
···
133
133
if no color bits are set (defaults to red when $flagged is set). *)
134
134
end
135
135
136
+
(** {1 Email Properties}
137
+
138
+
Polymorphic variants for type-safe property selection in Email/get requests.
139
+
These correspond to the properties defined in RFC 8621 Section 4.1. *)
140
+
141
+
(** Metadata properties (RFC 8621 Section 4.1.1).
142
+
These represent data about the message in the mail store. *)
143
+
type metadata_property = [
144
+
| `Id
145
+
| `Blob_id
146
+
| `Thread_id
147
+
| `Mailbox_ids
148
+
| `Keywords
149
+
| `Size
150
+
| `Received_at
151
+
]
152
+
153
+
(** Convenience header properties (RFC 8621 Section 4.1.3).
154
+
These are shortcuts for specific header:*:form properties. *)
155
+
type header_convenience_property = [
156
+
| `Message_id (** = header:Message-ID:asMessageIds *)
157
+
| `In_reply_to (** = header:In-Reply-To:asMessageIds *)
158
+
| `References (** = header:References:asMessageIds *)
159
+
| `Sender (** = header:Sender:asAddresses *)
160
+
| `From (** = header:From:asAddresses *)
161
+
| `To (** = header:To:asAddresses *)
162
+
| `Cc (** = header:Cc:asAddresses *)
163
+
| `Bcc (** = header:Bcc:asAddresses *)
164
+
| `Reply_to (** = header:Reply-To:asAddresses *)
165
+
| `Subject (** = header:Subject:asText *)
166
+
| `Sent_at (** = header:Date:asDate *)
167
+
| `Headers (** All headers in raw form *)
168
+
]
169
+
170
+
(** Body properties (RFC 8621 Section 4.1.4).
171
+
These represent the message body structure and content. *)
172
+
type body_property = [
173
+
| `Body_structure
174
+
| `Body_values
175
+
| `Text_body
176
+
| `Html_body
177
+
| `Attachments
178
+
| `Has_attachment
179
+
| `Preview
180
+
]
181
+
182
+
(** All standard Email properties. *)
183
+
type standard_property = [
184
+
| metadata_property
185
+
| header_convenience_property
186
+
| body_property
187
+
]
188
+
189
+
(** A dynamic header property request.
190
+
Use {!Mail_header.header_property} for type-safe construction. *)
191
+
type header_property = [ `Header of Mail_header.header_property ]
192
+
193
+
(** Any Email property - standard or dynamic header. *)
194
+
type property = [ standard_property | header_property ]
195
+
196
+
val property_to_string : [< property ] -> string
197
+
(** Convert a property to its wire name (e.g., [`From] -> "from"). *)
198
+
199
+
val property_of_string : string -> property option
200
+
(** Parse a property name. Returns [None] for unrecognized properties.
201
+
Handles both standard properties and header:* properties. *)
202
+
203
+
val standard_property_of_string : string -> standard_property option
204
+
(** Parse only standard property names (not header:* properties). *)
205
+
206
+
(** {1 Body Part Properties}
207
+
208
+
Properties that can be requested for EmailBodyPart objects
209
+
via the [bodyProperties] argument. *)
210
+
211
+
type body_part_property = [
212
+
| `Part_id
213
+
| `Blob_id
214
+
| `Size
215
+
| `Part_headers (** Named [headers] in the wire format *)
216
+
| `Name
217
+
| `Type
218
+
| `Charset
219
+
| `Disposition
220
+
| `Cid
221
+
| `Language
222
+
| `Location
223
+
| `Sub_parts
224
+
]
225
+
226
+
val body_part_property_to_string : [< body_part_property ] -> string
227
+
(** Convert a body part property to its wire name. *)
228
+
229
+
val body_part_property_of_string : string -> body_part_property option
230
+
(** Parse a body part property name. *)
231
+
136
232
(** {1 Email Object} *)
137
233
138
234
type t = {
139
235
(* Metadata - server-set, immutable *)
140
-
id : Proto_id.t;
141
-
blob_id : Proto_id.t;
142
-
thread_id : Proto_id.t;
143
-
size : int64;
144
-
received_at : Ptime.t;
236
+
id : Proto_id.t option;
237
+
blob_id : Proto_id.t option;
238
+
thread_id : Proto_id.t option;
239
+
size : int64 option;
240
+
received_at : Ptime.t option;
145
241
146
242
(* Metadata - mutable *)
147
-
mailbox_ids : (Proto_id.t * bool) list;
148
-
keywords : (string * bool) list;
243
+
mailbox_ids : (Proto_id.t * bool) list option;
244
+
keywords : (string * bool) list option;
149
245
150
246
(* Parsed headers *)
151
247
message_id : string list option;
···
169
265
text_body : Mail_body.Part.t list option;
170
266
html_body : Mail_body.Part.t list option;
171
267
attachments : Mail_body.Part.t list option;
172
-
has_attachment : bool;
173
-
preview : string;
268
+
has_attachment : bool option;
269
+
preview : string option;
270
+
271
+
(* Dynamic header properties - stored as raw JSON for lazy decoding *)
272
+
dynamic_headers : (string * Jsont.json) list;
273
+
(** Raw header values from [header:*] property requests.
274
+
The key is the full property name (e.g., "header:X-Custom:asText").
275
+
Use {!decode_header_value} to parse into typed values. *)
174
276
}
175
277
176
-
val id : t -> Proto_id.t
177
-
val blob_id : t -> Proto_id.t
178
-
val thread_id : t -> Proto_id.t
179
-
val size : t -> int64
180
-
val received_at : t -> Ptime.t
181
-
val mailbox_ids : t -> (Proto_id.t * bool) list
182
-
val keywords : t -> (string * bool) list
278
+
(** {2 Accessors}
279
+
280
+
All accessors return [option] types since the response only includes
281
+
properties that were requested. *)
282
+
283
+
val id : t -> Proto_id.t option
284
+
val blob_id : t -> Proto_id.t option
285
+
val thread_id : t -> Proto_id.t option
286
+
val size : t -> int64 option
287
+
val received_at : t -> Ptime.t option
288
+
val mailbox_ids : t -> (Proto_id.t * bool) list option
289
+
val keywords : t -> (string * bool) list option
183
290
val message_id : t -> string list option
184
291
val in_reply_to : t -> string list option
185
292
val references : t -> string list option
···
197
304
val text_body : t -> Mail_body.Part.t list option
198
305
val html_body : t -> Mail_body.Part.t list option
199
306
val attachments : t -> Mail_body.Part.t list option
200
-
val has_attachment : t -> bool
201
-
val preview : t -> string
307
+
val has_attachment : t -> bool option
308
+
val preview : t -> string option
309
+
val dynamic_headers_raw : t -> (string * Jsont.json) list
310
+
(** Get raw dynamic headers. Use {!decode_header_value} to parse them. *)
311
+
312
+
(** {2 Dynamic Header Decoding} *)
313
+
314
+
val decode_header_value : string -> Jsont.json -> Mail_header.header_value option
315
+
(** [decode_header_value prop_name json] decodes a raw JSON value into a typed
316
+
header value based on the property name. The property name determines the form:
317
+
- [header:Name] or [header:Name:all] -> Raw/Text (String_single/String_all)
318
+
- [header:Name:asText] -> Text (String_single)
319
+
- [header:Name:asAddresses] -> Addresses (Addresses_single)
320
+
- [header:Name:asGroupedAddresses] -> Grouped (Grouped_single)
321
+
- [header:Name:asMessageIds] -> MessageIds (Strings_single)
322
+
- [header:Name:asDate] -> Date (Date_single)
323
+
- [header:Name:asURLs] -> URLs (Strings_single)
324
+
Returns [None] if the property name is invalid or decoding fails. *)
325
+
326
+
val get_header : t -> string -> Mail_header.header_value option
327
+
(** [get_header email key] looks up and decodes a dynamic header by its full
328
+
property name. E.g., [get_header email "header:X-Custom:asText"]. *)
329
+
330
+
val get_header_string : t -> string -> string option
331
+
(** [get_header_string email key] looks up a string header value.
332
+
Returns [None] if not found or if the value is not a string type. *)
333
+
334
+
val get_header_addresses : t -> string -> Mail_address.t list option
335
+
(** [get_header_addresses email key] looks up an addresses header value.
336
+
Returns [None] if not found or if the value is not an addresses type. *)
202
337
203
338
val jsont : t Jsont.t
339
+
(** Permissive JSON codec that handles any subset of properties.
340
+
Unknown [header:*] properties are decoded into {!dynamic_headers}. *)
204
341
205
342
(** {1 Email Filter Conditions} *)
206
343
···
233
370
234
371
(** {1 Email/get Arguments} *)
235
372
236
-
(** Extra arguments for Email/get beyond standard /get. *)
373
+
(** Extra arguments for Email/get beyond standard /get.
374
+
375
+
Note: The standard [properties] argument from {!Proto_method.get_args}
376
+
should use {!property} variants converted via {!property_to_string}. *)
237
377
type get_args_extra = {
238
-
body_properties : string list option;
378
+
body_properties : body_part_property list option;
379
+
(** Properties to fetch for each EmailBodyPart.
380
+
If omitted, defaults to all properties. *)
239
381
fetch_text_body_values : bool;
382
+
(** If [true], fetch body values for text/* parts in textBody. *)
240
383
fetch_html_body_values : bool;
384
+
(** If [true], fetch body values for text/* parts in htmlBody. *)
241
385
fetch_all_body_values : bool;
386
+
(** If [true], fetch body values for all text/* parts. *)
242
387
max_body_value_bytes : int64 option;
388
+
(** Maximum size of body values to return. Larger values are truncated. *)
243
389
}
390
+
391
+
val get_args_extra :
392
+
?body_properties:body_part_property list ->
393
+
?fetch_text_body_values:bool ->
394
+
?fetch_html_body_values:bool ->
395
+
?fetch_all_body_values:bool ->
396
+
?max_body_value_bytes:int64 ->
397
+
unit ->
398
+
get_args_extra
399
+
(** Convenience constructor with sensible defaults. *)
244
400
245
401
val get_args_extra_jsont : get_args_extra Jsont.t
+332
-1
lib/mail/mail_header.ml
+332
-1
lib/mail/mail_header.ml
···
22
22
|> Jsont.Object.mem "value" Jsont.string ~enc:value
23
23
|> Jsont.Object.finish
24
24
25
-
(* Header parsed forms - these are used with header:Name:form properties *)
25
+
(* Header categories *)
26
+
27
+
type address_header = [
28
+
| `From
29
+
| `Sender
30
+
| `Reply_to
31
+
| `To
32
+
| `Cc
33
+
| `Bcc
34
+
| `Resent_from
35
+
| `Resent_sender
36
+
| `Resent_reply_to
37
+
| `Resent_to
38
+
| `Resent_cc
39
+
| `Resent_bcc
40
+
]
41
+
42
+
type message_id_header = [
43
+
| `Message_id
44
+
| `In_reply_to
45
+
| `References
46
+
| `Resent_message_id
47
+
]
48
+
49
+
type date_header = [
50
+
| `Date
51
+
| `Resent_date
52
+
]
53
+
54
+
type url_header = [
55
+
| `List_help
56
+
| `List_unsubscribe
57
+
| `List_subscribe
58
+
| `List_post
59
+
| `List_owner
60
+
| `List_archive
61
+
]
62
+
63
+
type text_header = [
64
+
| `Subject
65
+
| `Comments
66
+
| `Keywords
67
+
| `List_id
68
+
]
69
+
70
+
type standard_header = [
71
+
| address_header
72
+
| message_id_header
73
+
| date_header
74
+
| url_header
75
+
| text_header
76
+
]
77
+
78
+
type custom_header = [ `Custom of string ]
79
+
80
+
type any_header = [ standard_header | custom_header ]
81
+
82
+
let standard_header_to_string : [< standard_header ] -> string = function
83
+
| `From -> "From"
84
+
| `Sender -> "Sender"
85
+
| `Reply_to -> "Reply-To"
86
+
| `To -> "To"
87
+
| `Cc -> "Cc"
88
+
| `Bcc -> "Bcc"
89
+
| `Resent_from -> "Resent-From"
90
+
| `Resent_sender -> "Resent-Sender"
91
+
| `Resent_reply_to -> "Resent-Reply-To"
92
+
| `Resent_to -> "Resent-To"
93
+
| `Resent_cc -> "Resent-Cc"
94
+
| `Resent_bcc -> "Resent-Bcc"
95
+
| `Message_id -> "Message-ID"
96
+
| `In_reply_to -> "In-Reply-To"
97
+
| `References -> "References"
98
+
| `Resent_message_id -> "Resent-Message-ID"
99
+
| `Date -> "Date"
100
+
| `Resent_date -> "Resent-Date"
101
+
| `List_help -> "List-Help"
102
+
| `List_unsubscribe -> "List-Unsubscribe"
103
+
| `List_subscribe -> "List-Subscribe"
104
+
| `List_post -> "List-Post"
105
+
| `List_owner -> "List-Owner"
106
+
| `List_archive -> "List-Archive"
107
+
| `Subject -> "Subject"
108
+
| `Comments -> "Comments"
109
+
| `Keywords -> "Keywords"
110
+
| `List_id -> "List-Id"
111
+
112
+
let standard_header_of_string s : standard_header option =
113
+
match String.lowercase_ascii s with
114
+
| "from" -> Some `From
115
+
| "sender" -> Some `Sender
116
+
| "reply-to" -> Some `Reply_to
117
+
| "to" -> Some `To
118
+
| "cc" -> Some `Cc
119
+
| "bcc" -> Some `Bcc
120
+
| "resent-from" -> Some `Resent_from
121
+
| "resent-sender" -> Some `Resent_sender
122
+
| "resent-reply-to" -> Some `Resent_reply_to
123
+
| "resent-to" -> Some `Resent_to
124
+
| "resent-cc" -> Some `Resent_cc
125
+
| "resent-bcc" -> Some `Resent_bcc
126
+
| "message-id" -> Some `Message_id
127
+
| "in-reply-to" -> Some `In_reply_to
128
+
| "references" -> Some `References
129
+
| "resent-message-id" -> Some `Resent_message_id
130
+
| "date" -> Some `Date
131
+
| "resent-date" -> Some `Resent_date
132
+
| "list-help" -> Some `List_help
133
+
| "list-unsubscribe" -> Some `List_unsubscribe
134
+
| "list-subscribe" -> Some `List_subscribe
135
+
| "list-post" -> Some `List_post
136
+
| "list-owner" -> Some `List_owner
137
+
| "list-archive" -> Some `List_archive
138
+
| "subject" -> Some `Subject
139
+
| "comments" -> Some `Comments
140
+
| "keywords" -> Some `Keywords
141
+
| "list-id" -> Some `List_id
142
+
| _ -> None
143
+
144
+
let any_header_to_string : [< any_header ] -> string = function
145
+
| `Custom s -> s
146
+
| #standard_header as h -> standard_header_to_string h
147
+
148
+
(* Header parsed forms *)
149
+
150
+
type form = [
151
+
| `Raw
152
+
| `Text
153
+
| `Addresses
154
+
| `Grouped_addresses
155
+
| `Message_ids
156
+
| `Date
157
+
| `Urls
158
+
]
159
+
160
+
let form_to_string : [< form ] -> string = function
161
+
| `Raw -> ""
162
+
| `Text -> "asText"
163
+
| `Addresses -> "asAddresses"
164
+
| `Grouped_addresses -> "asGroupedAddresses"
165
+
| `Message_ids -> "asMessageIds"
166
+
| `Date -> "asDate"
167
+
| `Urls -> "asURLs"
168
+
169
+
let form_of_string s : form option =
170
+
match s with
171
+
| "" -> Some `Raw
172
+
| "asText" -> Some `Text
173
+
| "asAddresses" -> Some `Addresses
174
+
| "asGroupedAddresses" -> Some `Grouped_addresses
175
+
| "asMessageIds" -> Some `Message_ids
176
+
| "asDate" -> Some `Date
177
+
| "asURLs" -> Some `Urls
178
+
| _ -> None
179
+
180
+
(* Header property requests *)
181
+
182
+
type header_property =
183
+
| Raw of { name : string; all : bool }
184
+
| Text of { header : [ text_header | custom_header ]; all : bool }
185
+
| Addresses of { header : [ address_header | custom_header ]; all : bool }
186
+
| Grouped_addresses of { header : [ address_header | custom_header ]; all : bool }
187
+
| Message_ids of { header : [ message_id_header | custom_header ]; all : bool }
188
+
| Date of { header : [ date_header | custom_header ]; all : bool }
189
+
| Urls of { header : [ url_header | custom_header ]; all : bool }
190
+
191
+
let header_name_of_property : header_property -> string = function
192
+
| Raw { name; _ } -> name
193
+
| Text { header; _ } -> any_header_to_string (header :> any_header)
194
+
| Addresses { header; _ } -> any_header_to_string (header :> any_header)
195
+
| Grouped_addresses { header; _ } -> any_header_to_string (header :> any_header)
196
+
| Message_ids { header; _ } -> any_header_to_string (header :> any_header)
197
+
| Date { header; _ } -> any_header_to_string (header :> any_header)
198
+
| Urls { header; _ } -> any_header_to_string (header :> any_header)
199
+
200
+
let header_property_all : header_property -> bool = function
201
+
| Raw { all; _ } -> all
202
+
| Text { all; _ } -> all
203
+
| Addresses { all; _ } -> all
204
+
| Grouped_addresses { all; _ } -> all
205
+
| Message_ids { all; _ } -> all
206
+
| Date { all; _ } -> all
207
+
| Urls { all; _ } -> all
208
+
209
+
let header_property_form : header_property -> form = function
210
+
| Raw _ -> `Raw
211
+
| Text _ -> `Text
212
+
| Addresses _ -> `Addresses
213
+
| Grouped_addresses _ -> `Grouped_addresses
214
+
| Message_ids _ -> `Message_ids
215
+
| Date _ -> `Date
216
+
| Urls _ -> `Urls
217
+
218
+
let header_property_to_string prop =
219
+
let name = header_name_of_property prop in
220
+
let form = form_to_string (header_property_form prop) in
221
+
let all_suffix = if header_property_all prop then ":all" else "" in
222
+
let form_suffix = if form = "" then "" else ":" ^ form in
223
+
"header:" ^ name ^ form_suffix ^ all_suffix
224
+
225
+
let header_property_of_string s : header_property option =
226
+
if not (String.length s > 7 && String.sub s 0 7 = "header:") then
227
+
None
228
+
else
229
+
let rest = String.sub s 7 (String.length s - 7) in
230
+
(* Parse the parts: name[:form][:all] *)
231
+
let parts = String.split_on_char ':' rest in
232
+
match parts with
233
+
| [] -> None
234
+
| [name] ->
235
+
Some (Raw { name; all = false })
236
+
| [name; second] ->
237
+
if second = "all" then
238
+
Some (Raw { name; all = true })
239
+
else begin
240
+
match form_of_string second with
241
+
| None -> None
242
+
| Some `Raw -> Some (Raw { name; all = false })
243
+
| Some `Text -> Some (Text { header = `Custom name; all = false })
244
+
| Some `Addresses -> Some (Addresses { header = `Custom name; all = false })
245
+
| Some `Grouped_addresses -> Some (Grouped_addresses { header = `Custom name; all = false })
246
+
| Some `Message_ids -> Some (Message_ids { header = `Custom name; all = false })
247
+
| Some `Date -> Some (Date { header = `Custom name; all = false })
248
+
| Some `Urls -> Some (Urls { header = `Custom name; all = false })
249
+
end
250
+
| [name; form_str; "all"] ->
251
+
begin match form_of_string form_str with
252
+
| None -> None
253
+
| Some `Raw -> Some (Raw { name; all = true })
254
+
| Some `Text -> Some (Text { header = `Custom name; all = true })
255
+
| Some `Addresses -> Some (Addresses { header = `Custom name; all = true })
256
+
| Some `Grouped_addresses -> Some (Grouped_addresses { header = `Custom name; all = true })
257
+
| Some `Message_ids -> Some (Message_ids { header = `Custom name; all = true })
258
+
| Some `Date -> Some (Date { header = `Custom name; all = true })
259
+
| Some `Urls -> Some (Urls { header = `Custom name; all = true })
260
+
end
261
+
| _ -> None
262
+
263
+
(* Convenience constructors *)
264
+
265
+
let raw ?(all=false) name = Raw { name; all }
266
+
267
+
let text ?(all=false) header = Text { header; all }
268
+
269
+
let addresses ?(all=false) header = Addresses { header; all }
270
+
271
+
let grouped_addresses ?(all=false) header = Grouped_addresses { header; all }
272
+
273
+
let message_ids ?(all=false) header = Message_ids { header; all }
274
+
275
+
let date ?(all=false) header = Date { header; all }
276
+
277
+
let urls ?(all=false) header = Urls { header; all }
278
+
279
+
(* Header values in responses *)
280
+
281
+
type header_value =
282
+
| String_single of string option
283
+
| String_all of string list
284
+
| Addresses_single of Mail_address.t list option
285
+
| Addresses_all of Mail_address.t list list
286
+
| Grouped_single of Mail_address.Group.t list option
287
+
| Grouped_all of Mail_address.Group.t list list
288
+
| Date_single of Ptime.t option
289
+
| Date_all of Ptime.t option list
290
+
| Strings_single of string list option
291
+
| Strings_all of string list option list
292
+
293
+
let header_value_jsont ~form ~all : header_value Jsont.t =
294
+
match form, all with
295
+
| (`Raw | `Text), false ->
296
+
Jsont.map
297
+
~dec:(fun s -> String_single s)
298
+
~enc:(function String_single s -> s | _ -> None)
299
+
(Jsont.option Jsont.string)
300
+
| (`Raw | `Text), true ->
301
+
Jsont.map
302
+
~dec:(fun l -> String_all l)
303
+
~enc:(function String_all l -> l | _ -> [])
304
+
(Jsont.list Jsont.string)
305
+
| `Addresses, false ->
306
+
Jsont.map
307
+
~dec:(fun l -> Addresses_single l)
308
+
~enc:(function Addresses_single l -> l | _ -> None)
309
+
(Jsont.option (Jsont.list Mail_address.jsont))
310
+
| `Addresses, true ->
311
+
Jsont.map
312
+
~dec:(fun l -> Addresses_all l)
313
+
~enc:(function Addresses_all l -> l | _ -> [])
314
+
(Jsont.list (Jsont.list Mail_address.jsont))
315
+
| `Grouped_addresses, false ->
316
+
Jsont.map
317
+
~dec:(fun l -> Grouped_single l)
318
+
~enc:(function Grouped_single l -> l | _ -> None)
319
+
(Jsont.option (Jsont.list Mail_address.Group.jsont))
320
+
| `Grouped_addresses, true ->
321
+
Jsont.map
322
+
~dec:(fun l -> Grouped_all l)
323
+
~enc:(function Grouped_all l -> l | _ -> [])
324
+
(Jsont.list (Jsont.list Mail_address.Group.jsont))
325
+
| `Message_ids, false ->
326
+
Jsont.map
327
+
~dec:(fun l -> Strings_single l)
328
+
~enc:(function Strings_single l -> l | _ -> None)
329
+
(Jsont.option (Jsont.list Jsont.string))
330
+
| `Message_ids, true ->
331
+
Jsont.map
332
+
~dec:(fun l -> Strings_all l)
333
+
~enc:(function Strings_all l -> l | _ -> [])
334
+
(Jsont.list (Jsont.option (Jsont.list Jsont.string)))
335
+
| `Date, false ->
336
+
Jsont.map
337
+
~dec:(fun t -> Date_single t)
338
+
~enc:(function Date_single t -> t | _ -> None)
339
+
(Jsont.option Proto_date.Rfc3339.jsont)
340
+
| `Date, true ->
341
+
Jsont.map
342
+
~dec:(fun l -> Date_all l)
343
+
~enc:(function Date_all l -> l | _ -> [])
344
+
(Jsont.list (Jsont.option Proto_date.Rfc3339.jsont))
345
+
| `Urls, false ->
346
+
Jsont.map
347
+
~dec:(fun l -> Strings_single l)
348
+
~enc:(function Strings_single l -> l | _ -> None)
349
+
(Jsont.option (Jsont.list Jsont.string))
350
+
| `Urls, true ->
351
+
Jsont.map
352
+
~dec:(fun l -> Strings_all l)
353
+
~enc:(function Strings_all l -> l | _ -> [])
354
+
(Jsont.list (Jsont.option (Jsont.list Jsont.string)))
355
+
356
+
(* Low-level JSON codecs *)
26
357
27
358
let raw_jsont = Jsont.string
28
359
+234
-2
lib/mail/mail_header.mli
+234
-2
lib/mail/mail_header.mli
···
3
3
SPDX-License-Identifier: ISC
4
4
---------------------------------------------------------------------------*)
5
5
6
-
(** Email header types as defined in RFC 8621 Section 4.1.2
6
+
(** Email header types as defined in RFC 8621 Section 4.1.2
7
7
8
8
@canonical Jmap.Proto.Email_header *)
9
9
···
24
24
25
25
val jsont : t Jsont.t
26
26
27
+
(** {1 Header Categories}
28
+
29
+
RFC 8621 Section 4.1.2 restricts which parsed forms can be used with
30
+
which headers. These polymorphic variant types encode those restrictions
31
+
at the type level.
32
+
33
+
Each category corresponds to headers that share the same allowed forms:
34
+
- Address headers: can use [Addresses] and [Grouped_addresses] forms
35
+
- Message-ID headers: can use [Message_ids] form
36
+
- Date headers: can use [Date] form
37
+
- URL headers: can use [Urls] form
38
+
- Text headers: can use [Text] form
39
+
- All headers can use [Raw] form
40
+
- Custom headers (not in RFC 5322/2369) can use any form *)
41
+
42
+
(** Headers that allow the [Addresses] and [Grouped_addresses] forms.
43
+
These are address-list headers per RFC 5322. *)
44
+
type address_header = [
45
+
| `From
46
+
| `Sender
47
+
| `Reply_to
48
+
| `To
49
+
| `Cc
50
+
| `Bcc
51
+
| `Resent_from
52
+
| `Resent_sender
53
+
| `Resent_reply_to
54
+
| `Resent_to
55
+
| `Resent_cc
56
+
| `Resent_bcc
57
+
]
58
+
59
+
(** Headers that allow the [Message_ids] form.
60
+
These contain msg-id values per RFC 5322. *)
61
+
type message_id_header = [
62
+
| `Message_id
63
+
| `In_reply_to
64
+
| `References
65
+
| `Resent_message_id
66
+
]
67
+
68
+
(** Headers that allow the [Date] form.
69
+
These contain date-time values per RFC 5322. *)
70
+
type date_header = [
71
+
| `Date
72
+
| `Resent_date
73
+
]
74
+
75
+
(** Headers that allow the [Urls] form.
76
+
These are list-* headers per RFC 2369. *)
77
+
type url_header = [
78
+
| `List_help
79
+
| `List_unsubscribe
80
+
| `List_subscribe
81
+
| `List_post
82
+
| `List_owner
83
+
| `List_archive
84
+
]
85
+
86
+
(** Headers that allow the [Text] form.
87
+
These contain unstructured or phrase content. *)
88
+
type text_header = [
89
+
| `Subject
90
+
| `Comments
91
+
| `Keywords
92
+
| `List_id
93
+
]
94
+
95
+
(** All standard headers defined in RFC 5322 and RFC 2369. *)
96
+
type standard_header = [
97
+
| address_header
98
+
| message_id_header
99
+
| date_header
100
+
| url_header
101
+
| text_header
102
+
]
103
+
104
+
(** A custom header not defined in RFC 5322 or RFC 2369.
105
+
Custom headers can use any parsed form. *)
106
+
type custom_header = [ `Custom of string ]
107
+
108
+
(** Any header - standard or custom. *)
109
+
type any_header = [ standard_header | custom_header ]
110
+
111
+
(** {2 Header Name Conversion} *)
112
+
113
+
val standard_header_to_string : [< standard_header ] -> string
114
+
(** Convert a standard header variant to its wire name (e.g., [`From] -> "From"). *)
115
+
116
+
val standard_header_of_string : string -> standard_header option
117
+
(** Parse a header name to a standard header variant, case-insensitive.
118
+
Returns [None] for non-standard headers. *)
119
+
120
+
val any_header_to_string : [< any_header ] -> string
121
+
(** Convert any header variant to its wire name. *)
122
+
27
123
(** {1 Header Parsed Forms}
28
124
29
125
RFC 8621 defines several parsed forms for headers.
30
-
These can be requested via the header:Name:form properties. *)
126
+
These can be requested via the [header:Name:form] properties. *)
127
+
128
+
(** The parsed form to request for a header value. *)
129
+
type form = [
130
+
| `Raw (** Raw octets, available for all headers *)
131
+
| `Text (** Decoded text, for text headers or custom *)
132
+
| `Addresses (** Flat address list, for address headers or custom *)
133
+
| `Grouped_addresses (** Address list with groups, for address headers or custom *)
134
+
| `Message_ids (** List of message-id strings, for message-id headers or custom *)
135
+
| `Date (** Parsed date, for date headers or custom *)
136
+
| `Urls (** List of URLs, for url headers or custom *)
137
+
]
138
+
139
+
val form_to_string : [< form ] -> string
140
+
(** Convert form to wire suffix (e.g., [`Addresses] -> "asAddresses").
141
+
[`Raw] returns the empty string (raw is the default). *)
142
+
143
+
val form_of_string : string -> form option
144
+
(** Parse a form suffix (e.g., "asAddresses" -> [`Addresses]).
145
+
Empty string returns [`Raw]. *)
146
+
147
+
(** {1 Header Property Requests}
148
+
149
+
Type-safe construction of [header:Name:form:all] property strings.
150
+
The GADT ensures that only valid form/header combinations are allowed. *)
151
+
152
+
(** A header property request with type-safe form selection.
153
+
154
+
The type parameter encodes what forms are allowed:
155
+
- Address headers allow [Addresses] and [Grouped_addresses]
156
+
- Message-ID headers allow [Message_ids]
157
+
- Date headers allow [Date]
158
+
- URL headers allow [Urls]
159
+
- Text headers allow [Text]
160
+
- All headers allow [Raw]
161
+
- Custom headers allow any form *)
162
+
type header_property =
163
+
| Raw of { name : string; all : bool }
164
+
(** Raw form, available for any header. *)
165
+
166
+
| Text of { header : [ text_header | custom_header ]; all : bool }
167
+
(** Text form, for text headers or custom. *)
168
+
169
+
| Addresses of { header : [ address_header | custom_header ]; all : bool }
170
+
(** Addresses form, for address headers or custom. *)
171
+
172
+
| Grouped_addresses of { header : [ address_header | custom_header ]; all : bool }
173
+
(** GroupedAddresses form, for address headers or custom. *)
174
+
175
+
| Message_ids of { header : [ message_id_header | custom_header ]; all : bool }
176
+
(** MessageIds form, for message-id headers or custom. *)
177
+
178
+
| Date of { header : [ date_header | custom_header ]; all : bool }
179
+
(** Date form, for date headers or custom. *)
180
+
181
+
| Urls of { header : [ url_header | custom_header ]; all : bool }
182
+
(** URLs form, for URL headers or custom. *)
183
+
184
+
val header_property_to_string : header_property -> string
185
+
(** Convert a header property request to wire format.
186
+
E.g., [Addresses { header = `From; all = true }] -> "header:From:asAddresses:all" *)
187
+
188
+
val header_property_of_string : string -> header_property option
189
+
(** Parse a header property string.
190
+
Returns [None] if the string doesn't match [header:*] format. *)
191
+
192
+
(** {2 Convenience Constructors} *)
193
+
194
+
val raw : ?all:bool -> string -> header_property
195
+
(** [raw ?all name] creates a raw header property request. *)
196
+
197
+
val text : ?all:bool -> [ text_header | custom_header ] -> header_property
198
+
(** [text ?all header] creates a text header property request. *)
199
+
200
+
val addresses : ?all:bool -> [ address_header | custom_header ] -> header_property
201
+
(** [addresses ?all header] creates an addresses header property request. *)
202
+
203
+
val grouped_addresses : ?all:bool -> [ address_header | custom_header ] -> header_property
204
+
(** [grouped_addresses ?all header] creates a grouped addresses header property request. *)
205
+
206
+
val message_ids : ?all:bool -> [ message_id_header | custom_header ] -> header_property
207
+
(** [message_ids ?all header] creates a message-ids header property request. *)
208
+
209
+
val date : ?all:bool -> [ date_header | custom_header ] -> header_property
210
+
(** [date ?all header] creates a date header property request. *)
211
+
212
+
val urls : ?all:bool -> [ url_header | custom_header ] -> header_property
213
+
(** [urls ?all header] creates a URLs header property request. *)
214
+
215
+
(** {1 Header Values in Responses}
216
+
217
+
When fetching dynamic headers, the response value type depends on the
218
+
requested form. This type captures all possible response shapes. *)
219
+
220
+
(** A header value from the response.
221
+
222
+
The variant encodes both the form and whether [:all] was requested:
223
+
- [*_single] variants: value of the last header instance, or [None] if absent
224
+
- [*_all] variants: list of values for all instances, empty if absent *)
225
+
type header_value =
226
+
| String_single of string option
227
+
(** Raw or Text form, single instance. *)
228
+
229
+
| String_all of string list
230
+
(** Raw or Text form, all instances. *)
231
+
232
+
| Addresses_single of Mail_address.t list option
233
+
(** Addresses form, single instance. *)
234
+
235
+
| Addresses_all of Mail_address.t list list
236
+
(** Addresses form, all instances. *)
237
+
238
+
| Grouped_single of Mail_address.Group.t list option
239
+
(** GroupedAddresses form, single instance. *)
240
+
241
+
| Grouped_all of Mail_address.Group.t list list
242
+
(** GroupedAddresses form, all instances. *)
243
+
244
+
| Date_single of Ptime.t option
245
+
(** Date form, single instance. *)
246
+
247
+
| Date_all of Ptime.t option list
248
+
(** Date form, all instances. *)
249
+
250
+
| Strings_single of string list option
251
+
(** MessageIds or URLs form, single instance. *)
252
+
253
+
| Strings_all of string list option list
254
+
(** MessageIds or URLs form, all instances. *)
255
+
256
+
val header_value_jsont : form:form -> all:bool -> header_value Jsont.t
257
+
(** [header_value_jsont ~form ~all] returns a JSON codec for header values
258
+
with the given form and multiplicity. *)
259
+
260
+
(** {1 Low-level JSON Codecs}
261
+
262
+
These codecs are used internally and for custom header processing. *)
31
263
32
264
(** The raw form - header value as-is. *)
33
265
val raw_jsont : string Jsont.t
+49
-12
lib/mail/mail_identity.ml
+49
-12
lib/mail/mail_identity.ml
···
3
3
SPDX-License-Identifier: ISC
4
4
---------------------------------------------------------------------------*)
5
5
6
+
(* Identity properties *)
7
+
8
+
type property = [
9
+
| `Id
10
+
| `Name
11
+
| `Email
12
+
| `Reply_to
13
+
| `Bcc
14
+
| `Text_signature
15
+
| `Html_signature
16
+
| `May_delete
17
+
]
18
+
19
+
let property_to_string : [< property ] -> string = function
20
+
| `Id -> "id"
21
+
| `Name -> "name"
22
+
| `Email -> "email"
23
+
| `Reply_to -> "replyTo"
24
+
| `Bcc -> "bcc"
25
+
| `Text_signature -> "textSignature"
26
+
| `Html_signature -> "htmlSignature"
27
+
| `May_delete -> "mayDelete"
28
+
29
+
let property_of_string s : property option =
30
+
match s with
31
+
| "id" -> Some `Id
32
+
| "name" -> Some `Name
33
+
| "email" -> Some `Email
34
+
| "replyTo" -> Some `Reply_to
35
+
| "bcc" -> Some `Bcc
36
+
| "textSignature" -> Some `Text_signature
37
+
| "htmlSignature" -> Some `Html_signature
38
+
| "mayDelete" -> Some `May_delete
39
+
| _ -> None
40
+
41
+
(* Identity type *)
42
+
6
43
type t = {
7
-
id : Proto_id.t;
8
-
name : string;
9
-
email : string;
44
+
id : Proto_id.t option;
45
+
name : string option;
46
+
email : string option;
10
47
reply_to : Mail_address.t list option;
11
48
bcc : Mail_address.t list option;
12
-
text_signature : string;
13
-
html_signature : string;
14
-
may_delete : bool;
49
+
text_signature : string option;
50
+
html_signature : string option;
51
+
may_delete : bool option;
15
52
}
16
53
17
54
let id t = t.id
···
29
66
let jsont =
30
67
let kind = "Identity" in
31
68
Jsont.Object.map ~kind make
32
-
|> Jsont.Object.mem "id" Proto_id.jsont ~enc:id
33
-
|> Jsont.Object.mem "name" Jsont.string ~dec_absent:"" ~enc:name
34
-
|> Jsont.Object.mem "email" Jsont.string ~enc:email
69
+
|> Jsont.Object.opt_mem "id" Proto_id.jsont ~enc:id
70
+
|> Jsont.Object.opt_mem "name" Jsont.string ~enc:name
71
+
|> Jsont.Object.opt_mem "email" Jsont.string ~enc:email
35
72
|> Jsont.Object.opt_mem "replyTo" (Jsont.list Mail_address.jsont) ~enc:reply_to
36
73
|> Jsont.Object.opt_mem "bcc" (Jsont.list Mail_address.jsont) ~enc:bcc
37
-
|> Jsont.Object.mem "textSignature" Jsont.string ~dec_absent:"" ~enc:text_signature
38
-
|> Jsont.Object.mem "htmlSignature" Jsont.string ~dec_absent:"" ~enc:html_signature
39
-
|> Jsont.Object.mem "mayDelete" Jsont.bool ~enc:may_delete
74
+
|> Jsont.Object.opt_mem "textSignature" Jsont.string ~enc:text_signature
75
+
|> Jsont.Object.opt_mem "htmlSignature" Jsont.string ~enc:html_signature
76
+
|> Jsont.Object.opt_mem "mayDelete" Jsont.bool ~enc:may_delete
40
77
|> Jsont.Object.finish
+38
-13
lib/mail/mail_identity.mli
+38
-13
lib/mail/mail_identity.mli
···
3
3
SPDX-License-Identifier: ISC
4
4
---------------------------------------------------------------------------*)
5
5
6
-
(** Identity type as defined in RFC 8621 Section 6
6
+
(** Identity type as defined in RFC 8621 Section 6
7
7
8
8
@canonical Jmap.Proto.Identity *)
9
9
10
+
(** {1 Identity Properties}
11
+
12
+
Polymorphic variants for type-safe property selection in Identity/get requests.
13
+
These correspond to the properties defined in RFC 8621 Section 6. *)
14
+
15
+
(** All Identity properties that can be requested. *)
16
+
type property = [
17
+
| `Id
18
+
| `Name
19
+
| `Email
20
+
| `Reply_to
21
+
| `Bcc
22
+
| `Text_signature
23
+
| `Html_signature
24
+
| `May_delete
25
+
]
26
+
27
+
val property_to_string : [< property ] -> string
28
+
(** Convert a property to its wire name (e.g., [`Text_signature] -> "textSignature"). *)
29
+
30
+
val property_of_string : string -> property option
31
+
(** Parse a property name, case-sensitive. *)
32
+
33
+
(** {1 Identity Object} *)
34
+
10
35
type t = {
11
-
id : Proto_id.t;
36
+
id : Proto_id.t option;
12
37
(** Server-assigned identity id. *)
13
-
name : string;
38
+
name : string option;
14
39
(** Display name for sent emails. *)
15
-
email : string;
40
+
email : string option;
16
41
(** The email address to use. *)
17
42
reply_to : Mail_address.t list option;
18
43
(** Default Reply-To addresses. *)
19
44
bcc : Mail_address.t list option;
20
45
(** Default BCC addresses. *)
21
-
text_signature : string;
46
+
text_signature : string option;
22
47
(** Plain text signature. *)
23
-
html_signature : string;
48
+
html_signature : string option;
24
49
(** HTML signature. *)
25
-
may_delete : bool;
50
+
may_delete : bool option;
26
51
(** Whether the user may delete this identity. *)
27
52
}
28
53
29
-
val id : t -> Proto_id.t
30
-
val name : t -> string
31
-
val email : t -> string
54
+
val id : t -> Proto_id.t option
55
+
val name : t -> string option
56
+
val email : t -> string option
32
57
val reply_to : t -> Mail_address.t list option
33
58
val bcc : t -> Mail_address.t list option
34
-
val text_signature : t -> string
35
-
val html_signature : t -> string
36
-
val may_delete : t -> bool
59
+
val text_signature : t -> string option
60
+
val html_signature : t -> string option
61
+
val may_delete : t -> bool option
37
62
38
63
val jsont : t Jsont.t
+66
-25
lib/mail/mail_mailbox.ml
+66
-25
lib/mail/mail_mailbox.ml
···
3
3
SPDX-License-Identifier: ISC
4
4
---------------------------------------------------------------------------*)
5
5
6
+
(* Mailbox properties *)
7
+
8
+
type property = [
9
+
| `Id
10
+
| `Name
11
+
| `Parent_id
12
+
| `Role
13
+
| `Sort_order
14
+
| `Total_emails
15
+
| `Unread_emails
16
+
| `Total_threads
17
+
| `Unread_threads
18
+
| `My_rights
19
+
| `Is_subscribed
20
+
]
21
+
22
+
let property_to_string : [< property ] -> string = function
23
+
| `Id -> "id"
24
+
| `Name -> "name"
25
+
| `Parent_id -> "parentId"
26
+
| `Role -> "role"
27
+
| `Sort_order -> "sortOrder"
28
+
| `Total_emails -> "totalEmails"
29
+
| `Unread_emails -> "unreadEmails"
30
+
| `Total_threads -> "totalThreads"
31
+
| `Unread_threads -> "unreadThreads"
32
+
| `My_rights -> "myRights"
33
+
| `Is_subscribed -> "isSubscribed"
34
+
35
+
let property_of_string s : property option =
36
+
match s with
37
+
| "id" -> Some `Id
38
+
| "name" -> Some `Name
39
+
| "parentId" -> Some `Parent_id
40
+
| "role" -> Some `Role
41
+
| "sortOrder" -> Some `Sort_order
42
+
| "totalEmails" -> Some `Total_emails
43
+
| "unreadEmails" -> Some `Unread_emails
44
+
| "totalThreads" -> Some `Total_threads
45
+
| "unreadThreads" -> Some `Unread_threads
46
+
| "myRights" -> Some `My_rights
47
+
| "isSubscribed" -> Some `Is_subscribed
48
+
| _ -> None
49
+
6
50
module Rights = struct
7
51
type t = {
8
52
may_read_items : bool;
···
102
146
Jsont.string
103
147
104
148
type t = {
105
-
id : Proto_id.t;
106
-
name : string;
149
+
id : Proto_id.t option;
150
+
name : string option;
107
151
parent_id : Proto_id.t option;
108
152
role : role option;
109
-
sort_order : int64;
110
-
total_emails : int64;
111
-
unread_emails : int64;
112
-
total_threads : int64;
113
-
unread_threads : int64;
114
-
my_rights : Rights.t;
115
-
is_subscribed : bool;
153
+
sort_order : int64 option;
154
+
total_emails : int64 option;
155
+
unread_emails : int64 option;
156
+
total_threads : int64 option;
157
+
unread_threads : int64 option;
158
+
my_rights : Rights.t option;
159
+
is_subscribed : bool option;
116
160
}
117
161
118
162
let id t = t.id
···
134
178
135
179
let jsont =
136
180
let kind = "Mailbox" in
137
-
(* parentId and role can be null - RFC 8621 Section 2 *)
138
-
let nullable_id = Jsont.(option Proto_id.jsont) in
139
-
let nullable_role = Jsont.(option role_jsont) in
140
181
Jsont.Object.map ~kind make
141
-
|> Jsont.Object.mem "id" Proto_id.jsont ~enc:id
142
-
|> Jsont.Object.mem "name" Jsont.string ~enc:name
143
-
|> Jsont.Object.mem "parentId" nullable_id
144
-
~dec_absent:None ~enc_omit:Option.is_none ~enc:parent_id
145
-
|> Jsont.Object.mem "role" nullable_role
146
-
~dec_absent:None ~enc_omit:Option.is_none ~enc:role
147
-
|> Jsont.Object.mem "sortOrder" Proto_int53.Unsigned.jsont ~dec_absent:0L ~enc:sort_order
148
-
|> Jsont.Object.mem "totalEmails" Proto_int53.Unsigned.jsont ~enc:total_emails
149
-
|> Jsont.Object.mem "unreadEmails" Proto_int53.Unsigned.jsont ~enc:unread_emails
150
-
|> Jsont.Object.mem "totalThreads" Proto_int53.Unsigned.jsont ~enc:total_threads
151
-
|> Jsont.Object.mem "unreadThreads" Proto_int53.Unsigned.jsont ~enc:unread_threads
152
-
|> Jsont.Object.mem "myRights" Rights.jsont ~enc:my_rights
153
-
|> Jsont.Object.mem "isSubscribed" Jsont.bool ~enc:is_subscribed
182
+
|> Jsont.Object.opt_mem "id" Proto_id.jsont ~enc:id
183
+
|> Jsont.Object.opt_mem "name" Jsont.string ~enc:name
184
+
(* parentId can be null meaning top-level, or absent if not requested *)
185
+
|> Jsont.Object.opt_mem "parentId" Proto_id.jsont ~enc:parent_id
186
+
(* role can be null meaning no role, or absent if not requested *)
187
+
|> Jsont.Object.opt_mem "role" role_jsont ~enc:role
188
+
|> Jsont.Object.opt_mem "sortOrder" Proto_int53.Unsigned.jsont ~enc:sort_order
189
+
|> Jsont.Object.opt_mem "totalEmails" Proto_int53.Unsigned.jsont ~enc:total_emails
190
+
|> Jsont.Object.opt_mem "unreadEmails" Proto_int53.Unsigned.jsont ~enc:unread_emails
191
+
|> Jsont.Object.opt_mem "totalThreads" Proto_int53.Unsigned.jsont ~enc:total_threads
192
+
|> Jsont.Object.opt_mem "unreadThreads" Proto_int53.Unsigned.jsont ~enc:unread_threads
193
+
|> Jsont.Object.opt_mem "myRights" Rights.jsont ~enc:my_rights
194
+
|> Jsont.Object.opt_mem "isSubscribed" Jsont.bool ~enc:is_subscribed
154
195
|> Jsont.Object.finish
155
196
156
197
module Filter_condition = struct
+49
-21
lib/mail/mail_mailbox.mli
+49
-21
lib/mail/mail_mailbox.mli
···
3
3
SPDX-License-Identifier: ISC
4
4
---------------------------------------------------------------------------*)
5
5
6
-
(** Mailbox type as defined in RFC 8621 Section 2
6
+
(** Mailbox type as defined in RFC 8621 Section 2
7
7
8
8
@canonical Jmap.Proto.Mailbox *)
9
+
10
+
(** {1 Mailbox Properties}
11
+
12
+
Polymorphic variants for type-safe property selection in Mailbox/get requests.
13
+
These correspond to the properties defined in RFC 8621 Section 2. *)
14
+
15
+
(** All Mailbox properties that can be requested. *)
16
+
type property = [
17
+
| `Id
18
+
| `Name
19
+
| `Parent_id
20
+
| `Role
21
+
| `Sort_order
22
+
| `Total_emails
23
+
| `Unread_emails
24
+
| `Total_threads
25
+
| `Unread_threads
26
+
| `My_rights
27
+
| `Is_subscribed
28
+
]
29
+
30
+
val property_to_string : [< property ] -> string
31
+
(** Convert a property to its wire name (e.g., [`Parent_id] -> "parentId"). *)
32
+
33
+
val property_of_string : string -> property option
34
+
(** Parse a property name, case-sensitive. *)
9
35
10
36
(** {1 Mailbox Rights} *)
11
37
···
63
89
(** {1 Mailbox} *)
64
90
65
91
type t = {
66
-
id : Proto_id.t;
92
+
id : Proto_id.t option;
67
93
(** Server-assigned mailbox id. *)
68
-
name : string;
94
+
name : string option;
69
95
(** User-visible name (UTF-8). *)
70
96
parent_id : Proto_id.t option;
71
-
(** Id of parent mailbox, or [None] for root. *)
97
+
(** Id of parent mailbox, or [None] for root. Note: [None] can mean
98
+
either "not requested" or "top-level mailbox". *)
72
99
role : role option;
73
-
(** Standard role, if any. *)
74
-
sort_order : int64;
100
+
(** Standard role, if any. Note: [None] can mean either "not requested"
101
+
or "no role assigned". *)
102
+
sort_order : int64 option;
75
103
(** Sort order hint (lower = displayed first). *)
76
-
total_emails : int64;
104
+
total_emails : int64 option;
77
105
(** Total number of emails in mailbox. *)
78
-
unread_emails : int64;
106
+
unread_emails : int64 option;
79
107
(** Number of unread emails. *)
80
-
total_threads : int64;
108
+
total_threads : int64 option;
81
109
(** Total number of threads. *)
82
-
unread_threads : int64;
110
+
unread_threads : int64 option;
83
111
(** Number of threads with unread emails. *)
84
-
my_rights : Rights.t;
112
+
my_rights : Rights.t option;
85
113
(** User's rights on this mailbox. *)
86
-
is_subscribed : bool;
114
+
is_subscribed : bool option;
87
115
(** Whether user is subscribed to this mailbox. *)
88
116
}
89
117
90
-
val id : t -> Proto_id.t
91
-
val name : t -> string
118
+
val id : t -> Proto_id.t option
119
+
val name : t -> string option
92
120
val parent_id : t -> Proto_id.t option
93
121
val role : t -> role option
94
-
val sort_order : t -> int64
95
-
val total_emails : t -> int64
96
-
val unread_emails : t -> int64
97
-
val total_threads : t -> int64
98
-
val unread_threads : t -> int64
99
-
val my_rights : t -> Rights.t
100
-
val is_subscribed : t -> bool
122
+
val sort_order : t -> int64 option
123
+
val total_emails : t -> int64 option
124
+
val unread_emails : t -> int64 option
125
+
val total_threads : t -> int64 option
126
+
val unread_threads : t -> int64 option
127
+
val my_rights : t -> Rights.t option
128
+
val is_subscribed : t -> bool option
101
129
102
130
val jsont : t Jsont.t
103
131
+57
-16
lib/mail/mail_submission.ml
+57
-16
lib/mail/mail_submission.ml
···
3
3
SPDX-License-Identifier: ISC
4
4
---------------------------------------------------------------------------*)
5
5
6
+
(* EmailSubmission properties *)
7
+
8
+
type property = [
9
+
| `Id
10
+
| `Identity_id
11
+
| `Email_id
12
+
| `Thread_id
13
+
| `Envelope
14
+
| `Send_at
15
+
| `Undo_status
16
+
| `Delivery_status
17
+
| `Dsn_blob_ids
18
+
| `Mdn_blob_ids
19
+
]
20
+
21
+
let property_to_string : [< property ] -> string = function
22
+
| `Id -> "id"
23
+
| `Identity_id -> "identityId"
24
+
| `Email_id -> "emailId"
25
+
| `Thread_id -> "threadId"
26
+
| `Envelope -> "envelope"
27
+
| `Send_at -> "sendAt"
28
+
| `Undo_status -> "undoStatus"
29
+
| `Delivery_status -> "deliveryStatus"
30
+
| `Dsn_blob_ids -> "dsnBlobIds"
31
+
| `Mdn_blob_ids -> "mdnBlobIds"
32
+
33
+
let property_of_string s : property option =
34
+
match s with
35
+
| "id" -> Some `Id
36
+
| "identityId" -> Some `Identity_id
37
+
| "emailId" -> Some `Email_id
38
+
| "threadId" -> Some `Thread_id
39
+
| "envelope" -> Some `Envelope
40
+
| "sendAt" -> Some `Send_at
41
+
| "undoStatus" -> Some `Undo_status
42
+
| "deliveryStatus" -> Some `Delivery_status
43
+
| "dsnBlobIds" -> Some `Dsn_blob_ids
44
+
| "mdnBlobIds" -> Some `Mdn_blob_ids
45
+
| _ -> None
46
+
6
47
module Address = struct
7
48
type t = {
8
49
email : string;
···
114
155
~dec:undo_status_of_string ~enc:undo_status_to_string Jsont.string
115
156
116
157
type t = {
117
-
id : Proto_id.t;
118
-
identity_id : Proto_id.t;
119
-
email_id : Proto_id.t;
120
-
thread_id : Proto_id.t;
158
+
id : Proto_id.t option;
159
+
identity_id : Proto_id.t option;
160
+
email_id : Proto_id.t option;
161
+
thread_id : Proto_id.t option;
121
162
envelope : Envelope.t option;
122
-
send_at : Ptime.t;
123
-
undo_status : undo_status;
163
+
send_at : Ptime.t option;
164
+
undo_status : undo_status option;
124
165
delivery_status : (string * Delivery_status.t) list option;
125
-
dsn_blob_ids : Proto_id.t list;
126
-
mdn_blob_ids : Proto_id.t list;
166
+
dsn_blob_ids : Proto_id.t list option;
167
+
mdn_blob_ids : Proto_id.t list option;
127
168
}
128
169
129
170
let id t = t.id
···
145
186
let jsont =
146
187
let kind = "EmailSubmission" in
147
188
Jsont.Object.map ~kind make
148
-
|> Jsont.Object.mem "id" Proto_id.jsont ~enc:id
149
-
|> Jsont.Object.mem "identityId" Proto_id.jsont ~enc:identity_id
150
-
|> Jsont.Object.mem "emailId" Proto_id.jsont ~enc:email_id
151
-
|> Jsont.Object.mem "threadId" Proto_id.jsont ~enc:thread_id
189
+
|> Jsont.Object.opt_mem "id" Proto_id.jsont ~enc:id
190
+
|> Jsont.Object.opt_mem "identityId" Proto_id.jsont ~enc:identity_id
191
+
|> Jsont.Object.opt_mem "emailId" Proto_id.jsont ~enc:email_id
192
+
|> Jsont.Object.opt_mem "threadId" Proto_id.jsont ~enc:thread_id
152
193
|> Jsont.Object.opt_mem "envelope" Envelope.jsont ~enc:envelope
153
-
|> Jsont.Object.mem "sendAt" Proto_date.Utc.jsont ~enc:send_at
154
-
|> Jsont.Object.mem "undoStatus" undo_status_jsont ~enc:undo_status
194
+
|> Jsont.Object.opt_mem "sendAt" Proto_date.Utc.jsont ~enc:send_at
195
+
|> Jsont.Object.opt_mem "undoStatus" undo_status_jsont ~enc:undo_status
155
196
|> Jsont.Object.opt_mem "deliveryStatus" (Proto_json_map.of_string Delivery_status.jsont) ~enc:delivery_status
156
-
|> Jsont.Object.mem "dsnBlobIds" (Jsont.list Proto_id.jsont) ~dec_absent:[] ~enc:dsn_blob_ids
157
-
|> Jsont.Object.mem "mdnBlobIds" (Jsont.list Proto_id.jsont) ~dec_absent:[] ~enc:mdn_blob_ids
197
+
|> Jsont.Object.opt_mem "dsnBlobIds" (Jsont.list Proto_id.jsont) ~enc:dsn_blob_ids
198
+
|> Jsont.Object.opt_mem "mdnBlobIds" (Jsont.list Proto_id.jsont) ~enc:mdn_blob_ids
158
199
|> Jsont.Object.finish
159
200
160
201
module Filter_condition = struct
+42
-17
lib/mail/mail_submission.mli
+42
-17
lib/mail/mail_submission.mli
···
3
3
SPDX-License-Identifier: ISC
4
4
---------------------------------------------------------------------------*)
5
5
6
-
(** EmailSubmission type as defined in RFC 8621 Section 7
6
+
(** EmailSubmission type as defined in RFC 8621 Section 7
7
7
8
8
@canonical Jmap.Proto.Submission *)
9
+
10
+
(** {1 EmailSubmission Properties}
11
+
12
+
Polymorphic variants for type-safe property selection in EmailSubmission/get requests.
13
+
These correspond to the properties defined in RFC 8621 Section 7. *)
14
+
15
+
(** All EmailSubmission properties that can be requested. *)
16
+
type property = [
17
+
| `Id
18
+
| `Identity_id
19
+
| `Email_id
20
+
| `Thread_id
21
+
| `Envelope
22
+
| `Send_at
23
+
| `Undo_status
24
+
| `Delivery_status
25
+
| `Dsn_blob_ids
26
+
| `Mdn_blob_ids
27
+
]
28
+
29
+
val property_to_string : [< property ] -> string
30
+
(** Convert a property to its wire name (e.g., [`Identity_id] -> "identityId"). *)
31
+
32
+
val property_of_string : string -> property option
33
+
(** Parse a property name, case-sensitive. *)
9
34
10
35
(** {1 Address} *)
11
36
···
86
111
(** {1 EmailSubmission} *)
87
112
88
113
type t = {
89
-
id : Proto_id.t;
114
+
id : Proto_id.t option;
90
115
(** Server-assigned submission id. *)
91
-
identity_id : Proto_id.t;
116
+
identity_id : Proto_id.t option;
92
117
(** The identity used to send. *)
93
-
email_id : Proto_id.t;
118
+
email_id : Proto_id.t option;
94
119
(** The email that was submitted. *)
95
-
thread_id : Proto_id.t;
120
+
thread_id : Proto_id.t option;
96
121
(** The thread of the submitted email. *)
97
122
envelope : Envelope.t option;
98
123
(** The envelope used, if different from email headers. *)
99
-
send_at : Ptime.t;
124
+
send_at : Ptime.t option;
100
125
(** When the email was/will be sent. *)
101
-
undo_status : undo_status;
126
+
undo_status : undo_status option;
102
127
(** Whether sending can be undone. *)
103
128
delivery_status : (string * Delivery_status.t) list option;
104
129
(** Delivery status per recipient. *)
105
-
dsn_blob_ids : Proto_id.t list;
130
+
dsn_blob_ids : Proto_id.t list option;
106
131
(** Blob ids of received DSN messages. *)
107
-
mdn_blob_ids : Proto_id.t list;
132
+
mdn_blob_ids : Proto_id.t list option;
108
133
(** Blob ids of received MDN messages. *)
109
134
}
110
135
111
-
val id : t -> Proto_id.t
112
-
val identity_id : t -> Proto_id.t
113
-
val email_id : t -> Proto_id.t
114
-
val thread_id : t -> Proto_id.t
136
+
val id : t -> Proto_id.t option
137
+
val identity_id : t -> Proto_id.t option
138
+
val email_id : t -> Proto_id.t option
139
+
val thread_id : t -> Proto_id.t option
115
140
val envelope : t -> Envelope.t option
116
-
val send_at : t -> Ptime.t
117
-
val undo_status : t -> undo_status
141
+
val send_at : t -> Ptime.t option
142
+
val undo_status : t -> undo_status option
118
143
val delivery_status : t -> (string * Delivery_status.t) list option
119
-
val dsn_blob_ids : t -> Proto_id.t list
120
-
val mdn_blob_ids : t -> Proto_id.t list
144
+
val dsn_blob_ids : t -> Proto_id.t list option
145
+
val mdn_blob_ids : t -> Proto_id.t list option
121
146
122
147
val jsont : t Jsont.t
123
148
+23
-4
lib/mail/mail_thread.ml
+23
-4
lib/mail/mail_thread.ml
···
3
3
SPDX-License-Identifier: ISC
4
4
---------------------------------------------------------------------------*)
5
5
6
+
(* Thread properties *)
7
+
8
+
type property = [
9
+
| `Id
10
+
| `Email_ids
11
+
]
12
+
13
+
let property_to_string : [< property ] -> string = function
14
+
| `Id -> "id"
15
+
| `Email_ids -> "emailIds"
16
+
17
+
let property_of_string s : property option =
18
+
match s with
19
+
| "id" -> Some `Id
20
+
| "emailIds" -> Some `Email_ids
21
+
| _ -> None
22
+
23
+
(* Thread type *)
24
+
6
25
type t = {
7
-
id : Proto_id.t;
8
-
email_ids : Proto_id.t list;
26
+
id : Proto_id.t option;
27
+
email_ids : Proto_id.t list option;
9
28
}
10
29
11
30
let id t = t.id
···
16
35
let jsont =
17
36
let kind = "Thread" in
18
37
Jsont.Object.map ~kind make
19
-
|> Jsont.Object.mem "id" Proto_id.jsont ~enc:id
20
-
|> Jsont.Object.mem "emailIds" (Jsont.list Proto_id.jsont) ~enc:email_ids
38
+
|> Jsont.Object.opt_mem "id" Proto_id.jsont ~enc:id
39
+
|> Jsont.Object.opt_mem "emailIds" (Jsont.list Proto_id.jsont) ~enc:email_ids
21
40
|> Jsont.Object.finish
+24
-5
lib/mail/mail_thread.mli
+24
-5
lib/mail/mail_thread.mli
···
3
3
SPDX-License-Identifier: ISC
4
4
---------------------------------------------------------------------------*)
5
5
6
-
(** Thread type as defined in RFC 8621 Section 3
6
+
(** Thread type as defined in RFC 8621 Section 3
7
7
8
8
@canonical Jmap.Proto.Thread *)
9
9
10
+
(** {1 Thread Properties}
11
+
12
+
Polymorphic variants for type-safe property selection in Thread/get requests.
13
+
Threads have only two properties per RFC 8621 Section 3. *)
14
+
15
+
(** All Thread properties that can be requested. *)
16
+
type property = [
17
+
| `Id
18
+
| `Email_ids
19
+
]
20
+
21
+
val property_to_string : [< property ] -> string
22
+
(** Convert a property to its wire name (e.g., [`Email_ids] -> "emailIds"). *)
23
+
24
+
val property_of_string : string -> property option
25
+
(** Parse a property name, case-sensitive. *)
26
+
27
+
(** {1 Thread Object} *)
28
+
10
29
type t = {
11
-
id : Proto_id.t;
30
+
id : Proto_id.t option;
12
31
(** Server-assigned thread id. *)
13
-
email_ids : Proto_id.t list;
32
+
email_ids : Proto_id.t list option;
14
33
(** Ids of emails in this thread, in date order. *)
15
34
}
16
35
17
-
val id : t -> Proto_id.t
18
-
val email_ids : t -> Proto_id.t list
36
+
val id : t -> Proto_id.t option
37
+
val email_ids : t -> Proto_id.t list option
19
38
20
39
val jsont : t Jsont.t
+6
lib/top/dune
+6
lib/top/dune
+68
lib/top/jmap_top.ml
+68
lib/top/jmap_top.ml
···
1
+
(* Toplevel printers for JMAP types
2
+
3
+
Usage in toplevel:
4
+
#require "jmap.top";;
5
+
6
+
Printers are automatically installed when the library is loaded.
7
+
*)
8
+
9
+
(* JSON printers *)
10
+
11
+
let json_printer ppf (json : Jsont.json) =
12
+
match Jsont_bytesrw.encode_string Jsont.json json with
13
+
| Ok s -> Format.pp_print_string ppf s
14
+
| Error e -> Format.fprintf ppf "<json encoding error: %s>" e
15
+
16
+
let jsont_error_printer ppf (e : Jsont.Error.t) =
17
+
Format.pp_print_string ppf (Jsont.Error.to_string e)
18
+
19
+
(* JSON encoding helpers *)
20
+
21
+
let encode (type a) (codec : a Jsont.t) (value : a) : Jsont.json =
22
+
match Jsont.Json.encode codec value with
23
+
| Ok json -> json
24
+
| Error e -> invalid_arg e
25
+
26
+
let encode_string (type a) (codec : a Jsont.t) (value : a) : string =
27
+
match Jsont_bytesrw.encode_string codec value with
28
+
| Ok s -> s
29
+
| Error e -> invalid_arg e
30
+
31
+
let pp_as_json (type a) (codec : a Jsont.t) ppf (value : a) =
32
+
json_printer ppf (encode codec value)
33
+
34
+
(* Automatic printer installation *)
35
+
36
+
let printers =
37
+
[ "Jmap.Id.pp";
38
+
"Jmap.Keyword.pp";
39
+
"Jmap.Role.pp";
40
+
"Jmap.Capability.pp";
41
+
"Jmap.Error.pp";
42
+
"Jmap_top.json_printer";
43
+
"Jmap_top.jsont_error_printer" ]
44
+
45
+
(* Suppress stderr during printer installation to avoid noise in MDX tests *)
46
+
let null_formatter = Format.make_formatter (fun _ _ _ -> ()) (fun () -> ())
47
+
48
+
let eval_string_quiet str =
49
+
try
50
+
let lexbuf = Lexing.from_string str in
51
+
let phrase = !Toploop.parse_toplevel_phrase lexbuf in
52
+
Toploop.execute_phrase false null_formatter phrase
53
+
with _ -> false
54
+
55
+
let rec do_install_printers = function
56
+
| [] -> true
57
+
| printer :: rest ->
58
+
let cmd = Printf.sprintf "#install_printer %s;;" printer in
59
+
eval_string_quiet cmd && do_install_printers rest
60
+
61
+
let install () =
62
+
(* Silently ignore failures - this handles non-toplevel contexts like MDX *)
63
+
ignore (do_install_printers printers)
64
+
65
+
(* Only auto-install when OCAML_TOPLEVEL_NAME is set, indicating a real toplevel *)
66
+
let () =
67
+
if Sys.getenv_opt "OCAML_TOPLEVEL_NAME" <> None then
68
+
install ()
+50
lib/top/jmap_top.mli
+50
lib/top/jmap_top.mli
···
1
+
(** Toplevel printers for JMAP types.
2
+
3
+
Printers are automatically installed when the library is loaded:
4
+
{[
5
+
#require "jmap.top";;
6
+
]}
7
+
8
+
After loading, JMAP types will display nicely:
9
+
{[
10
+
# Jmap.Id.of_string_exn "abc123";;
11
+
- : Jmap.Id.t = <id:abc123>
12
+
13
+
# Jmap.Keyword.of_string "$seen";;
14
+
- : Jmap.Keyword.t = `Seen
15
+
16
+
# Jmap.Role.of_string "inbox";;
17
+
- : Jmap.Role.t = `Inbox
18
+
]}
19
+
20
+
JSON values display as formatted strings, making it easy to see
21
+
how OCaml types map to JMAP JSON. *)
22
+
23
+
(** {1 JSON Printers} *)
24
+
25
+
val json_printer : Format.formatter -> Jsont.json -> unit
26
+
(** Formats a JSON value as a compact JSON string. *)
27
+
28
+
val jsont_error_printer : Format.formatter -> Jsont.Error.t -> unit
29
+
(** Formats a Jsont parsing error. *)
30
+
31
+
(** {1 JSON Encoding Helpers}
32
+
33
+
These functions encode OCaml types to JSON, useful for understanding
34
+
how the library maps to JMAP wire format. *)
35
+
36
+
val encode : 'a Jsont.t -> 'a -> Jsont.json
37
+
(** [encode codec value] encodes a value to JSON using the given codec.
38
+
Raises [Invalid_argument] on encoding failure. *)
39
+
40
+
val encode_string : 'a Jsont.t -> 'a -> string
41
+
(** [encode_string codec value] encodes a value to a JSON string. *)
42
+
43
+
val pp_as_json : 'a Jsont.t -> Format.formatter -> 'a -> unit
44
+
(** [pp_as_json codec ppf value] pretty-prints a value as JSON. *)
45
+
46
+
(** {1 Installation} *)
47
+
48
+
val install : unit -> unit
49
+
(** [install ()] installs all printers. This is called automatically when
50
+
the library is loaded, but can be called again if needed. *)
+24
-18
test/proto/test_proto.ml
+24
-18
test/proto/test_proto.ml
···
48
48
Alcotest.failf "%s: re-decode failed: %s" name (Jsont.Error.to_string e)
49
49
| Ok _ -> ()
50
50
51
+
(* Helpers for extracting values from optional fields in tests *)
52
+
let get_id opt = match opt with Some id -> Jmap.Proto.Id.to_string id | None -> Alcotest.fail "expected id"
53
+
let get_string opt = match opt with Some s -> s | None -> Alcotest.fail "expected string"
54
+
let get_int64 opt = match opt with Some n -> n | None -> Alcotest.fail "expected int64"
55
+
let get_bool opt = match opt with Some b -> b | None -> Alcotest.fail "expected bool"
56
+
51
57
(* ID tests *)
52
58
module Id_tests = struct
53
59
open Jmap.Proto
···
607
613
match decode Mailbox.jsont json with
608
614
| Error e -> Alcotest.failf "decode failed: %s" (Jsont.Error.to_string e)
609
615
| Ok mb ->
610
-
Alcotest.(check string) "id" "mb1" (Jmap.Proto.Id.to_string (Mailbox.id mb));
611
-
Alcotest.(check string) "name" "Inbox" (Mailbox.name mb);
616
+
Alcotest.(check string) "id" "mb1" (get_id (Mailbox.id mb));
617
+
Alcotest.(check string) "name" "Inbox" (get_string (Mailbox.name mb));
612
618
Alcotest.(check (option role_testable)) "role" (Some `Inbox) (Mailbox.role mb);
613
-
Alcotest.(check int64) "totalEmails" 150L (Mailbox.total_emails mb);
614
-
Alcotest.(check int64) "unreadEmails" 5L (Mailbox.unread_emails mb)
619
+
Alcotest.(check int64) "totalEmails" 150L (get_int64 (Mailbox.total_emails mb));
620
+
Alcotest.(check int64) "unreadEmails" 5L (get_int64 (Mailbox.unread_emails mb))
615
621
616
622
let test_roundtrip () =
617
623
test_roundtrip "simple roundtrip" Mailbox.jsont "mail/mailbox/valid/simple.json" ()
···
628
634
| Error e -> Alcotest.failf "decode failed: %s" (Jsont.Error.to_string e)
629
635
| Ok mb ->
630
636
Alcotest.(check (option role_testable)) "role" (Some `Archive) (Mailbox.role mb);
631
-
Alcotest.(check int64) "totalEmails" 1000L (Mailbox.total_emails mb)
637
+
Alcotest.(check int64) "totalEmails" 1000L (get_int64 (Mailbox.total_emails mb))
632
638
633
639
let tests = [
634
640
"valid: simple", `Quick, test_simple;
···
659
665
match decode Email.jsont json with
660
666
| Error e -> Alcotest.failf "decode failed: %s" (Jsont.Error.to_string e)
661
667
| Ok email ->
662
-
Alcotest.(check string) "id" "e1" (Jmap.Proto.Id.to_string (Email.id email));
663
-
Alcotest.(check string) "blobId" "blob1" (Jmap.Proto.Id.to_string (Email.blob_id email));
664
-
Alcotest.(check int64) "size" 1024L (Email.size email)
668
+
Alcotest.(check string) "id" "e1" (get_id (Email.id email));
669
+
Alcotest.(check string) "blobId" "blob1" (get_id (Email.blob_id email));
670
+
Alcotest.(check int64) "size" 1024L (get_int64 (Email.size email))
665
671
666
672
let test_full_values () =
667
673
let json = read_file "mail/email/valid/full.json" in
···
669
675
| Error e -> Alcotest.failf "decode failed: %s" (Jsont.Error.to_string e)
670
676
| Ok email ->
671
677
Alcotest.(check (option string)) "subject" (Some "Re: Important meeting") (Email.subject email);
672
-
Alcotest.(check bool) "hasAttachment" true (Email.has_attachment email);
678
+
Alcotest.(check bool) "hasAttachment" true (get_bool (Email.has_attachment email));
673
679
(* Check from address *)
674
680
match Email.from email with
675
681
| None -> Alcotest.fail "expected from address"
···
702
708
match decode Email.jsont json with
703
709
| Error e -> Alcotest.failf "decode failed: %s" (Jsont.Error.to_string e)
704
710
| Ok email ->
705
-
let keywords = Email.keywords email in
711
+
let keywords = Option.value ~default:[] (Email.keywords email) in
706
712
Alcotest.(check int) "keywords count" 3 (List.length keywords);
707
713
Alcotest.(check bool) "$seen present" true (List.mem_assoc "$seen" keywords);
708
714
Alcotest.(check bool) "$flagged present" true (List.mem_assoc "$flagged" keywords)
···
712
718
match decode Email.jsont json with
713
719
| Error e -> Alcotest.failf "decode failed: %s" (Jsont.Error.to_string e)
714
720
| Ok email ->
715
-
let mailbox_ids = Email.mailbox_ids email in
721
+
let mailbox_ids = Option.value ~default:[] (Email.mailbox_ids email) in
716
722
Alcotest.(check int) "mailboxIds count" 3 (List.length mailbox_ids)
717
723
718
724
let tests = [
···
747
753
match decode Thread.jsont json with
748
754
| Error e -> Alcotest.failf "decode failed: %s" (Jsont.Error.to_string e)
749
755
| Ok thread ->
750
-
Alcotest.(check string) "id" "t2" (Jmap.Proto.Id.to_string (Thread.id thread));
751
-
Alcotest.(check int) "emailIds count" 5 (List.length (Thread.email_ids thread))
756
+
Alcotest.(check string) "id" "t2" (get_id (Thread.id thread));
757
+
Alcotest.(check int) "emailIds count" 5 (List.length (Option.value ~default:[] (Thread.email_ids thread)))
752
758
753
759
let tests = [
754
760
"valid: simple", `Quick, test_simple;
···
769
775
match decode Identity.jsont json with
770
776
| Error e -> Alcotest.failf "decode failed: %s" (Jsont.Error.to_string e)
771
777
| Ok ident ->
772
-
Alcotest.(check string) "name" "Work Identity" (Identity.name ident);
773
-
Alcotest.(check string) "email" "john.doe@company.com" (Identity.email ident);
774
-
Alcotest.(check bool) "mayDelete" true (Identity.may_delete ident)
778
+
Alcotest.(check string) "name" "Work Identity" (get_string (Identity.name ident));
779
+
Alcotest.(check string) "email" "john.doe@company.com" (get_string (Identity.email ident));
780
+
Alcotest.(check bool) "mayDelete" true (get_bool (Identity.may_delete ident))
775
781
776
782
let tests = [
777
783
"valid: simple", `Quick, test_simple;
···
948
954
match decode Submission.jsont json with
949
955
| Error e -> Alcotest.failf "decode failed: %s" (Jsont.Error.to_string e)
950
956
| Ok sub ->
951
-
Alcotest.(check string) "id" "sub1" (Jmap.Proto.Id.to_string (Submission.id sub));
957
+
Alcotest.(check string) "id" "sub1" (get_id (Submission.id sub));
952
958
(* Check undoStatus is Pending *)
953
959
match Submission.undo_status sub with
954
-
| `Pending -> ()
960
+
| Some `Pending -> ()
955
961
| _ -> Alcotest.fail "expected undoStatus to be pending"
956
962
957
963
let tests = [
+562
web/brr.html
+562
web/brr.html
···
1
+
<!DOCTYPE html>
2
+
<html lang="en">
3
+
<head>
4
+
<meta charset="utf-8">
5
+
<meta name="viewport" content="width=device-width, initial-scale=1.0">
6
+
<title>JMAP Email Client</title>
7
+
<style>
8
+
:root {
9
+
--bg-color: #1a1a2e;
10
+
--card-bg: #16213e;
11
+
--accent: #0f3460;
12
+
--highlight: #e94560;
13
+
--text: #eee;
14
+
--text-muted: #888;
15
+
--success: #4ade80;
16
+
--error: #f87171;
17
+
--warning: #fbbf24;
18
+
}
19
+
20
+
* {
21
+
box-sizing: border-box;
22
+
margin: 0;
23
+
padding: 0;
24
+
}
25
+
26
+
body {
27
+
font-family: -apple-system, BlinkMacSystemFont, 'Segoe UI', Roboto, Oxygen, Ubuntu, sans-serif;
28
+
background: var(--bg-color);
29
+
color: var(--text);
30
+
min-height: 100vh;
31
+
padding: 20px;
32
+
}
33
+
34
+
.container {
35
+
max-width: 1200px;
36
+
margin: 0 auto;
37
+
}
38
+
39
+
header {
40
+
text-align: center;
41
+
margin-bottom: 30px;
42
+
}
43
+
44
+
h1 {
45
+
font-size: 2rem;
46
+
margin-bottom: 10px;
47
+
}
48
+
49
+
h1 span {
50
+
color: var(--highlight);
51
+
}
52
+
53
+
.subtitle {
54
+
color: var(--text-muted);
55
+
font-size: 0.9rem;
56
+
}
57
+
58
+
/* Top Section - Two Column Layout */
59
+
.top-section {
60
+
display: grid;
61
+
grid-template-columns: 1fr 1fr;
62
+
gap: 20px;
63
+
margin-bottom: 20px;
64
+
}
65
+
66
+
@media (max-width: 800px) {
67
+
.top-section {
68
+
grid-template-columns: 1fr;
69
+
}
70
+
}
71
+
72
+
/* Login Form */
73
+
.login-card {
74
+
background: var(--card-bg);
75
+
border-radius: 12px;
76
+
padding: 16px;
77
+
box-shadow: 0 4px 20px rgba(0,0,0,0.3);
78
+
}
79
+
80
+
.login-card h3 {
81
+
margin-bottom: 12px;
82
+
font-size: 0.9rem;
83
+
color: var(--text-muted);
84
+
text-transform: uppercase;
85
+
letter-spacing: 1px;
86
+
}
87
+
88
+
.form-row {
89
+
display: flex;
90
+
gap: 12px;
91
+
margin-bottom: 12px;
92
+
}
93
+
94
+
.form-group {
95
+
flex: 1;
96
+
margin-bottom: 12px;
97
+
}
98
+
99
+
.form-group:last-child {
100
+
margin-bottom: 0;
101
+
}
102
+
103
+
.form-group.small {
104
+
flex: 0.4;
105
+
}
106
+
107
+
label {
108
+
display: block;
109
+
margin-bottom: 4px;
110
+
font-weight: 500;
111
+
font-size: 0.75rem;
112
+
color: var(--text-muted);
113
+
}
114
+
115
+
input[type="text"],
116
+
input[type="password"] {
117
+
width: 100%;
118
+
padding: 8px 12px;
119
+
border: 2px solid var(--accent);
120
+
border-radius: 6px;
121
+
background: var(--bg-color);
122
+
color: var(--text);
123
+
font-size: 0.85rem;
124
+
transition: border-color 0.2s;
125
+
}
126
+
127
+
input:focus {
128
+
outline: none;
129
+
border-color: var(--highlight);
130
+
}
131
+
132
+
.btn-row {
133
+
display: flex;
134
+
gap: 8px;
135
+
}
136
+
137
+
.btn {
138
+
flex: 1;
139
+
padding: 10px;
140
+
border: none;
141
+
border-radius: 6px;
142
+
font-size: 0.85rem;
143
+
font-weight: 600;
144
+
cursor: pointer;
145
+
transition: transform 0.1s, opacity 0.2s;
146
+
}
147
+
148
+
.btn:hover {
149
+
transform: translateY(-1px);
150
+
}
151
+
152
+
.btn:active {
153
+
transform: translateY(0);
154
+
}
155
+
156
+
.btn:disabled {
157
+
opacity: 0.5;
158
+
cursor: not-allowed;
159
+
transform: none;
160
+
}
161
+
162
+
.btn-primary {
163
+
background: var(--highlight);
164
+
color: white;
165
+
}
166
+
167
+
.btn-secondary {
168
+
background: var(--accent);
169
+
color: var(--text);
170
+
}
171
+
172
+
/* Status/Log Panel */
173
+
.log-panel {
174
+
background: var(--card-bg);
175
+
border-radius: 12px;
176
+
padding: 20px;
177
+
margin-bottom: 30px;
178
+
max-height: 500px;
179
+
overflow-y: auto;
180
+
}
181
+
182
+
.log-panel h3 {
183
+
margin-bottom: 15px;
184
+
font-size: 0.9rem;
185
+
color: var(--text-muted);
186
+
text-transform: uppercase;
187
+
letter-spacing: 1px;
188
+
}
189
+
190
+
.log-entry {
191
+
font-family: 'SF Mono', Monaco, 'Courier New', monospace;
192
+
font-size: 0.85rem;
193
+
padding: 8px 0;
194
+
border-bottom: 1px solid var(--accent);
195
+
}
196
+
197
+
.log-entry:last-child {
198
+
border-bottom: none;
199
+
}
200
+
201
+
.log-entry-header {
202
+
display: flex;
203
+
align-items: center;
204
+
gap: 8px;
205
+
}
206
+
207
+
.log-info .log-entry-header { color: var(--text); }
208
+
.log-success .log-entry-header { color: var(--success); }
209
+
.log-error .log-entry-header { color: var(--error); }
210
+
.log-warning .log-entry-header { color: var(--warning); }
211
+
212
+
.log-time {
213
+
color: var(--text-muted);
214
+
font-size: 0.8rem;
215
+
flex-shrink: 0;
216
+
}
217
+
218
+
.log-message {
219
+
flex: 1;
220
+
}
221
+
222
+
.log-expand-btn {
223
+
background: var(--accent);
224
+
border: none;
225
+
color: var(--text-muted);
226
+
padding: 2px 8px;
227
+
border-radius: 4px;
228
+
font-size: 0.7rem;
229
+
cursor: pointer;
230
+
font-family: inherit;
231
+
transition: background 0.2s, color 0.2s;
232
+
flex-shrink: 0;
233
+
}
234
+
235
+
.log-expand-btn:hover {
236
+
background: var(--highlight);
237
+
color: white;
238
+
}
239
+
240
+
.log-expand-btn.expanded {
241
+
background: var(--highlight);
242
+
color: white;
243
+
}
244
+
245
+
/* JSON content within log entry */
246
+
.log-json {
247
+
display: none;
248
+
margin-top: 8px;
249
+
border-radius: 8px;
250
+
overflow: hidden;
251
+
}
252
+
253
+
.log-json.visible {
254
+
display: block;
255
+
}
256
+
257
+
.log-json-header {
258
+
padding: 6px 12px;
259
+
font-size: 0.75rem;
260
+
font-weight: 600;
261
+
display: flex;
262
+
justify-content: space-between;
263
+
align-items: center;
264
+
}
265
+
266
+
.log-json.request .log-json-header {
267
+
background: var(--accent);
268
+
color: var(--highlight);
269
+
}
270
+
271
+
.log-json.response .log-json-header {
272
+
background: #1a3a2e;
273
+
color: var(--success);
274
+
}
275
+
276
+
.log-json-body {
277
+
background: var(--bg-color);
278
+
padding: 12px;
279
+
font-size: 0.75rem;
280
+
line-height: 1.4;
281
+
white-space: pre-wrap;
282
+
word-break: break-all;
283
+
max-height: 300px;
284
+
overflow-y: auto;
285
+
color: var(--text-muted);
286
+
}
287
+
288
+
.log-json-body.collapsed {
289
+
max-height: 100px;
290
+
}
291
+
292
+
.json-toggle-size {
293
+
background: none;
294
+
border: none;
295
+
color: inherit;
296
+
cursor: pointer;
297
+
font-size: 0.7rem;
298
+
opacity: 0.7;
299
+
}
300
+
301
+
.json-toggle-size:hover {
302
+
opacity: 1;
303
+
}
304
+
305
+
/* Session Info */
306
+
.session-info {
307
+
background: var(--card-bg);
308
+
border-radius: 12px;
309
+
padding: 16px;
310
+
display: none;
311
+
box-shadow: 0 4px 20px rgba(0,0,0,0.3);
312
+
}
313
+
314
+
.session-info.visible {
315
+
display: block;
316
+
}
317
+
318
+
.session-info h3 {
319
+
margin-bottom: 12px;
320
+
font-size: 0.9rem;
321
+
color: var(--success);
322
+
text-transform: uppercase;
323
+
letter-spacing: 1px;
324
+
}
325
+
326
+
.session-detail {
327
+
display: flex;
328
+
margin-bottom: 6px;
329
+
font-size: 0.85rem;
330
+
}
331
+
332
+
.session-detail .label {
333
+
width: 100px;
334
+
color: var(--text-muted);
335
+
flex-shrink: 0;
336
+
}
337
+
338
+
.session-detail .value {
339
+
color: var(--text);
340
+
word-break: break-all;
341
+
font-family: 'SF Mono', Monaco, 'Courier New', monospace;
342
+
font-size: 0.8rem;
343
+
}
344
+
345
+
.search-box {
346
+
margin-top: 12px;
347
+
padding-top: 12px;
348
+
border-top: 1px solid var(--accent);
349
+
display: flex;
350
+
gap: 8px;
351
+
}
352
+
353
+
.search-box input {
354
+
flex: 1;
355
+
padding: 8px 12px;
356
+
border: 2px solid var(--accent);
357
+
border-radius: 6px;
358
+
background: var(--bg-color);
359
+
color: var(--text);
360
+
font-size: 0.85rem;
361
+
}
362
+
363
+
.search-box input:focus {
364
+
outline: none;
365
+
border-color: var(--highlight);
366
+
}
367
+
368
+
.btn-small {
369
+
flex: 0;
370
+
padding: 8px 16px;
371
+
white-space: nowrap;
372
+
}
373
+
374
+
/* Email List */
375
+
.email-list {
376
+
display: none;
377
+
}
378
+
379
+
.email-list.visible {
380
+
display: block;
381
+
}
382
+
383
+
.email-list h2 {
384
+
margin-bottom: 20px;
385
+
}
386
+
387
+
.email-item {
388
+
background: var(--card-bg);
389
+
border-radius: 8px;
390
+
padding: 16px 20px;
391
+
margin-bottom: 12px;
392
+
cursor: pointer;
393
+
transition: background 0.2s, transform 0.1s;
394
+
border-left: 4px solid transparent;
395
+
}
396
+
397
+
.email-item:hover {
398
+
background: var(--accent);
399
+
transform: translateX(4px);
400
+
}
401
+
402
+
.email-item.unread {
403
+
border-left-color: var(--highlight);
404
+
}
405
+
406
+
.email-header {
407
+
display: flex;
408
+
justify-content: space-between;
409
+
align-items: flex-start;
410
+
margin-bottom: 8px;
411
+
}
412
+
413
+
.email-from {
414
+
font-weight: 600;
415
+
font-size: 1rem;
416
+
}
417
+
418
+
.email-date {
419
+
color: var(--text-muted);
420
+
font-size: 0.85rem;
421
+
}
422
+
423
+
.email-subject {
424
+
font-size: 0.95rem;
425
+
color: var(--text);
426
+
margin-bottom: 6px;
427
+
}
428
+
429
+
.email-preview {
430
+
color: var(--text-muted);
431
+
font-size: 0.85rem;
432
+
white-space: nowrap;
433
+
overflow: hidden;
434
+
text-overflow: ellipsis;
435
+
}
436
+
437
+
.email-keywords {
438
+
margin-top: 8px;
439
+
}
440
+
441
+
.keyword-tag {
442
+
display: inline-block;
443
+
background: var(--accent);
444
+
color: var(--text-muted);
445
+
padding: 2px 8px;
446
+
border-radius: 4px;
447
+
font-size: 0.75rem;
448
+
margin-right: 6px;
449
+
}
450
+
451
+
.keyword-tag.flagged {
452
+
background: var(--warning);
453
+
color: var(--bg-color);
454
+
}
455
+
456
+
/* Loading spinner */
457
+
.spinner {
458
+
display: inline-block;
459
+
width: 20px;
460
+
height: 20px;
461
+
border: 2px solid var(--text-muted);
462
+
border-top-color: var(--highlight);
463
+
border-radius: 50%;
464
+
animation: spin 0.8s linear infinite;
465
+
margin-right: 10px;
466
+
vertical-align: middle;
467
+
}
468
+
469
+
@keyframes spin {
470
+
to { transform: rotate(360deg); }
471
+
}
472
+
473
+
/* Responsive */
474
+
@media (max-width: 600px) {
475
+
body {
476
+
padding: 10px;
477
+
}
478
+
479
+
.login-card {
480
+
padding: 20px;
481
+
}
482
+
483
+
h1 {
484
+
font-size: 1.5rem;
485
+
}
486
+
}
487
+
</style>
488
+
</head>
489
+
<body>
490
+
<div class="container">
491
+
<header>
492
+
<h1>JMAP <span>Email Client</span></h1>
493
+
<p class="subtitle">Built with OCaml and Brr</p>
494
+
</header>
495
+
496
+
<!-- Top Section: Login + Session Info -->
497
+
<div class="top-section">
498
+
<!-- Login Form -->
499
+
<div class="login-card" id="login-card">
500
+
<h3>Connection</h3>
501
+
<div class="form-group">
502
+
<label for="session-url">Session URL</label>
503
+
<input type="text" id="session-url"
504
+
value="https://api.fastmail.com/jmap/session"
505
+
placeholder="https://api.fastmail.com/jmap/session">
506
+
</div>
507
+
<div class="form-row">
508
+
<div class="form-group">
509
+
<label for="api-token">API Token</label>
510
+
<input type="password" id="api-token"
511
+
placeholder="Enter your JMAP API token">
512
+
</div>
513
+
</div>
514
+
<div class="btn-row">
515
+
<button class="btn btn-primary" id="connect-btn">Connect</button>
516
+
<button class="btn btn-secondary" id="disconnect-btn" style="display: none;">Disconnect</button>
517
+
</div>
518
+
</div>
519
+
520
+
<!-- Session Info -->
521
+
<div class="session-info" id="session-info">
522
+
<h3>Connected</h3>
523
+
<div class="session-detail">
524
+
<span class="label">Username:</span>
525
+
<span class="value" id="session-username">-</span>
526
+
</div>
527
+
<div class="session-detail">
528
+
<span class="label">API URL:</span>
529
+
<span class="value" id="session-api-url">-</span>
530
+
</div>
531
+
<div class="session-detail">
532
+
<span class="label">Account ID:</span>
533
+
<span class="value" id="session-account-id">-</span>
534
+
</div>
535
+
<div class="search-box">
536
+
<input type="text" id="email-search" placeholder="Search emails...">
537
+
<button class="btn btn-primary btn-small" id="search-btn">Search</button>
538
+
</div>
539
+
</div>
540
+
</div>
541
+
542
+
<!-- Log Panel with expandable JSON -->
543
+
<div class="log-panel" id="log-panel">
544
+
<h3>Activity Log</h3>
545
+
<div id="log-entries"></div>
546
+
</div>
547
+
548
+
<!-- Email List -->
549
+
<div class="email-list" id="email-list">
550
+
<h2>Recent Emails</h2>
551
+
<div id="emails"></div>
552
+
</div>
553
+
</div>
554
+
555
+
<script type="text/javascript" defer src="brr.js"></script>
556
+
<noscript>
557
+
<p style="text-align: center; padding: 50px; color: #888;">
558
+
Please enable JavaScript to use this application.
559
+
</p>
560
+
</noscript>
561
+
</body>
562
+
</html>
+539
web/brr_app.ml
+539
web/brr_app.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
JMAP Email Client - Browser Application
3
+
Built with OCaml, Brr, and jmap-brr
4
+
---------------------------------------------------------------------------*)
5
+
6
+
open Brr
7
+
open Fut.Syntax
8
+
9
+
(* ---- Shared timestamp utilities ---- *)
10
+
11
+
let get_time_str () =
12
+
let date = Jv.new' (Jv.get Jv.global "Date") [||] in
13
+
let h = Jv.to_int (Jv.call date "getHours" [||]) in
14
+
let m = Jv.to_int (Jv.call date "getMinutes" [||]) in
15
+
let s = Jv.to_int (Jv.call date "getSeconds" [||]) in
16
+
Printf.sprintf "%02d:%02d:%02d" h m s
17
+
18
+
(* ---- JSON Masking ---- *)
19
+
20
+
module JsonMask = struct
21
+
let sensitive_keys = [
22
+
"accountId"; "blobId"; "threadId"; "emailId"; "id";
23
+
"username"; "apiUrl"; "downloadUrl"; "uploadUrl"; "eventSourceUrl";
24
+
"state"; "oldState"; "newState"
25
+
]
26
+
27
+
let is_sensitive key =
28
+
List.exists (fun k -> String.lowercase_ascii k = String.lowercase_ascii key) sensitive_keys
29
+
30
+
let mask_value s =
31
+
let len = String.length s in
32
+
if len <= 4 then String.make len '*'
33
+
else
34
+
let visible = min 4 (len / 4) in
35
+
(String.sub s 0 visible) ^ String.make (len - visible) '*'
36
+
37
+
let rec mask_json (json : Jv.t) : Jv.t =
38
+
if Jv.is_null json || Jv.is_undefined json then json
39
+
else if Jv.is_array json then
40
+
let arr = Jv.to_list Fun.id json in
41
+
let masked = List.map mask_json arr in
42
+
Jv.of_list Fun.id masked
43
+
else if Jstr.equal (Jv.typeof json) (Jstr.v "object") && not (Jv.is_array json) then
44
+
let obj = Jv.obj [||] in
45
+
let keys = Jv.call (Jv.get Jv.global "Object") "keys" [|json|] in
46
+
let key_list = Jv.to_list Jv.to_string keys in
47
+
List.iter (fun key ->
48
+
let value = Jv.get json key in
49
+
let masked_value =
50
+
if is_sensitive key && Jstr.equal (Jv.typeof value) (Jstr.v "string") then
51
+
Jv.of_string (mask_value (Jv.to_string value))
52
+
else
53
+
mask_json value
54
+
in
55
+
Jv.set obj key masked_value
56
+
) key_list;
57
+
obj
58
+
else
59
+
json
60
+
61
+
let format_json json =
62
+
let json_obj = Jv.get Jv.global "JSON" in
63
+
Jv.to_string (Jv.call json_obj "stringify" [|json; Jv.null; Jv.of_int 2|])
64
+
65
+
let mask_and_format json_str =
66
+
try
67
+
let json_obj = Jv.get Jv.global "JSON" in
68
+
let parsed = Jv.call json_obj "parse" [|Jv.of_string json_str|] in
69
+
let masked = mask_json parsed in
70
+
format_json masked
71
+
with _ -> json_str
72
+
end
73
+
74
+
(* ---- Logging with expandable JSON ---- *)
75
+
76
+
module Log = struct
77
+
type level = Info | Success | Error | Warning
78
+
79
+
let log_entries_el () =
80
+
Document.find_el_by_id G.document (Jstr.v "log-entries")
81
+
82
+
(* Reference to the last created entry for attaching JSON *)
83
+
let last_entry : El.t option ref = ref None
84
+
85
+
let add level msg =
86
+
match log_entries_el () with
87
+
| None -> Console.(log [str msg])
88
+
| Some container ->
89
+
let time_str = get_time_str () in
90
+
let class_name = match level with
91
+
| Info -> "log-info"
92
+
| Success -> "log-success"
93
+
| Error -> "log-error"
94
+
| Warning -> "log-warning"
95
+
in
96
+
let header = El.div ~at:At.[class' (Jstr.v "log-entry-header")] [
97
+
El.span ~at:At.[class' (Jstr.v "log-time")] [El.txt' time_str];
98
+
El.span ~at:At.[class' (Jstr.v "log-message")] [El.txt' msg];
99
+
] in
100
+
let entry = El.div ~at:At.[class' (Jstr.v ("log-entry " ^ class_name))] [header] in
101
+
last_entry := Some entry;
102
+
El.append_children container [entry];
103
+
(* Scroll to bottom *)
104
+
let scroll_height = Jv.get (El.to_jv container) "scrollHeight" in
105
+
Jv.set (El.to_jv container) "scrollTop" scroll_height
106
+
107
+
let attach_json direction label json_str =
108
+
match !last_entry with
109
+
| None -> ()
110
+
| Some entry ->
111
+
let formatted = JsonMask.mask_and_format json_str in
112
+
let class_name = match direction with
113
+
| `Request -> "log-json request"
114
+
| `Response -> "log-json response"
115
+
in
116
+
let arrow = match direction with
117
+
| `Request -> ">>> "
118
+
| `Response -> "<<< "
119
+
in
120
+
(* Create the JSON container (hidden by default) *)
121
+
let json_body = El.pre ~at:At.[class' (Jstr.v "log-json-body collapsed")] [El.txt' formatted] in
122
+
let expand_size_btn = El.button ~at:At.[class' (Jstr.v "json-toggle-size")] [El.txt' "[expand]"] in
123
+
let json_div = El.div ~at:At.[class' (Jstr.v class_name)] [
124
+
El.div ~at:At.[class' (Jstr.v "log-json-header")] [
125
+
El.span [El.txt' (arrow ^ label)];
126
+
expand_size_btn;
127
+
];
128
+
json_body;
129
+
] in
130
+
(* Add expand button to header if not already there *)
131
+
let header = El.children entry |> List.hd in
132
+
let existing_btns = El.children header |> List.filter (fun el ->
133
+
match El.at (Jstr.v "class") el with
134
+
| Some cls -> Option.is_some (Jstr.find_sub ~sub:(Jstr.v "log-expand-btn") cls)
135
+
| None -> false
136
+
) in
137
+
if List.length existing_btns = 0 then begin
138
+
let expand_btn = El.button ~at:At.[class' (Jstr.v "log-expand-btn")] [El.txt' "JSON"] in
139
+
El.append_children header [expand_btn];
140
+
(* Toggle visibility on click *)
141
+
ignore @@ Ev.listen Ev.click (fun _ev ->
142
+
let json_els = El.children entry |> List.filter (fun el ->
143
+
match El.at (Jstr.v "class") el with
144
+
| Some cls -> Option.is_some (Jstr.find_sub ~sub:(Jstr.v "log-json") cls)
145
+
| None -> false
146
+
) in
147
+
let is_visible = List.exists (fun el ->
148
+
El.class' (Jstr.v "visible") el
149
+
) json_els in
150
+
List.iter (fun el ->
151
+
El.set_class (Jstr.v "visible") (not is_visible) el
152
+
) json_els;
153
+
El.set_class (Jstr.v "expanded") (not is_visible) expand_btn
154
+
) (El.as_target expand_btn)
155
+
end;
156
+
(* Toggle body size *)
157
+
ignore @@ Ev.listen Ev.click (fun _ev ->
158
+
let is_collapsed = El.class' (Jstr.v "collapsed") json_body in
159
+
El.set_class (Jstr.v "collapsed") (not is_collapsed) json_body;
160
+
El.set_children expand_size_btn [El.txt' (if is_collapsed then "[collapse]" else "[expand]")]
161
+
) (El.as_target expand_size_btn);
162
+
El.append_children entry [json_div];
163
+
(* Scroll to bottom *)
164
+
match log_entries_el () with
165
+
| Some container ->
166
+
let scroll_height = Jv.get (El.to_jv container) "scrollHeight" in
167
+
Jv.set (El.to_jv container) "scrollTop" scroll_height
168
+
| None -> ()
169
+
170
+
let info msg = add Info msg
171
+
let success msg = add Success msg
172
+
let error msg = add Error msg
173
+
let warning msg = add Warning msg
174
+
end
175
+
176
+
(* ---- JSON Protocol Logging (bridges to Log.attach_json) ---- *)
177
+
178
+
module JsonLog = struct
179
+
let request label json = Log.attach_json `Request label json
180
+
let response label json = Log.attach_json `Response label json
181
+
let clear () = () (* No longer needed *)
182
+
end
183
+
184
+
(* ---- DOM Helpers ---- *)
185
+
186
+
let get_el id =
187
+
match Document.find_el_by_id G.document (Jstr.v id) with
188
+
| Some el -> el
189
+
| None -> failwith (Printf.sprintf "Element not found: %s" id)
190
+
191
+
let get_input_value id =
192
+
let el = get_el id in
193
+
Jstr.to_string (El.prop El.Prop.value el)
194
+
195
+
let set_text id text =
196
+
let el = get_el id in
197
+
El.set_children el [El.txt' text]
198
+
199
+
let show_el id =
200
+
let el = get_el id in
201
+
El.set_class (Jstr.v "visible") true el
202
+
203
+
let hide_el id =
204
+
let el = get_el id in
205
+
El.set_class (Jstr.v "visible") false el
206
+
207
+
let set_button_loading id loading =
208
+
let el = get_el id in
209
+
El.set_at At.Name.disabled (if loading then Some (Jstr.v "") else None) el;
210
+
if loading then
211
+
El.set_children el [
212
+
El.span ~at:At.[class' (Jstr.v "spinner")] [];
213
+
El.txt' "Connecting..."
214
+
]
215
+
else
216
+
El.set_children el [El.txt' "Connect"]
217
+
218
+
(* ---- Email Display ---- *)
219
+
220
+
let format_date ptime =
221
+
let date, time = Ptime.to_date_time ptime in
222
+
let y, m, d = date in
223
+
let (h, min, _), _ = time in
224
+
Printf.sprintf "%04d-%02d-%02d %02d:%02d" y m d h min
225
+
226
+
let format_address (addr : Jmap.Proto.Email_address.t) =
227
+
match addr.name with
228
+
| Some name -> Printf.sprintf "%s <%s>" name addr.email
229
+
| None -> addr.email
230
+
231
+
let format_addresses = function
232
+
| None -> "Unknown"
233
+
| Some [] -> "Unknown"
234
+
| Some (addr :: _) -> format_address addr
235
+
236
+
let render_email (email : Jmap.Proto.Email.t) =
237
+
let keywords = Option.value ~default:[] email.keywords in
238
+
let is_unread = not (List.exists (fun (k, v) -> k = "$seen" && v) keywords) in
239
+
let is_flagged = List.exists (fun (k, v) -> k = "$flagged" && v) keywords in
240
+
241
+
let from_str = format_addresses email.from in
242
+
let subject = Option.value ~default:"(No Subject)" email.subject in
243
+
let date_str = match email.received_at with Some t -> format_date t | None -> "?" in
244
+
let preview = Option.value ~default:"" email.preview in
245
+
246
+
let keyword_tags =
247
+
if is_flagged then
248
+
[El.span ~at:At.[class' (Jstr.v "keyword-tag flagged")] [El.txt' "Flagged"]]
249
+
else
250
+
[]
251
+
in
252
+
253
+
let classes = "email-item" ^ (if is_unread then " unread" else "") in
254
+
255
+
El.div ~at:At.[class' (Jstr.v classes)] [
256
+
El.div ~at:At.[class' (Jstr.v "email-header")] [
257
+
El.span ~at:At.[class' (Jstr.v "email-from")] [El.txt' from_str];
258
+
El.span ~at:At.[class' (Jstr.v "email-date")] [El.txt' date_str];
259
+
];
260
+
El.div ~at:At.[class' (Jstr.v "email-subject")] [El.txt' subject];
261
+
El.div ~at:At.[class' (Jstr.v "email-preview")] [El.txt' preview];
262
+
El.div ~at:At.[class' (Jstr.v "email-keywords")] keyword_tags;
263
+
]
264
+
265
+
let display_emails emails =
266
+
let container = get_el "emails" in
267
+
let email_els = List.map render_email emails in
268
+
El.set_children container email_els;
269
+
show_el "email-list"
270
+
271
+
(* ---- State ---- *)
272
+
273
+
type state = {
274
+
mutable connection : Jmap_brr.connection option;
275
+
mutable account_id : Jmap.Proto.Id.t option;
276
+
}
277
+
278
+
let state = { connection = None; account_id = None }
279
+
280
+
(* ---- JMAP Operations ---- *)
281
+
282
+
let fetch_emails ?(search_text="") conn account_id =
283
+
let search_msg = if search_text = "" then "Fetching recent emails..."
284
+
else Printf.sprintf "Searching emails for '%s'..." search_text in
285
+
Log.info search_msg;
286
+
287
+
let capabilities = [
288
+
Jmap.Capability.core_uri;
289
+
Jmap.Capability.mail_uri
290
+
] in
291
+
292
+
(* First, get mailboxes to find the inbox *)
293
+
let request, mailbox_handle =
294
+
let open Jmap.Chain in
295
+
build ~capabilities (mailbox_get ~account_id ())
296
+
in
297
+
298
+
let* response = Jmap_brr.request conn request in
299
+
match response with
300
+
| Error e ->
301
+
Log.error (Printf.sprintf "Failed to get mailboxes: %s"
302
+
(Jstr.to_string (Jv.Error.message e)));
303
+
Fut.return ()
304
+
| Ok resp ->
305
+
match Jmap.Chain.parse mailbox_handle resp with
306
+
| Error e ->
307
+
Log.error (Printf.sprintf "Failed to parse mailboxes: %s"
308
+
(Jsont.Error.to_string e));
309
+
Fut.return ()
310
+
| Ok mailbox_resp ->
311
+
let mailboxes = mailbox_resp.list in
312
+
Log.info (Printf.sprintf "Found %d mailboxes" (List.length mailboxes));
313
+
314
+
(* Find inbox or use first mailbox *)
315
+
let inbox_id =
316
+
match List.find_opt (fun m ->
317
+
match m.Jmap.Proto.Mailbox.role with
318
+
| Some `Inbox -> true
319
+
| _ -> false
320
+
) mailboxes with
321
+
| Some m -> m.Jmap.Proto.Mailbox.id
322
+
| None ->
323
+
match mailboxes with
324
+
| m :: _ -> m.Jmap.Proto.Mailbox.id
325
+
| [] ->
326
+
Log.error "No mailboxes found";
327
+
failwith "No mailboxes"
328
+
in
329
+
let inbox_id = match inbox_id with
330
+
| Some id -> id
331
+
| None ->
332
+
Log.error "Inbox has no ID";
333
+
failwith "Inbox has no ID"
334
+
in
335
+
336
+
let query_msg = if search_text = "" then "Querying emails from inbox..."
337
+
else Printf.sprintf "Querying inbox for '%s'..." search_text in
338
+
Log.info query_msg;
339
+
340
+
(* Query for recent emails with optional text search *)
341
+
let text_filter = if search_text = "" then None else Some search_text in
342
+
let filter_condition : Jmap.Proto.Email.Filter_condition.t = {
343
+
in_mailbox = Some inbox_id;
344
+
in_mailbox_other_than = None;
345
+
before = None;
346
+
after = None;
347
+
min_size = None;
348
+
max_size = None;
349
+
all_in_thread_have_keyword = None;
350
+
some_in_thread_have_keyword = None;
351
+
none_in_thread_have_keyword = None;
352
+
has_keyword = None;
353
+
not_keyword = None;
354
+
has_attachment = None;
355
+
text = text_filter;
356
+
from = None;
357
+
to_ = None;
358
+
cc = None;
359
+
bcc = None;
360
+
subject = None;
361
+
body = None;
362
+
header = None;
363
+
} in
364
+
365
+
let request2, email_handle =
366
+
let open Jmap.Chain in
367
+
build ~capabilities begin
368
+
let* query = email_query ~account_id
369
+
~filter:(Jmap.Proto.Filter.Condition filter_condition)
370
+
~sort:[Jmap.Proto.Filter.comparator ~is_ascending:false "receivedAt"]
371
+
~limit:20L
372
+
()
373
+
in
374
+
email_get ~account_id
375
+
~ids:(from_query query)
376
+
~properties:["id"; "blobId"; "threadId"; "mailboxIds"; "keywords";
377
+
"size"; "receivedAt"; "from"; "subject"; "preview";
378
+
"hasAttachment"]
379
+
()
380
+
end
381
+
in
382
+
383
+
Log.info "Sending email query request...";
384
+
let* response2 = Jmap_brr.request conn request2 in
385
+
Log.info "Got email query response";
386
+
match response2 with
387
+
| Error e ->
388
+
Log.error (Printf.sprintf "Failed to query emails: %s"
389
+
(Jstr.to_string (Jv.Error.message e)));
390
+
Fut.return ()
391
+
| Ok resp2 ->
392
+
Log.info "Parsing email response...";
393
+
match Jmap.Chain.parse email_handle resp2 with
394
+
| Error e ->
395
+
Log.error (Printf.sprintf "Failed to parse emails: %s"
396
+
(Jsont.Error.to_string e));
397
+
Fut.return ()
398
+
| Ok email_resp ->
399
+
let emails = email_resp.list in
400
+
Log.success (Printf.sprintf "Loaded %d emails" (List.length emails));
401
+
(try
402
+
display_emails emails
403
+
with exn ->
404
+
Log.error (Printf.sprintf "Display error: %s" (Printexc.to_string exn)));
405
+
Fut.return ()
406
+
407
+
(* ---- Connection ---- *)
408
+
409
+
let connect () =
410
+
let session_url = get_input_value "session-url" in
411
+
let api_token = get_input_value "api-token" in
412
+
413
+
if String.length api_token = 0 then begin
414
+
Log.error "Please enter an API token";
415
+
Fut.return ()
416
+
end else begin
417
+
Log.info (Printf.sprintf "Connecting to %s..." session_url);
418
+
set_button_loading "connect-btn" true;
419
+
420
+
let* result = Jmap_brr.get_session
421
+
~url:(Jstr.v session_url)
422
+
~token:(Jstr.v api_token)
423
+
in
424
+
425
+
set_button_loading "connect-btn" false;
426
+
427
+
match result with
428
+
| Error e ->
429
+
let msg = Jstr.to_string (Jv.Error.message e) in
430
+
Log.error (Printf.sprintf "Connection failed: %s" msg);
431
+
Fut.return ()
432
+
| Ok conn ->
433
+
let session = Jmap_brr.session conn in
434
+
let username = Jmap.Proto.Session.username session in
435
+
let api_url = Jmap.Proto.Session.api_url session in
436
+
437
+
Log.success (Printf.sprintf "Connected as %s" username);
438
+
439
+
(* Find primary mail account *)
440
+
let account_id =
441
+
match Jmap.Proto.Session.primary_account_for
442
+
Jmap.Capability.mail_uri session with
443
+
| Some id -> id
444
+
| None ->
445
+
match Jmap.Proto.Session.accounts session with
446
+
| (id, _) :: _ -> id
447
+
| [] -> failwith "No accounts found"
448
+
in
449
+
450
+
state.connection <- Some conn;
451
+
state.account_id <- Some account_id;
452
+
453
+
(* Update UI *)
454
+
set_text "session-username" username;
455
+
set_text "session-api-url" api_url;
456
+
set_text "session-account-id" (Jmap.Proto.Id.to_string account_id);
457
+
show_el "session-info";
458
+
459
+
(* Show disconnect button *)
460
+
let connect_btn = get_el "connect-btn" in
461
+
let disconnect_btn = get_el "disconnect-btn" in
462
+
El.set_inline_style (Jstr.v "display") (Jstr.v "none") connect_btn;
463
+
El.set_inline_style (Jstr.v "display") (Jstr.v "block") disconnect_btn;
464
+
465
+
(* Fetch emails *)
466
+
fetch_emails conn account_id
467
+
end
468
+
469
+
let disconnect () =
470
+
state.connection <- None;
471
+
state.account_id <- None;
472
+
473
+
hide_el "session-info";
474
+
hide_el "email-list";
475
+
476
+
(* Reset buttons *)
477
+
let connect_btn = get_el "connect-btn" in
478
+
let disconnect_btn = get_el "disconnect-btn" in
479
+
El.set_inline_style (Jstr.v "display") (Jstr.v "block") connect_btn;
480
+
El.set_inline_style (Jstr.v "display") (Jstr.v "none") disconnect_btn;
481
+
482
+
Log.info "Disconnected"
483
+
484
+
let search_emails () =
485
+
match state.connection, state.account_id with
486
+
| Some conn, Some account_id ->
487
+
let search_text = get_input_value "email-search" in
488
+
ignore (fetch_emails ~search_text conn account_id)
489
+
| _ ->
490
+
Log.warning "Not connected"
491
+
492
+
(* ---- Main ---- *)
493
+
494
+
let setup_handlers () =
495
+
let connect_btn = get_el "connect-btn" in
496
+
let disconnect_btn = get_el "disconnect-btn" in
497
+
498
+
(* Connect button click *)
499
+
ignore @@ Ev.listen Ev.click (fun _ev ->
500
+
ignore (connect ())
501
+
) (El.as_target connect_btn);
502
+
503
+
(* Disconnect button click *)
504
+
ignore @@ Ev.listen Ev.click (fun _ev ->
505
+
disconnect ()
506
+
) (El.as_target disconnect_btn);
507
+
508
+
(* Enter key in token field *)
509
+
let token_input = get_el "api-token" in
510
+
ignore @@ Ev.listen Ev.keydown (fun ev ->
511
+
let kev = Ev.as_type ev in
512
+
if Jstr.equal (Ev.Keyboard.key kev) (Jstr.v "Enter") then
513
+
ignore (connect ())
514
+
) (El.as_target token_input);
515
+
516
+
(* Search button click *)
517
+
let search_btn = get_el "search-btn" in
518
+
ignore @@ Ev.listen Ev.click (fun _ev ->
519
+
search_emails ()
520
+
) (El.as_target search_btn);
521
+
522
+
(* Enter key in search field *)
523
+
let search_input = get_el "email-search" in
524
+
ignore @@ Ev.listen Ev.keydown (fun ev ->
525
+
let kev = Ev.as_type ev in
526
+
if Jstr.equal (Ev.Keyboard.key kev) (Jstr.v "Enter") then
527
+
search_emails ()
528
+
) (El.as_target search_input)
529
+
530
+
let main () =
531
+
(* Register JSON loggers *)
532
+
Jmap_brr.set_request_logger JsonLog.request;
533
+
Jmap_brr.set_response_logger JsonLog.response;
534
+
535
+
Log.info "JMAP Email Client initialized";
536
+
Log.info "Enter your JMAP server URL and API token to connect";
537
+
setup_handlers ()
538
+
539
+
let () = main ()
+15
web/dune
+15
web/dune