+7

bin/dune

··· 4 4 (package jmap-eio) 5 5 (modules jmap) 6 6 (libraries jmap-eio eio_main)) 7 7 + 8 8 + (executable 9 9 + (name jmapq) 10 10 + (public_name jmapq) 11 11 + (package jmap-eio) 12 12 + (modules jmapq) 13 13 + (libraries jmap-eio eio_main re jsont.bytesrw))

+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 33 + (* Helpers for optional Email fields *) 34 34 + let email_id (e : Jmap.Proto.Email.t) = 35 35 + match e.id with Some id -> Jmap.Proto.Id.to_string id | None -> "?" 36 36 + 37 37 + let email_received_at (e : Jmap.Proto.Email.t) = 38 38 + match e.received_at with Some t -> ptime_to_string t | None -> "?" 39 39 + 40 40 + let email_keywords (e : Jmap.Proto.Email.t) = 41 41 + Option.value ~default:[] e.keywords 42 42 + 43 43 + let email_preview (e : Jmap.Proto.Email.t) = 44 44 + Option.value ~default:"" e.preview 45 45 + 46 46 + let email_thread_id (e : Jmap.Proto.Email.t) = 47 47 + match e.thread_id with Some id -> Jmap.Proto.Id.to_string id | None -> "?" 48 48 + 49 49 + let email_size (e : Jmap.Proto.Email.t) = 50 50 + Option.value ~default:0L e.size 51 51 + 52 52 + let email_mailbox_ids (e : Jmap.Proto.Email.t) = 53 53 + Option.value ~default:[] e.mailbox_ids 54 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 101 - let cmp = Int64.compare a.sort_order b.sort_order in 102 102 - if cmp <> 0 then cmp else String.compare a.name b.name 123 123 + let sort_a = Option.value ~default:0L a.sort_order in 124 124 + let sort_b = Option.value ~default:0L b.sort_order in 125 125 + let cmp = Int64.compare sort_a sort_b in 126 126 + let name_a = Option.value ~default:"" a.name in 127 127 + let name_b = Option.value ~default:"" b.name in 128 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 135 + let id_str = match mbox.id with 136 136 + | Some id -> Jmap.Proto.Id.to_string id 137 137 + | None -> "?" 138 138 + in 139 139 + let name = Option.value ~default:"(unnamed)" mbox.name in 140 140 + let total = Option.value ~default:0L mbox.total_emails in 141 141 + let unread = Option.value ~default:0L mbox.unread_emails in 109 142 Fmt.pr " %a %s%a (%Ld total, %Ld unread)@," 110 110 - Fmt.(styled `Cyan string) (Jmap.Proto.Id.to_string mbox.id) 111 111 - mbox.name 143 143 + Fmt.(styled `Cyan string) id_str 144 144 + name 112 145 Fmt.(styled `Yellow string) role_str 113 113 - mbox.total_emails mbox.unread_emails 146 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 231 - let flags = format_keywords email.keywords in 264 264 + let keywords = Option.value ~default:[] email.keywords in 265 265 + let flags = format_keywords keywords in 232 266 let flag_str = if flags = "" then "" else " [" ^ flags ^ "]" in 267 267 + let id_str = match email.id with 268 268 + | Some id -> Jmap.Proto.Id.to_string id 269 269 + | None -> "?" 270 270 + in 271 271 + let received = match email.received_at with 272 272 + | Some t -> ptime_to_string t 273 273 + | None -> "?" 274 274 + in 275 275 + let preview = Option.value ~default:"" email.preview in 233 276 Fmt.pr " %a %s@," 234 234 - Fmt.(styled `Cyan string) (Jmap.Proto.Id.to_string email.id) 235 235 - (ptime_to_string email.received_at); 277 277 + Fmt.(styled `Cyan string) id_str 278 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 241 - (truncate_string 70 email.preview); 284 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 395 + let id_str = match email.id with 396 396 + | Some id -> Jmap.Proto.Id.to_string id 397 397 + | None -> "?" 398 398 + in 399 399 + let received = match email.received_at with 400 400 + | Some t -> ptime_to_string t 401 401 + | None -> "?" 402 402 + in 403 403 + let preview = Option.value ~default:"" email.preview in 352 404 Fmt.pr " %a %s@," 353 353 - Fmt.(styled `Cyan string) (Jmap.Proto.Id.to_string email.id) 354 354 - (ptime_to_string email.received_at); 405 405 + Fmt.(styled `Cyan string) id_str 406 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 359 - (truncate_string 70 email.preview); 411 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 463 - let flags = format_keywords email.keywords in 515 515 + let flags = format_keywords (email_keywords email) in 464 516 Printf.printf "%s\t%s\t%s\t%s\t%s\n" 465 465 - (Jmap.Proto.Id.to_string email.id) 466 466 - (ptime_to_string email.received_at) 517 517 + (email_id email) 518 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 488 - let flags = format_keywords email.keywords in 540 540 + let flags = format_keywords (email_keywords email) in 489 541 let id_short = 490 490 - let id = Jmap.Proto.Id.to_string email.id in 542 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 495 - (ptime_to_string email.received_at) 547 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 520 - let flags = format_keywords email.keywords in 521 521 - let mailbox_count = List.length email.mailbox_ids in 572 572 + let flags = format_keywords (email_keywords email) in 573 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 527 - Fmt.(styled `Cyan string) (Jmap.Proto.Id.to_string email.id); 528 528 - Fmt.pr "Thread: %s@," (Jmap.Proto.Id.to_string email.thread_id); 529 529 - Fmt.pr "Date: %s@," (ptime_to_string email.received_at); 579 579 + Fmt.(styled `Cyan string) (email_id email); 580 580 + Fmt.pr "Thread: %s@," (email_thread_id email); 581 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 535 - Fmt.pr "Size: %Ld bytes@," email.size; 587 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 538 - Fmt.pr "Preview: %s@]@,@," email.preview; 590 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 560 - let email_id = Jmap.Proto.Id.of_string_exn email_id_str in 612 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 566 - ~ids:[email_id] 618 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 591 - let thread_id = email.thread_id in 643 643 + let thread_id = match email.thread_id with 644 644 + | Some id -> id 645 645 + | None -> 646 646 + Fmt.epr "Email has no thread ID@."; 647 647 + exit 1 648 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 622 - let email_ids = thread.email_ids in 679 679 + let thread_id_str = match thread.id with 680 680 + | Some id -> Jmap.Proto.Id.to_string id 681 681 + | None -> "?" 682 682 + in 683 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 625 - (Jmap.Proto.Id.to_string thread.id) 686 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 660 - Fmt.(styled `Cyan string) (Jmap.Proto.Id.to_string email.id) 661 661 - (ptime_to_string email.received_at); 721 721 + Fmt.(styled `Cyan string) (email_id email) 722 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 765 + let ident_id = match ident.id with Some id -> Jmap.Proto.Id.to_string id | None -> "?" in 766 766 + let ident_name = Option.value ~default:"(unnamed)" ident.name in 767 767 + let ident_email = Option.value ~default:"(no email)" ident.email in 768 768 + let ident_sig = Option.value ~default:"" ident.text_signature in 769 769 + let ident_may_delete = Option.value ~default:false ident.may_delete in 704 770 Fmt.pr " %a@," 705 705 - Fmt.(styled `Cyan string) (Jmap.Proto.Id.to_string ident.id); 706 706 - Fmt.pr " Name: %s@," ident.name; 771 771 + Fmt.(styled `Cyan string) ident_id; 772 772 + Fmt.pr " Name: %s@," ident_name; 707 773 Fmt.pr " Email: %a@," 708 708 - Fmt.(styled `Green string) ident.email; 709 709 - if ident.text_signature <> "" then 710 710 - Fmt.pr " Signature: %s@," (truncate_string 50 ident.text_signature); 711 711 - Fmt.pr " May delete: %b@,@," ident.may_delete 774 774 + Fmt.(styled `Green string) ident_email; 775 775 + if ident_sig <> "" then 776 776 + Fmt.pr " Signature: %s@," (truncate_string 50 ident_sig); 777 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 763 - Jmap_eio.Cli.debug cfg "Found inbox: %s" (Jmap.Proto.Id.to_string inbox.id); 829 829 + let inbox_id = match inbox.id with 830 830 + | Some id -> id 831 831 + | None -> 832 832 + Fmt.epr "Inbox has no ID@."; 833 833 + exit 1 834 834 + in 835 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 768 - in_mailbox = Some inbox.id; 840 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 822 - let flags = format_keywords email.keywords in 894 894 + let flags = format_keywords (email_keywords email) in 823 895 Fmt.pr " %a %s@," 824 824 - Fmt.(styled `Cyan string) (Jmap.Proto.Id.to_string email.id) 825 825 - (ptime_to_string email.received_at); 896 896 + Fmt.(styled `Cyan string) (email_id email) 897 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 905 - let tid = Jmap.Proto.Id.to_string email.thread_id in 977 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 920 - Ptime.compare a.received_at b.received_at 992 992 + let a_time = Option.value ~default:Ptime.epoch a.received_at in 993 993 + let b_time = Option.value ~default:Ptime.epoch b.received_at in 994 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 934 - (Jmap.Proto.Id.to_string email.id |> truncate_string 12) 935 935 - (ptime_to_string email.received_at) 1008 1008 + (email_id email |> truncate_string 12) 1009 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 1216 - (Jmap.Proto.Id.to_string email.id |> truncate_string 12) 1290 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 1228 - let flags = format_keywords email.keywords in 1302 1302 + let flags = format_keywords (email_keywords email) in 1229 1303 Fmt.pr " ~ %s [%s]@," 1230 1230 - (Jmap.Proto.Id.to_string email.id |> truncate_string 12) 1304 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 1331 + (** Headers command - demonstrates RFC 8621 §4.1 header property queries *) 1332 1332 + let headers_cmd = 1333 1333 + let email_id_term = 1334 1334 + let doc = "Email ID to get headers for" in 1335 1335 + Arg.(required & pos 0 (some string) None & info [] ~docv:"EMAIL_ID" ~doc) 1336 1336 + in 1337 1337 + 1338 1338 + (* Format a header value for display *) 1339 1339 + let format_header_value = function 1340 1340 + | Jmap.Proto.Email_header.String_single None -> "(null)" 1341 1341 + | Jmap.Proto.Email_header.String_single (Some s) -> s 1342 1342 + | Jmap.Proto.Email_header.String_all [] -> "(empty list)" 1343 1343 + | Jmap.Proto.Email_header.String_all strs -> String.concat "; " strs 1344 1344 + | Jmap.Proto.Email_header.Addresses_single None -> "(null)" 1345 1345 + | Jmap.Proto.Email_header.Addresses_single (Some []) -> "(empty)" 1346 1346 + | Jmap.Proto.Email_header.Addresses_single (Some addrs) -> 1347 1347 + String.concat ", " (List.map (fun a -> 1348 1348 + match a.Jmap.Proto.Email_address.name with 1349 1349 + | Some n -> Printf.sprintf "%s <%s>" n a.email 1350 1350 + | None -> a.email 1351 1351 + ) addrs) 1352 1352 + | Jmap.Proto.Email_header.Addresses_all [] -> "(empty list)" 1353 1353 + | Jmap.Proto.Email_header.Addresses_all groups -> 1354 1354 + String.concat " | " (List.map (fun addrs -> 1355 1355 + String.concat ", " (List.map (fun a -> 1356 1356 + match a.Jmap.Proto.Email_address.name with 1357 1357 + | Some n -> Printf.sprintf "%s <%s>" n a.email 1358 1358 + | None -> a.email 1359 1359 + ) addrs) 1360 1360 + ) groups) 1361 1361 + | Jmap.Proto.Email_header.Grouped_single None -> "(null)" 1362 1362 + | Jmap.Proto.Email_header.Grouped_single (Some groups) -> 1363 1363 + String.concat "; " (List.map (fun g -> 1364 1364 + let name = Option.value ~default:"(ungrouped)" g.Jmap.Proto.Email_address.Group.name in 1365 1365 + let addrs = String.concat ", " (List.map (fun a -> 1366 1366 + match a.Jmap.Proto.Email_address.name with 1367 1367 + | Some n -> Printf.sprintf "%s <%s>" n a.email 1368 1368 + | None -> a.email 1369 1369 + ) g.addresses) in 1370 1370 + Printf.sprintf "%s: %s" name addrs 1371 1371 + ) groups) 1372 1372 + | Jmap.Proto.Email_header.Grouped_all _ -> "(grouped addresses list)" 1373 1373 + | Jmap.Proto.Email_header.Date_single None -> "(null)" 1374 1374 + | Jmap.Proto.Email_header.Date_single (Some t) -> ptime_to_string t 1375 1375 + | Jmap.Proto.Email_header.Date_all [] -> "(empty list)" 1376 1376 + | Jmap.Proto.Email_header.Date_all dates -> 1377 1377 + String.concat "; " (List.map (function 1378 1378 + | None -> "(null)" 1379 1379 + | Some t -> ptime_to_string t 1380 1380 + ) dates) 1381 1381 + | Jmap.Proto.Email_header.Strings_single None -> "(null)" 1382 1382 + | Jmap.Proto.Email_header.Strings_single (Some []) -> "(empty)" 1383 1383 + | Jmap.Proto.Email_header.Strings_single (Some strs) -> String.concat ", " strs 1384 1384 + | Jmap.Proto.Email_header.Strings_all [] -> "(empty list)" 1385 1385 + | Jmap.Proto.Email_header.Strings_all groups -> 1386 1386 + String.concat " | " (List.map (function 1387 1387 + | None -> "(null)" 1388 1388 + | Some strs -> String.concat ", " strs 1389 1389 + ) groups) 1390 1390 + in 1391 1391 + 1392 1392 + let run cfg email_id_str = 1393 1393 + Eio_main.run @@ fun env -> 1394 1394 + Eio.Switch.run @@ fun sw -> 1395 1395 + let client = Jmap_eio.Cli.create_client ~sw env cfg in 1396 1396 + let account_id = Jmap_eio.Cli.get_account_id cfg client in 1397 1397 + let target_email_id = Jmap.Proto.Id.of_string_exn email_id_str in 1398 1398 + 1399 1399 + Jmap_eio.Cli.debug cfg "Fetching headers for email %s" email_id_str; 1400 1400 + 1401 1401 + (* Demonstrate various header forms from RFC 8621 §4.1.2: 1402 1402 + - header:name - Raw value 1403 1403 + - header:name:asText - Text decoded 1404 1404 + - header:name:asAddresses - Address list 1405 1405 + - header:name:asGroupedAddresses - Address groups 1406 1406 + - header:name:asMessageIds - Message-ID list 1407 1407 + - header:name:asDate - RFC 3339 date 1408 1408 + - header:name:asURLs - URL list 1409 1409 + - header:name:all - All values (not just first) 1410 1410 + *) 1411 1411 + let header_props = [ 1412 1412 + (* Raw and text forms *) 1413 1413 + "header:Subject"; 1414 1414 + "header:Subject:asText"; 1415 1415 + (* Address headers *) 1416 1416 + "header:From:asAddresses"; 1417 1417 + "header:To:asAddresses"; 1418 1418 + "header:Cc:asAddresses"; 1419 1419 + "header:Bcc:asAddresses"; 1420 1420 + "header:Reply-To:asAddresses"; 1421 1421 + "header:Sender:asAddresses"; 1422 1422 + (* Grouped addresses *) 1423 1423 + "header:From:asGroupedAddresses"; 1424 1424 + (* Message ID headers *) 1425 1425 + "header:Message-ID:asMessageIds"; 1426 1426 + "header:In-Reply-To:asMessageIds"; 1427 1427 + "header:References:asMessageIds"; 1428 1428 + (* Date header *) 1429 1429 + "header:Date:asDate"; 1430 1430 + (* List headers as URLs *) 1431 1431 + "header:List-Unsubscribe:asURLs"; 1432 1432 + "header:List-Post:asURLs"; 1433 1433 + "header:List-Archive:asURLs"; 1434 1434 + (* Custom headers *) 1435 1435 + "header:X-Mailer:asText"; 1436 1436 + "header:X-Priority"; 1437 1437 + "header:X-Spam-Status:asText"; 1438 1438 + "header:Content-Type"; 1439 1439 + "header:MIME-Version"; 1440 1440 + (* Get all Received headers (typically multiple) *) 1441 1441 + "header:Received:all"; 1442 1442 + ] in 1443 1443 + 1444 1444 + let properties = "id" :: "threadId" :: "subject" :: header_props in 1445 1445 + 1446 1446 + let get_inv = Jmap_eio.Client.Build.email_get 1447 1447 + ~call_id:"h1" 1448 1448 + ~account_id 1449 1449 + ~ids:[target_email_id] 1450 1450 + ~properties 1451 1451 + () 1452 1452 + in 1453 1453 + let req = Jmap_eio.Client.Build.( 1454 1454 + make_request 1455 1455 + ~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail] 1456 1456 + [get_inv] 1457 1457 + ) in 1458 1458 + 1459 1459 + match Jmap_eio.Client.request client req with 1460 1460 + | Error e -> 1461 1461 + Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e); 1462 1462 + exit 1 1463 1463 + | Ok response -> 1464 1464 + match Jmap_eio.Client.Parse.parse_email_get ~call_id:"h1" response with 1465 1465 + | Error e -> 1466 1466 + Fmt.epr "Parse error: %s@." (Jsont.Error.to_string e); 1467 1467 + exit 1 1468 1468 + | Ok email_result -> 1469 1469 + match email_result.list with 1470 1470 + | [] -> 1471 1471 + Fmt.epr "Email not found: %s@." email_id_str; 1472 1472 + exit 1 1473 1473 + | email :: _ -> 1474 1474 + Fmt.pr "@[<v>%a@," Fmt.(styled `Bold string) "Email Headers (RFC 8621 §4.1)"; 1475 1475 + Fmt.pr "ID: %s@," (email_id email); 1476 1476 + Fmt.pr "Thread: %s@," (email_thread_id email); 1477 1477 + (match email.subject with 1478 1478 + | Some s -> Fmt.pr "Subject (convenience): %s@," s 1479 1479 + | None -> ()); 1480 1480 + Fmt.pr "@,"; 1481 1481 + 1482 1482 + (* Print dynamic headers grouped by category *) 1483 1483 + let raw_headers = Jmap.Proto.Email.dynamic_headers_raw email in 1484 1484 + if raw_headers = [] then 1485 1485 + Fmt.pr "%a@," Fmt.(styled `Yellow string) "No dynamic headers returned" 1486 1486 + else begin 1487 1487 + Fmt.pr "%a (%d properties)@,@," 1488 1488 + Fmt.(styled `Bold string) "Dynamic Header Properties" 1489 1489 + (List.length raw_headers); 1490 1490 + 1491 1491 + List.iter (fun (name, json) -> 1492 1492 + match Jmap.Proto.Email.decode_header_value name json with 1493 1493 + | None -> 1494 1494 + Fmt.pr " %a: (decode failed)@," 1495 1495 + Fmt.(styled `Red string) name 1496 1496 + | Some value -> 1497 1497 + let formatted = format_header_value value in 1498 1498 + if String.length formatted > 80 then 1499 1499 + Fmt.pr " %a:@, %s@," 1500 1500 + Fmt.(styled `Cyan string) name 1501 1501 + formatted 1502 1502 + else 1503 1503 + Fmt.pr " %a: %s@," 1504 1504 + Fmt.(styled `Cyan string) name 1505 1505 + formatted 1506 1506 + ) raw_headers 1507 1507 + end; 1508 1508 + Fmt.pr "@]@." 1509 1509 + in 1510 1510 + let doc = "Show email headers in various forms (demonstrates RFC 8621 §4.1)" in 1511 1511 + let info = Cmd.info "headers" ~doc in 1512 1512 + Cmd.v info Term.(const run $ Jmap_eio.Cli.config_term $ email_id_term) 1513 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 1540 + headers_cmd; 1283 1541 (* Chain API examples *) 1284 1542 inbox_cmd; 1285 1543 thread_view_cmd;

+434

bin/jmapq.ml

··· 1 1 + (*--------------------------------------------------------------------------- 2 2 + Copyright (c) 2025 Anil Madhavapeddy. All rights reserved. 3 3 + SPDX-License-Identifier: ISC 4 4 + ---------------------------------------------------------------------------*) 5 5 + 6 6 + (** JMAPQ - Specialist JMAP workflow commands *) 7 7 + 8 8 + open Cmdliner 9 9 + 10 10 + (** {1 Helpers} *) 11 11 + 12 12 + let ptime_to_string t = 13 13 + let (y, m, d), ((hh, mm, ss), _tz) = Ptime.to_date_time t in 14 14 + Printf.sprintf "%04d-%02d-%02d %02d:%02d:%02d" y m d hh mm ss 15 15 + 16 16 + let truncate_string max_len s = 17 17 + if String.length s <= max_len then s 18 18 + else String.sub s 0 (max_len - 3) ^ "..." 19 19 + 20 20 + (** {1 Zulip Types and Codec} *) 21 21 + 22 22 + (** Parsed information from a Zulip notification email subject. 23 23 + Subject format: "#Channel > topic [Server Name]" *) 24 24 + module Zulip_message = struct 25 25 + type t = { 26 26 + id : string; 27 27 + date : Ptime.t; 28 28 + thread_id : string; 29 29 + channel : string; 30 30 + topic : string; 31 31 + server : string; 32 32 + is_read : bool; 33 33 + labels : string list; 34 34 + } 35 35 + 36 36 + (** Parse a Zulip subject line of the form "#Channel > topic [Server Name]" *) 37 37 + let parse_subject subject = 38 38 + (* Pattern: #<channel> > <topic> [<server>] *) 39 39 + let channel_re = Re.Pcre.regexp {|^#(.+?)\s*>\s*(.+?)\s*\[(.+?)\]$|} in 40 40 + match Re.exec_opt channel_re subject with 41 41 + | Some groups -> 42 42 + let channel = Re.Group.get groups 1 in 43 43 + let topic = Re.Group.get groups 2 in 44 44 + let server = Re.Group.get groups 3 in 45 45 + Some (channel, topic, server) 46 46 + | None -> None 47 47 + 48 48 + (** Check if an email has the $seen keyword *) 49 49 + let is_seen keywords = 50 50 + List.exists (fun (k, v) -> k = "$seen" && v) keywords 51 51 + 52 52 + (** Extract label strings from keywords, excluding standard JMAP keywords *) 53 53 + let extract_labels keywords = 54 54 + keywords 55 55 + |> List.filter_map (fun (k, v) -> 56 56 + if v && not (String.length k > 0 && k.[0] = '$') then 57 57 + Some k 58 58 + else if v && k = "$flagged" then 59 59 + Some "flagged" 60 60 + else 61 61 + None) 62 62 + 63 63 + (** Create a Zulip_message from a JMAP Email *) 64 64 + let of_email (email : Jmap.Proto.Email.t) : t option = 65 65 + let id = match email.id with 66 66 + | Some id -> Jmap.Proto.Id.to_string id 67 67 + | None -> "" 68 68 + in 69 69 + let date = match email.received_at with 70 70 + | Some t -> t 71 71 + | None -> Ptime.epoch 72 72 + in 73 73 + let thread_id = match email.thread_id with 74 74 + | Some id -> Jmap.Proto.Id.to_string id 75 75 + | None -> "" 76 76 + in 77 77 + let subject = Option.value ~default:"" email.subject in 78 78 + match parse_subject subject with 79 79 + | None -> None 80 80 + | Some (channel, topic, server) -> 81 81 + let keywords = Option.value ~default:[] email.keywords in 82 82 + let is_read = is_seen keywords in 83 83 + let labels = extract_labels keywords in 84 84 + Some { id; date; thread_id; channel; topic; server; is_read; labels } 85 85 + 86 86 + (** Jsont codec for Ptime.t - reuse the library's UTC date codec *) 87 87 + let ptime_jsont : Ptime.t Jsont.t = Jmap.Proto.Date.Utc.jsont 88 88 + 89 89 + (** Jsont codec for a single Zulip message *) 90 90 + let jsont : t Jsont.t = 91 91 + let kind = "ZulipMessage" in 92 92 + let make id date thread_id channel topic server is_read labels = 93 93 + { id; date; thread_id; channel; topic; server; is_read; labels } 94 94 + in 95 95 + Jsont.Object.map ~kind make 96 96 + |> Jsont.Object.mem "id" Jsont.string ~enc:(fun t -> t.id) 97 97 + |> Jsont.Object.mem "date" ptime_jsont ~enc:(fun t -> t.date) 98 98 + |> Jsont.Object.mem "thread_id" Jsont.string ~enc:(fun t -> t.thread_id) 99 99 + |> Jsont.Object.mem "channel" Jsont.string ~enc:(fun t -> t.channel) 100 100 + |> Jsont.Object.mem "topic" Jsont.string ~enc:(fun t -> t.topic) 101 101 + |> Jsont.Object.mem "server" Jsont.string ~enc:(fun t -> t.server) 102 102 + |> Jsont.Object.mem "is_read" Jsont.bool ~enc:(fun t -> t.is_read) 103 103 + |> Jsont.Object.mem "labels" (Jsont.list Jsont.string) ~enc:(fun t -> t.labels) 104 104 + |> Jsont.Object.finish 105 105 + 106 106 + (** Jsont codec for a list of Zulip messages *) 107 107 + let list_jsont : t list Jsont.t = Jsont.list jsont 108 108 + end 109 109 + 110 110 + (** {1 Zulip List Command} *) 111 111 + 112 112 + let zulip_list_cmd = 113 113 + let json_term = 114 114 + let doc = "Output as JSON" in 115 115 + Arg.(value & flag & info ["json"] ~doc) 116 116 + in 117 117 + let limit_term = 118 118 + let doc = "Maximum number of messages to fetch (default: all)" in 119 119 + Arg.(value & opt (some int) None & info ["limit"; "n"] ~docv:"N" ~doc) 120 120 + in 121 121 + let run cfg json_output limit = 122 122 + Eio_main.run @@ fun env -> 123 123 + Eio.Switch.run @@ fun sw -> 124 124 + let client = Jmap_eio.Cli.create_client ~sw env cfg in 125 125 + let account_id = Jmap_eio.Cli.get_account_id cfg client in 126 126 + 127 127 + Jmap_eio.Cli.debug cfg "Searching for Zulip notification emails"; 128 128 + 129 129 + (* Build filter for emails from noreply@zulip.com *) 130 130 + let cond : Jmap.Proto.Email.Filter_condition.t = { 131 131 + in_mailbox = None; in_mailbox_other_than = None; 132 132 + before = None; after = None; 133 133 + min_size = None; max_size = None; 134 134 + all_in_thread_have_keyword = None; 135 135 + some_in_thread_have_keyword = None; 136 136 + none_in_thread_have_keyword = None; 137 137 + has_keyword = None; not_keyword = None; 138 138 + has_attachment = None; 139 139 + text = None; 140 140 + from = Some "noreply@zulip.com"; 141 141 + to_ = None; 142 142 + cc = None; bcc = None; subject = None; 143 143 + body = None; header = None; 144 144 + } in 145 145 + let filter = Jmap.Proto.Filter.Condition cond in 146 146 + let sort = [Jmap.Proto.Filter.comparator ~is_ascending:false "receivedAt"] in 147 147 + 148 148 + (* Query for all Zulip emails *) 149 149 + let query_limit = match limit with 150 150 + | Some n -> Int64.of_int n 151 151 + | None -> Int64.of_int 10000 (* Large default to get "all" *) 152 152 + in 153 153 + let query_inv = Jmap_eio.Client.Build.email_query 154 154 + ~call_id:"q1" 155 155 + ~account_id 156 156 + ~filter 157 157 + ~sort 158 158 + ~limit:query_limit 159 159 + () 160 160 + in 161 161 + 162 162 + let req = Jmap_eio.Client.Build.( 163 163 + make_request 164 164 + ~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail] 165 165 + [query_inv] 166 166 + ) in 167 167 + 168 168 + match Jmap_eio.Client.request client req with 169 169 + | Error e -> 170 170 + Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e); 171 171 + exit 1 172 172 + | Ok response -> 173 173 + match Jmap_eio.Client.Parse.parse_email_query ~call_id:"q1" response with 174 174 + | Error e -> 175 175 + Fmt.epr "Parse error: %s@." (Jsont.Error.to_string e); 176 176 + exit 1 177 177 + | Ok query_result -> 178 178 + let email_ids = query_result.ids in 179 179 + Jmap_eio.Cli.debug cfg "Found %d Zulip email IDs" (List.length email_ids); 180 180 + 181 181 + if List.length email_ids = 0 then ( 182 182 + if json_output then 183 183 + Fmt.pr "[]@." 184 184 + else 185 185 + Fmt.pr "No Zulip notification emails found.@." 186 186 + ) else ( 187 187 + (* Fetch email details *) 188 188 + let get_inv = Jmap_eio.Client.Build.email_get 189 189 + ~call_id:"g1" 190 190 + ~account_id 191 191 + ~ids:email_ids 192 192 + ~properties:["id"; "blobId"; "threadId"; "mailboxIds"; "keywords"; 193 193 + "size"; "receivedAt"; "subject"; "from"] 194 194 + () 195 195 + in 196 196 + let req2 = Jmap_eio.Client.Build.( 197 197 + make_request 198 198 + ~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail] 199 199 + [get_inv] 200 200 + ) in 201 201 + 202 202 + match Jmap_eio.Client.request client req2 with 203 203 + | Error e -> 204 204 + Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e); 205 205 + exit 1 206 206 + | Ok response2 -> 207 207 + match Jmap_eio.Client.Parse.parse_email_get ~call_id:"g1" response2 with 208 208 + | Error e -> 209 209 + Fmt.epr "Parse error: %s@." (Jsont.Error.to_string e); 210 210 + exit 1 211 211 + | Ok get_result -> 212 212 + (* Parse Zulip subjects and filter successful parses *) 213 213 + let zulip_messages = 214 214 + get_result.list 215 215 + |> List.filter_map Zulip_message.of_email 216 216 + in 217 217 + 218 218 + Jmap_eio.Cli.debug cfg "Parsed %d Zulip messages from %d emails" 219 219 + (List.length zulip_messages) 220 220 + (List.length get_result.list); 221 221 + 222 222 + if json_output then ( 223 223 + (* Output as JSON *) 224 224 + match Jsont_bytesrw.encode_string' ~format:Jsont.Indent Zulip_message.list_jsont zulip_messages with 225 225 + | Ok json_str -> Fmt.pr "%s@." json_str 226 226 + | Error e -> Fmt.epr "JSON encoding error: %s@." (Jsont.Error.to_string e) 227 227 + ) else ( 228 228 + (* Human-readable output *) 229 229 + Fmt.pr "@[<v>%a (%d messages)@,@," 230 230 + Fmt.(styled `Bold string) "Zulip Notifications" 231 231 + (List.length zulip_messages); 232 232 + 233 233 + (* Group by server, then by channel *) 234 234 + let by_server = Hashtbl.create 8 in 235 235 + List.iter (fun (msg : Zulip_message.t) -> 236 236 + let existing = try Hashtbl.find by_server msg.server with Not_found -> [] in 237 237 + Hashtbl.replace by_server msg.server (msg :: existing) 238 238 + ) zulip_messages; 239 239 + 240 240 + Hashtbl.iter (fun server msgs -> 241 241 + Fmt.pr "%a [%s]@," 242 242 + Fmt.(styled `Bold string) "Server:" 243 243 + server; 244 244 + 245 245 + (* Group by channel within server *) 246 246 + let by_channel = Hashtbl.create 8 in 247 247 + List.iter (fun (msg : Zulip_message.t) -> 248 248 + let existing = try Hashtbl.find by_channel msg.channel with Not_found -> [] in 249 249 + Hashtbl.replace by_channel msg.channel (msg :: existing) 250 250 + ) msgs; 251 251 + 252 252 + Hashtbl.iter (fun channel channel_msgs -> 253 253 + Fmt.pr " %a #%s (%d)@," 254 254 + Fmt.(styled `Cyan string) "Channel:" 255 255 + channel 256 256 + (List.length channel_msgs); 257 257 + 258 258 + (* Sort by date descending *) 259 259 + let sorted = List.sort (fun a b -> 260 260 + Ptime.compare b.Zulip_message.date a.Zulip_message.date 261 261 + ) channel_msgs in 262 262 + 263 263 + List.iter (fun (msg : Zulip_message.t) -> 264 264 + let read_marker = if msg.is_read then " " else "*" in 265 265 + let labels_str = match msg.labels with 266 266 + | [] -> "" 267 267 + | ls -> " [" ^ String.concat ", " ls ^ "]" 268 268 + in 269 269 + Fmt.pr " %s %s %a %s%s@," 270 270 + read_marker 271 271 + (ptime_to_string msg.date) 272 272 + Fmt.(styled `Yellow string) (truncate_string 40 msg.topic) 273 273 + (truncate_string 12 msg.id) 274 274 + labels_str 275 275 + ) sorted; 276 276 + Fmt.pr "@," 277 277 + ) by_channel 278 278 + ) by_server; 279 279 + 280 280 + Fmt.pr "@]@." 281 281 + ) 282 282 + ) 283 283 + in 284 284 + let doc = "List Zulip notification emails with parsed channel/topic info" in 285 285 + let man = [ 286 286 + `S Manpage.s_description; 287 287 + `P "Lists all emails from noreply@zulip.com and parses the subject line to extract \ 288 288 + the Zulip channel, topic, and server name."; 289 289 + `P "Subject format expected: \"#Channel > topic [Server Name]\""; 290 290 + `S Manpage.s_examples; 291 291 + `P "List all Zulip notifications:"; 292 292 + `Pre " jmapq zulip-list"; 293 293 + `P "Output as JSON:"; 294 294 + `Pre " jmapq zulip-list --json"; 295 295 + `P "Limit to 50 most recent:"; 296 296 + `Pre " jmapq zulip-list -n 50"; 297 297 + ] in 298 298 + let info = Cmd.info "zulip-list" ~doc ~man in 299 299 + Cmd.v info Term.(const run $ Jmap_eio.Cli.config_term $ json_term $ limit_term) 300 300 + 301 301 + (** {1 Zulip Timeout Command} *) 302 302 + 303 303 + (** The keyword used to mark Zulip notifications as processed *) 304 304 + let zulip_processed_keyword = "zulip-processed" 305 305 + 306 306 + let zulip_timeout_cmd = 307 307 + let email_ids_term = 308 308 + let doc = "Email IDs to mark as processed" in 309 309 + Arg.(non_empty & pos_all string [] & info [] ~docv:"EMAIL_ID" ~doc) 310 310 + in 311 311 + let run cfg email_id_strs = 312 312 + Eio_main.run @@ fun env -> 313 313 + Eio.Switch.run @@ fun sw -> 314 314 + let client = Jmap_eio.Cli.create_client ~sw env cfg in 315 315 + let account_id = Jmap_eio.Cli.get_account_id cfg client in 316 316 + let email_ids = List.map Jmap.Proto.Id.of_string_exn email_id_strs in 317 317 + 318 318 + Jmap_eio.Cli.debug cfg "Marking %d email(s) with '%s' keyword" 319 319 + (List.length email_ids) zulip_processed_keyword; 320 320 + 321 321 + (* Build patch to add the zulip-processed keyword *) 322 322 + let patch = 323 323 + let open Jmap_eio.Chain in 324 324 + json_obj [("keywords/" ^ zulip_processed_keyword, json_bool true)] 325 325 + in 326 326 + 327 327 + (* Build updates list: each email ID gets the same patch *) 328 328 + let updates = List.map (fun id -> (id, patch)) email_ids in 329 329 + 330 330 + let open Jmap_eio.Chain in 331 331 + let request, set_h = build 332 332 + ~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail] 333 333 + begin 334 334 + email_set ~account_id 335 335 + ~update:updates 336 336 + () 337 337 + end in 338 338 + 339 339 + match Jmap_eio.Client.request client request with 340 340 + | Error e -> 341 341 + Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e); 342 342 + exit 1 343 343 + | Ok response -> 344 344 + (* Check for JMAP method-level errors first *) 345 345 + let call_id = Jmap_eio.Chain.call_id set_h in 346 346 + (match Jmap.Proto.Response.find_response call_id response with 347 347 + | None -> 348 348 + Fmt.epr "Error: No response found for call_id %s@." call_id; 349 349 + exit 1 350 350 + | Some inv when Jmap.Proto.Response.is_error inv -> 351 351 + (match Jmap.Proto.Response.get_error inv with 352 352 + | Some err -> 353 353 + Fmt.epr "JMAP Error: %s%s@." 354 354 + (Jmap.Proto.Error.method_error_type_to_string err.type_) 355 355 + (match err.description with Some d -> " - " ^ d | None -> ""); 356 356 + exit 1 357 357 + | None -> 358 358 + Fmt.epr "JMAP Error: Unknown error@."; 359 359 + exit 1) 360 360 + | Some _ -> 361 361 + match parse set_h response with 362 362 + | Error e -> 363 363 + Fmt.epr "Parse error: %s@." (Jsont.Error.to_string e); 364 364 + exit 1 365 365 + | Ok result -> 366 366 + (* Report successes *) 367 367 + let updated_ids = 368 368 + result.updated 369 369 + |> Option.value ~default:[] 370 370 + |> List.map (fun (id, _) -> Jmap.Proto.Id.to_string id) 371 371 + in 372 372 + if List.length updated_ids > 0 then begin 373 373 + Fmt.pr "@[<v>%a %d email(s) with '%s':@," 374 374 + Fmt.(styled `Green string) "Marked" 375 375 + (List.length updated_ids) 376 376 + zulip_processed_keyword; 377 377 + List.iter (fun id -> Fmt.pr " %s@," id) updated_ids; 378 378 + Fmt.pr "@]@." 379 379 + end; 380 380 + 381 381 + (* Report failures *) 382 382 + let not_updated = Option.value ~default:[] result.not_updated in 383 383 + if not_updated <> [] then begin 384 384 + Fmt.epr "@[<v>%a to mark %d email(s):@," 385 385 + Fmt.(styled `Red string) "Failed" 386 386 + (List.length not_updated); 387 387 + List.iter (fun (id, err) -> 388 388 + let open Jmap.Proto.Error in 389 389 + let err_type = set_error_type_to_string err.type_ in 390 390 + let err_desc = Option.value ~default:"" err.description in 391 391 + Fmt.epr " %s: %s%s@," 392 392 + (Jmap.Proto.Id.to_string id) 393 393 + err_type 394 394 + (if err_desc = "" then "" else " - " ^ err_desc) 395 395 + ) not_updated; 396 396 + Fmt.epr "@]@."; 397 397 + exit 1 398 398 + end) 399 399 + in 400 400 + let doc = "Mark Zulip notification emails as processed" in 401 401 + let man = [ 402 402 + `S Manpage.s_description; 403 403 + `P (Printf.sprintf "Adds the '%s' keyword to the specified email(s). \ 404 404 + This keyword can be used to filter processed Zulip notifications \ 405 405 + or set up server-side rules to auto-archive them." 406 406 + zulip_processed_keyword); 407 407 + `S Manpage.s_examples; 408 408 + `P "Mark a single email as processed:"; 409 409 + `Pre " jmapq zulip-timeout StrrDTS_WEa3"; 410 410 + `P "Mark multiple emails as processed:"; 411 411 + `Pre " jmapq zulip-timeout StrrDTS_WEa3 StrsGZ7P8Dpc StrsGuCSXJ3Z"; 412 412 + ] in 413 413 + let info = Cmd.info "zulip-timeout" ~doc ~man in 414 414 + Cmd.v info Term.(const run $ Jmap_eio.Cli.config_term $ email_ids_term) 415 415 + 416 416 + (** {1 Main Command Group} *) 417 417 + 418 418 + let main_cmd = 419 419 + let doc = "JMAPQ - Specialist JMAP workflow commands" in 420 420 + let man = [ 421 421 + `S Manpage.s_description; 422 422 + `P "A collection of specialist workflow commands for JMAP email processing."; 423 423 + `S Manpage.s_environment; 424 424 + `P Jmap_eio.Cli.env_docs; 425 425 + ] in 426 426 + let info = Cmd.info "jmapq" ~version:"0.1.0" ~doc ~man in 427 427 + Cmd.group info [ 428 428 + zulip_list_cmd; 429 429 + zulip_timeout_cmd; 430 430 + ] 431 431 + 432 432 + let () = 433 433 + Fmt_tty.setup_std_outputs (); 434 434 + exit (Cmd.eval main_cmd)

+7

doc/dune

··· 1 1 + (mdx 2 2 + (files tutorial.mld) 3 3 + (libraries jmap jmap_top jsont jsont.bytesrw)) 4 4 + 5 5 + (documentation 6 6 + (package jmap) 7 7 + (mld_files index tutorial))

+13

doc/index.mld

··· 1 1 + {0 jmap} 2 2 + 3 3 + {!modules: Jmap Jmap_top} 4 4 + 5 5 + {1 Tutorial} 6 6 + 7 7 + See the {!page-tutorial} for a comprehensive guide to using JMAP with OCaml, 8 8 + including how types map to JSON and practical examples. 9 9 + 10 10 + {1 Browser Support} 11 11 + 12 12 + For browser-based applications, see the [jmap-brr] package which provides 13 13 + a JMAP client using the Brr library and js_of_ocaml.

+494

doc/tutorial.mld

··· 1 1 + {0 JMAP Tutorial} 2 2 + 3 3 + This tutorial introduces JMAP (JSON Meta Application Protocol) and 4 4 + demonstrates the [jmap] OCaml library through interactive examples. JMAP 5 5 + is defined in {{:https://www.rfc-editor.org/rfc/rfc8620}RFC 8620} (core) 6 6 + and {{:https://www.rfc-editor.org/rfc/rfc8621}RFC 8621} (mail). 7 7 + 8 8 + {1 What is JMAP?} 9 9 + 10 10 + JMAP is a modern, efficient protocol for synchronizing mail and other 11 11 + data. It's designed as a better alternative to IMAP, addressing many of 12 12 + IMAP's limitations: 13 13 + 14 14 + {ul 15 15 + {- {b Stateless over HTTP}: Unlike IMAP's persistent TCP connections, JMAP 16 16 + uses standard HTTP POST requests with JSON payloads.} 17 17 + {- {b Efficient batching}: Multiple operations can be combined into a single 18 18 + request, reducing round-trips.} 19 19 + {- {b Result references}: The output of one method call can be used as input 20 20 + to another in the same request.} 21 21 + {- {b Push support}: Built-in mechanisms for real-time notifications.} 22 22 + {- {b Binary data handling}: Separate upload/download endpoints for large 23 23 + attachments.}} 24 24 + 25 25 + The core protocol (RFC 8620) defines the general structure, while RFC 8621 26 26 + extends it specifically for email, mailboxes, threads, and related objects. 27 27 + 28 28 + {1 Setup} 29 29 + 30 30 + First, let's set up our environment. In the toplevel, load the library 31 31 + with [#require "jmap.top";;] which will automatically install pretty 32 32 + printers. 33 33 + 34 34 + {@ocaml[ 35 35 + # Jmap_top.install ();; 36 36 + - : unit = () 37 37 + # open Jmap;; 38 38 + ]} 39 39 + 40 40 + For parsing and encoding JSON, we'll use some helper functions: 41 41 + 42 42 + {@ocaml[ 43 43 + # let parse_json s = 44 44 + match Jsont_bytesrw.decode_string Jsont.json s with 45 45 + | Ok json -> json 46 46 + | Error e -> failwith e;; 47 47 + val parse_json : string -> Jsont.json = <fun> 48 48 + # let json_to_string json = 49 49 + match Jsont_bytesrw.encode_string ~format:Jsont.Indent Jsont.json json with 50 50 + | Ok s -> s 51 51 + | Error e -> failwith e;; 52 52 + val json_to_string : Jsont.json -> string = <fun> 53 53 + ]} 54 54 + 55 55 + {1 JMAP Identifiers} 56 56 + 57 57 + From {{:https://www.rfc-editor.org/rfc/rfc8620#section-1.2}RFC 8620 Section 1.2}: 58 58 + 59 59 + {i An "Id" is a String of at least 1 and a maximum of 255 octets in size, 60 60 + and it MUST only contain characters from the "URL and Filename Safe" 61 61 + base64 alphabet.} 62 62 + 63 63 + The {!Jmap.Id} module provides type-safe identifiers: 64 64 + 65 65 + {@ocaml[ 66 66 + # let id = Id.of_string_exn "abc123";; 67 67 + val id : Id.t = abc123 68 68 + # Id.to_string id;; 69 69 + - : string = "abc123" 70 70 + ]} 71 71 + 72 72 + Invalid identifiers are rejected: 73 73 + 74 74 + {@ocaml[ 75 75 + # Id.of_string "";; 76 76 + - : (Id.t, string) result = Error "Id cannot be empty" 77 77 + # Id.of_string (String.make 256 'x');; 78 78 + - : (Id.t, string) result = Error "Id cannot exceed 255 characters" 79 79 + ]} 80 80 + 81 81 + {1 Keywords} 82 82 + 83 83 + Email keywords are string flags that indicate message state. RFC 8621 84 84 + defines standard keywords, and the library represents them as polymorphic 85 85 + variants for type safety. 86 86 + 87 87 + {2 Standard Keywords} 88 88 + 89 89 + From {{:https://www.rfc-editor.org/rfc/rfc8621#section-4.1.1}RFC 8621 90 90 + Section 4.1.1}: 91 91 + 92 92 + {@ocaml[ 93 93 + # Keyword.of_string "$seen";; 94 94 + - : Keyword.t = $seen 95 95 + # Keyword.of_string "$flagged";; 96 96 + - : Keyword.t = $flagged 97 97 + # Keyword.of_string "$draft";; 98 98 + - : Keyword.t = $draft 99 99 + # Keyword.of_string "$answered";; 100 100 + - : Keyword.t = $answered 101 101 + ]} 102 102 + 103 103 + The standard keywords are: 104 104 + 105 105 + {ul 106 106 + {- [`Seen] - The email has been read} 107 107 + {- [`Flagged] - The email has been flagged for attention} 108 108 + {- [`Draft] - The email is a draft being composed} 109 109 + {- [`Answered] - The email has been replied to} 110 110 + {- [`Forwarded] - The email has been forwarded} 111 111 + {- [`Phishing] - The email is likely phishing} 112 112 + {- [`Junk] - The email is spam} 113 113 + {- [`NotJunk] - The email is definitely not spam}} 114 114 + 115 115 + {2 Extended Keywords} 116 116 + 117 117 + The library also supports draft-ietf-mailmaint extended keywords: 118 118 + 119 119 + {@ocaml[ 120 120 + # Keyword.of_string "$notify";; 121 121 + - : Keyword.t = $notify 122 122 + # Keyword.of_string "$muted";; 123 123 + - : Keyword.t = $muted 124 124 + # Keyword.of_string "$hasattachment";; 125 125 + - : Keyword.t = $hasattachment 126 126 + ]} 127 127 + 128 128 + {2 Custom Keywords} 129 129 + 130 130 + Unknown keywords are preserved as [`Custom]: 131 131 + 132 132 + {@ocaml[ 133 133 + # Keyword.of_string "$my_custom_flag";; 134 134 + - : Keyword.t = $my_custom_flag 135 135 + ]} 136 136 + 137 137 + {2 Converting Back to Strings} 138 138 + 139 139 + {@ocaml[ 140 140 + # Keyword.to_string `Seen;; 141 141 + - : string = "$seen" 142 142 + # Keyword.to_string `Flagged;; 143 143 + - : string = "$flagged" 144 144 + # Keyword.to_string (`Custom "$important");; 145 145 + - : string = "$important" 146 146 + ]} 147 147 + 148 148 + {1 Mailbox Roles} 149 149 + 150 150 + Mailboxes can have special roles that indicate their purpose. From 151 151 + {{:https://www.rfc-editor.org/rfc/rfc8621#section-2}RFC 8621 Section 2}: 152 152 + 153 153 + {@ocaml[ 154 154 + # Role.of_string "inbox";; 155 155 + - : Role.t = inbox 156 156 + # Role.of_string "sent";; 157 157 + - : Role.t = sent 158 158 + # Role.of_string "drafts";; 159 159 + - : Role.t = drafts 160 160 + # Role.of_string "trash";; 161 161 + - : Role.t = trash 162 162 + # Role.of_string "junk";; 163 163 + - : Role.t = junk 164 164 + # Role.of_string "archive";; 165 165 + - : Role.t = archive 166 166 + ]} 167 167 + 168 168 + Custom roles are also supported: 169 169 + 170 170 + {@ocaml[ 171 171 + # Role.of_string "receipts";; 172 172 + - : Role.t = receipts 173 173 + ]} 174 174 + 175 175 + {1 Capabilities} 176 176 + 177 177 + JMAP uses capability URIs to indicate supported features. From 178 178 + {{:https://www.rfc-editor.org/rfc/rfc8620#section-2}RFC 8620 Section 2}: 179 179 + 180 180 + {@ocaml[ 181 181 + # Capability.core_uri;; 182 182 + - : string = "urn:ietf:params:jmap:core" 183 183 + # Capability.mail_uri;; 184 184 + - : string = "urn:ietf:params:jmap:mail" 185 185 + # Capability.submission_uri;; 186 186 + - : string = "urn:ietf:params:jmap:submission" 187 187 + ]} 188 188 + 189 189 + {@ocaml[ 190 190 + # Capability.of_string Capability.core_uri;; 191 191 + - : Capability.t = urn:ietf:params:jmap:core 192 192 + # Capability.of_string Capability.mail_uri;; 193 193 + - : Capability.t = urn:ietf:params:jmap:mail 194 194 + # Capability.of_string "urn:example:custom";; 195 195 + - : Capability.t = urn:example:custom 196 196 + ]} 197 197 + 198 198 + {1 Understanding JMAP JSON Structure} 199 199 + 200 200 + One of the key benefits of JMAP over IMAP is its use of JSON. Let's see 201 201 + how OCaml types map to the wire format. 202 202 + 203 203 + {2 Requests} 204 204 + 205 205 + A JMAP request contains: 206 206 + - [using]: List of capability URIs required 207 207 + - [methodCalls]: Array of method invocations 208 208 + 209 209 + Each method invocation is a triple: [methodName], [arguments], [callId]. 210 210 + 211 211 + Here's how a simple request is structured: 212 212 + 213 213 + {x@ocaml[ 214 214 + # let req = Jmap.Proto.Request.create 215 215 + ~using:[Capability.core_uri; Capability.mail_uri] 216 216 + ~method_calls:[ 217 217 + Jmap.Proto.Invocation.create 218 218 + ~name:"Mailbox/get" 219 219 + ~arguments:(parse_json {|{"accountId": "abc123"}|}) 220 220 + ~call_id:"c0" 221 221 + ] 222 222 + ();; 223 223 + Line 7, characters 18-22: 224 224 + Error: The function applied to this argument has type 225 225 + method_call_id:string -> Proto.Invocation.t 226 226 + This argument cannot be applied with label ~call_id 227 227 + # Jmap_top.encode Jmap.Proto.Request.jsont req |> json_to_string |> print_endline;; 228 228 + Line 1, characters 42-45: 229 229 + Error: Unbound value req 230 230 + Hint: Did you mean ref? 231 231 + ]x} 232 232 + 233 233 + {2 Email Filter Conditions} 234 234 + 235 235 + Filters demonstrate how complex query conditions map to JSON. From 236 236 + {{:https://www.rfc-editor.org/rfc/rfc8621#section-4.4.1}RFC 8621 237 237 + Section 4.4.1}: 238 238 + 239 239 + {x@ocaml[ 240 240 + # let filter_condition : Jmap.Proto.Email.Filter_condition.t = { 241 241 + in_mailbox = Some (Id.of_string_exn "inbox123"); 242 242 + in_mailbox_other_than = None; 243 243 + before = None; 244 244 + after = None; 245 245 + min_size = None; 246 246 + max_size = None; 247 247 + all_in_thread_have_keyword = None; 248 248 + some_in_thread_have_keyword = None; 249 249 + none_in_thread_have_keyword = None; 250 250 + has_keyword = Some "$flagged"; 251 251 + not_keyword = None; 252 252 + has_attachment = Some true; 253 253 + text = None; 254 254 + from = Some "alice@"; 255 255 + to_ = None; 256 256 + cc = None; 257 257 + bcc = None; 258 258 + subject = Some "urgent"; 259 259 + body = None; 260 260 + header = None; 261 261 + };; 262 262 + Line 2, characters 23-52: 263 263 + Error: This expression has type Id.t but an expression was expected of type 264 264 + Proto.Id.t 265 265 + # Jmap_top.encode Jmap.Proto.Email.Filter_condition.jsont filter_condition 266 266 + |> json_to_string |> print_endline;; 267 267 + Line 1, characters 57-73: 268 268 + Error: Unbound value filter_condition 269 269 + ]x} 270 270 + 271 271 + Notice how: 272 272 + - OCaml record fields use [snake_case], but JSON uses [camelCase] 273 273 + - [None] values are omitted from JSON (not sent as [null]) 274 274 + - The filter only includes non-empty conditions 275 275 + 276 276 + {2 Filter Operators} 277 277 + 278 278 + Filters can be combined with AND, OR, and NOT operators: 279 279 + 280 280 + {x@ocaml[ 281 281 + # let combined_filter = Jmap.Proto.Filter.Operator { 282 282 + operator = `And; 283 283 + conditions = [ 284 284 + Condition filter_condition; 285 285 + Condition { filter_condition with has_keyword = Some "$seen" } 286 286 + ] 287 287 + };; 288 288 + Line 4, characters 17-33: 289 289 + Error: Unbound value filter_condition 290 290 + ]x} 291 291 + 292 292 + {1 Method Chaining} 293 293 + 294 294 + One of JMAP's most powerful features is result references - using the 295 295 + output of one method as input to another. The {!Jmap.Chain} module 296 296 + provides a monadic interface for building such requests. 297 297 + 298 298 + From {{:https://www.rfc-editor.org/rfc/rfc8620#section-3.7}RFC 8620 299 299 + Section 3.7}: 300 300 + 301 301 + {i A method argument may use the result of a previous method invocation 302 302 + in the same request.} 303 303 + 304 304 + {2 Basic Example} 305 305 + 306 306 + Query for emails, then fetch their details: 307 307 + 308 308 + {[ 309 309 + open Jmap.Chain 310 310 + 311 311 + let request, handle = build ~capabilities:[core; mail] begin 312 312 + let* query = email_query ~account_id 313 313 + ~filter:(Condition { in_mailbox = Some inbox_id; (* ... *) }) 314 314 + ~limit:50L () 315 315 + in 316 316 + let* emails = email_get ~account_id 317 317 + ~ids:(from_query query) (* Reference query results! *) 318 318 + ~properties:["subject"; "from"; "receivedAt"] 319 319 + () 320 320 + in 321 321 + return emails 322 322 + end 323 323 + ][ 324 324 + {err@mdx-error[ 325 325 + Line 3, characters 46-50: 326 326 + Error: Unbound value core 327 327 + ]err}]} 328 328 + 329 329 + The key insight is [from_query query] - this creates a reference to the 330 330 + [ids] array from the query response. The server processes both calls in 331 331 + sequence, substituting the reference with actual IDs. 332 332 + 333 333 + {2 Creation and Submission} 334 334 + 335 335 + Create a draft and send it in one request: 336 336 + 337 337 + {[ 338 338 + let* set_h, draft_cid = email_set ~account_id 339 339 + ~create:[("draft1", draft_email_json)] 340 340 + () 341 341 + in 342 342 + let* _ = email_submission_set ~account_id 343 343 + ~create:[("sub1", submission_json 344 344 + ~email_id:(created_id_of_string "draft1") (* Reference creation! *) 345 345 + ~identity_id)] 346 346 + () 347 347 + in 348 348 + return set_h 349 349 + ][ 350 350 + {err@mdx-error[ 351 351 + Line 1, characters 1-5: 352 352 + Error: Unbound value ( let* ) 353 353 + ]err}]} 354 354 + 355 355 + {2 The RFC 8620 Example} 356 356 + 357 357 + The RFC provides a complex example: fetch from/date/subject for all 358 358 + emails in the first 10 threads in the inbox: 359 359 + 360 360 + {[ 361 361 + let* q = email_query ~account_id 362 362 + ~filter:(Condition { in_mailbox = Some inbox_id; (* ... *) }) 363 363 + ~sort:[comparator ~is_ascending:false "receivedAt"] 364 364 + ~collapse_threads:true ~limit:10L () 365 365 + in 366 366 + let* e1 = email_get ~account_id 367 367 + ~ids:(from_query q) 368 368 + ~properties:["threadId"] 369 369 + () 370 370 + in 371 371 + let* threads = thread_get ~account_id 372 372 + ~ids:(from_get_field e1 "threadId") (* Get threadIds from emails *) 373 373 + () 374 374 + in 375 375 + let* e2 = email_get ~account_id 376 376 + ~ids:(from_get_field threads "emailIds") (* Get all emailIds in threads *) 377 377 + ~properties:["from"; "receivedAt"; "subject"] 378 378 + () 379 379 + in 380 380 + return e2 381 381 + ][ 382 382 + {err@mdx-error[ 383 383 + Line 1, characters 1-5: 384 384 + Error: Unbound value ( let* ) 385 385 + ]err}]} 386 386 + 387 387 + This entire flow executes in a {e single HTTP request}! 388 388 + 389 389 + {1 Error Handling} 390 390 + 391 391 + JMAP has a structured error system with three levels: 392 392 + 393 393 + {2 Request-Level Errors} 394 394 + 395 395 + These are returned with HTTP error status codes and RFC 7807 Problem 396 396 + Details. From {{:https://www.rfc-editor.org/rfc/rfc8620#section-3.6.1}RFC 397 397 + 8620 Section 3.6.1}: 398 398 + 399 399 + {@ocaml[ 400 400 + # Error.to_string (`Request { 401 401 + Error.type_ = "urn:ietf:params:jmap:error:unknownCapability"; 402 402 + status = Some 400; 403 403 + title = Some "Unknown Capability"; 404 404 + detail = Some "The server does not support 'urn:example:unsupported'"; 405 405 + limit = None; 406 406 + });; 407 407 + - : string = 408 408 + "Request error: urn:ietf:params:jmap:error:unknownCapability (status 400): The server does not support 'urn:example:unsupported'" 409 409 + ]} 410 410 + 411 411 + {2 Method-Level Errors} 412 412 + 413 413 + Individual method calls can fail while others succeed: 414 414 + 415 415 + {@ocaml[ 416 416 + # Error.to_string (`Method { 417 417 + Error.type_ = "invalidArguments"; 418 418 + description = Some "The 'filter' argument is malformed"; 419 419 + });; 420 420 + - : string = 421 421 + "Method error: invalidArguments: The 'filter' argument is malformed" 422 422 + ]} 423 423 + 424 424 + {2 SetError} 425 425 + 426 426 + Object-level errors in /set responses: 427 427 + 428 428 + {@ocaml[ 429 429 + # Error.to_string (`Set ("draft1", { 430 430 + Error.type_ = "invalidProperties"; 431 431 + description = Some "Unknown property: foobar"; 432 432 + properties = Some ["foobar"]; 433 433 + }));; 434 434 + - : string = 435 435 + "Set error for draft1: invalidProperties: Unknown property: foobar" 436 436 + ]} 437 437 + 438 438 + {1 Using with FastMail} 439 439 + 440 440 + FastMail is a popular JMAP provider. Here's how to connect: 441 441 + 442 442 + {[ 443 443 + (* Get a token from https://app.fastmail.com/settings/tokens *) 444 444 + let token = "your-api-token" 445 445 + 446 446 + (* The session URL for FastMail *) 447 447 + let session_url = "https://api.fastmail.com/jmap/session" 448 448 + 449 449 + (* For browser applications using jmap-brr: *) 450 450 + let main () = 451 451 + let open Fut.Syntax in 452 452 + let* conn = Jmap_brr.get_session 453 453 + ~url:(Jstr.v session_url) 454 454 + ~token:(Jstr.v token) 455 455 + in 456 456 + match conn with 457 457 + | Error e -> Brr.Console.(error [str "Error:"; e]); Fut.return () 458 458 + | Ok conn -> 459 459 + let session = Jmap_brr.session conn in 460 460 + Brr.Console.(log [str "Connected as:"; 461 461 + str (Jmap.Session.username session)]); 462 462 + Fut.return () 463 463 + ][ 464 464 + {err@mdx-error[ 465 465 + Line 9, characters 14-17: 466 466 + Error: Unbound module Fut 467 467 + Hint: Did you mean Fun? 468 468 + ]err}]} 469 469 + 470 470 + {1 Summary} 471 471 + 472 472 + JMAP (RFC 8620/8621) provides a modern, efficient protocol for email: 473 473 + 474 474 + {ol 475 475 + {- {b Sessions}: Discover capabilities and account information via GET request} 476 476 + {- {b Batching}: Combine multiple method calls in one request} 477 477 + {- {b References}: Use results from one method as input to another} 478 478 + {- {b Type Safety}: The [jmap] library uses polymorphic variants for keywords and roles} 479 479 + {- {b JSON Mapping}: OCaml types map cleanly to JMAP JSON structure} 480 480 + {- {b Browser Support}: The [jmap-brr] package enables browser-based clients}} 481 481 + 482 482 + The [jmap] library provides: 483 483 + {ul 484 484 + {- {!Jmap} - High-level interface with abstract types} 485 485 + {- {!Jmap.Proto} - Low-level protocol types matching the RFCs} 486 486 + {- {!Jmap.Chain} - Monadic interface for request chaining} 487 487 + {- [Jmap_brr] - Browser support via Brr/js_of_ocaml (separate package)}} 488 488 + 489 489 + {2 Key RFC References} 490 490 + 491 491 + {ul 492 492 + {- {{:https://www.rfc-editor.org/rfc/rfc8620}RFC 8620}: JMAP Core} 493 493 + {- {{:https://www.rfc-editor.org/rfc/rfc8621}RFC 8621}: JMAP for Mail} 494 494 + {- {{:https://www.rfc-editor.org/rfc/rfc7807}RFC 7807}: Problem Details for HTTP APIs}}

+12

dune-project

··· 1 1 (lang dune 3.20) 2 2 3 3 + (using mdx 0.4) 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 41 + 42 42 + (package 43 43 + (name jmap-brr) 44 44 + (synopsis "JMAP client for browsers") 45 45 + (description "JMAP client using Brr for browser-based email clients with js_of_ocaml.") 46 46 + (depends 47 47 + (ocaml (>= 5.4.0)) 48 48 + (jmap (= :version)) 49 49 + (jsont (>= 0.2.0)) 50 50 + (brr (>= 0.0.6))))

+35

jmap-brr.opam

··· 1 1 + # This file is generated by dune, edit dune-project instead 2 2 + opam-version: "2.0" 3 3 + synopsis: "JMAP client for browsers" 4 4 + description: 5 5 + "JMAP client using Brr for browser-based email clients with js_of_ocaml." 6 6 + maintainer: ["Anil Madhavapeddy <anil@recoil.org>"] 7 7 + authors: ["Anil Madhavapeddy <anil@recoil.org>"] 8 8 + license: "ISC" 9 9 + homepage: "https://github.com/avsm/ocaml-jmap" 10 10 + doc: "https://avsm.github.io/ocaml-jmap" 11 11 + bug-reports: "https://github.com/avsm/ocaml-jmap/issues" 12 12 + depends: [ 13 13 + "dune" {>= "3.20"} 14 14 + "ocaml" {>= "5.4.0"} 15 15 + "jmap" {= version} 16 16 + "jsont" {>= "0.2.0"} 17 17 + "brr" {>= "0.0.6"} 18 18 + "odoc" {with-doc} 19 19 + ] 20 20 + build: [ 21 21 + ["dune" "subst"] {dev} 22 22 + [ 23 23 + "dune" 24 24 + "build" 25 25 + "-p" 26 26 + name 27 27 + "-j" 28 28 + jobs 29 29 + "@install" 30 30 + "@runtest" {with-test} 31 31 + "@doc" {with-doc} 32 32 + ] 33 33 + ] 34 34 + dev-repo: "git+https://github.com/avsm/ocaml-jmap.git" 35 35 + x-maintenance-intent: ["(latest)"]

+9 -6

lib/core/jmap.ml

··· 216 216 217 217 (** Get active keywords as polymorphic variants. *) 218 218 let keywords e = 219 219 - let kw_map = Proto.Email.keywords e in 220 220 - List.filter_map (fun (k, v) -> 221 221 - if v then Some (Keyword.of_string k) else None 222 222 - ) kw_map 219 219 + match Proto.Email.keywords e with 220 220 + | None -> [] 221 221 + | Some kw_map -> 222 222 + List.filter_map (fun (k, v) -> 223 223 + if v then Some (Keyword.of_string k) else None 224 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 227 - let kw_map = Proto.Email.keywords e in 228 228 - List.exists (fun (k, v) -> k = kw_str && v) kw_map 229 229 + match Proto.Email.keywords e with 230 230 + | None -> false 231 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

··· 267 267 val create : ?name:string -> string -> t 268 268 end 269 269 270 270 - (** Email mailbox. *) 270 270 + (** Email mailbox. 271 271 + All accessors return option types since responses only include requested properties. *) 271 272 module Mailbox : sig 272 273 type t 273 274 274 274 - val id : t -> Id.t 275 275 - val name : t -> string 275 275 + val id : t -> Id.t option 276 276 + val name : t -> string option 276 277 val parent_id : t -> Id.t option 277 277 - val sort_order : t -> int64 278 278 - val total_emails : t -> int64 279 279 - val unread_emails : t -> int64 280 280 - val total_threads : t -> int64 281 281 - val unread_threads : t -> int64 282 282 - val is_subscribed : t -> bool 278 278 + val sort_order : t -> int64 option 279 279 + val total_emails : t -> int64 option 280 280 + val unread_emails : t -> int64 option 281 281 + val total_threads : t -> int64 option 282 282 + val unread_threads : t -> int64 option 283 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 300 - val my_rights : t -> Rights.t 301 301 + val my_rights : t -> Rights.t option 301 302 end 302 303 303 303 - (** Email thread. *) 304 304 + (** Email thread. 305 305 + All accessors return option types since responses only include requested properties. *) 304 306 module Thread : sig 305 307 type t 306 308 307 307 - val id : t -> Id.t 308 308 - val email_ids : t -> Id.t list 309 309 + val id : t -> Id.t option 310 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 336 + (** All accessors return option types since responses only include requested properties. *) 334 337 type t 335 338 336 336 - val id : t -> Id.t 337 337 - val blob_id : t -> Id.t 338 338 - val thread_id : t -> Id.t 339 339 - val mailbox_ids : t -> (Id.t * bool) list 340 340 - val size : t -> int64 341 341 - val received_at : t -> Ptime.t 339 339 + val id : t -> Id.t option 340 340 + val blob_id : t -> Id.t option 341 341 + val thread_id : t -> Id.t option 342 342 + val mailbox_ids : t -> (Id.t * bool) list option 343 343 + val size : t -> int64 option 344 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 347 - val has_attachment : t -> bool 348 348 - val preview : t -> string 350 350 + val has_attachment : t -> bool option 351 351 + val preview : t -> string option 349 352 350 350 - (** Get active keywords as polymorphic variants. *) 353 353 + (** Get active keywords as polymorphic variants. 354 354 + Returns empty list if keywords property was not requested. *) 351 355 val keywords : t -> Keyword.t list 352 356 353 353 - (** Check if email has a specific keyword. *) 357 357 + (** Check if email has a specific keyword. 358 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 369 - (** Email identity for sending. *) 374 374 + (** Email identity for sending. 375 375 + All accessors return option types since responses only include requested properties. *) 370 376 module Identity : sig 371 377 type t 372 378 373 373 - val id : t -> Id.t 374 374 - val name : t -> string 375 375 - val email : t -> string 379 379 + val id : t -> Id.t option 380 380 + val name : t -> string option 381 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 378 - val text_signature : t -> string 379 379 - val html_signature : t -> string 380 380 - val may_delete : t -> bool 384 384 + val text_signature : t -> string option 385 385 + val html_signature : t -> string option 386 386 + val may_delete : t -> bool option 381 387 end 382 388 383 383 - (** Email submission for outgoing mail. *) 389 389 + (** Email submission for outgoing mail. 390 390 + All accessors return option types since responses only include requested properties. *) 384 391 module Submission : sig 385 392 type t 386 393 387 387 - val id : t -> Id.t 388 388 - val identity_id : t -> Id.t 389 389 - val email_id : t -> Id.t 390 390 - val thread_id : t -> Id.t 391 391 - val send_at : t -> Ptime.t 392 392 - val undo_status : t -> Proto.Submission.undo_status 394 394 + val id : t -> Id.t option 395 395 + val identity_id : t -> Id.t option 396 396 + val email_id : t -> Id.t option 397 397 + val thread_id : t -> Id.t option 398 398 + val send_at : t -> Ptime.t option 399 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 394 - val dsn_blob_ids : t -> Id.t list 395 395 - val mdn_blob_ids : t -> Id.t list 401 401 + val dsn_blob_ids : t -> Id.t list option 402 402 + val mdn_blob_ids : t -> Id.t list option 396 403 end 397 404 398 405 (** Vacation auto-response. *)

+7

lib/js/dune

··· 1 1 + (include_subdirs no) 2 2 + 3 3 + (library 4 4 + (name jmap_brr) 5 5 + (public_name jmap-brr) 6 6 + (libraries jmap brr jsont.brr) 7 7 + (modes byte))

+174

lib/js/jmap_brr.ml

··· 1 1 + (*--------------------------------------------------------------------------- 2 2 + Copyright (c) 2025 Anil Madhavapeddy. All rights reserved. 3 3 + SPDX-License-Identifier: ISC 4 4 + ---------------------------------------------------------------------------*) 5 5 + 6 6 + open Brr 7 7 + open Fut.Syntax 8 8 + 9 9 + type connection = { 10 10 + session : Jmap.Proto.Session.t; 11 11 + api_url : Jstr.t; 12 12 + token : Jstr.t; 13 13 + } 14 14 + 15 15 + let session conn = conn.session 16 16 + let api_url conn = conn.api_url 17 17 + 18 18 + (* JSON logging callbacks *) 19 19 + let on_request : (string -> string -> unit) option ref = ref None 20 20 + let on_response : (string -> string -> unit) option ref = ref None 21 21 + 22 22 + let set_request_logger f = on_request := Some f 23 23 + let set_response_logger f = on_response := Some f 24 24 + 25 25 + let log_request label json = 26 26 + match !on_request with 27 27 + | Some f -> f label json 28 28 + | None -> () 29 29 + 30 30 + let log_response label json = 31 31 + match !on_response with 32 32 + | Some f -> f label json 33 33 + | None -> () 34 34 + 35 35 + (* JSON encoding/decoding using jsont.brr *) 36 36 + 37 37 + let encode_request req = 38 38 + Jsont_brr.encode Jmap.Proto.Request.jsont req 39 39 + 40 40 + let encode_response resp = 41 41 + Jsont_brr.encode Jmap.Proto.Response.jsont resp 42 42 + 43 43 + let encode_session session = 44 44 + Jsont_brr.encode Jmap.Proto.Session.jsont session 45 45 + 46 46 + let decode_json s = 47 47 + match Brr.Json.decode s with 48 48 + | Ok jv -> Ok (Obj.magic jv : Jsont.json) (* Jv.t and Jsont.json are compatible *) 49 49 + | Error e -> Error e 50 50 + 51 51 + let encode_json json = 52 52 + Ok (Brr.Json.encode (Obj.magic json : Jv.t)) 53 53 + 54 54 + let pp_json ppf json = 55 55 + match encode_json json with 56 56 + | Ok s -> Format.pp_print_string ppf (Jstr.to_string s) 57 57 + | Error _ -> Format.pp_print_string ppf "<json encoding error>" 58 58 + 59 59 + (* HTTP helpers *) 60 60 + 61 61 + let make_headers token = 62 62 + Brr_io.Fetch.Headers.of_assoc [ 63 63 + Jstr.v "Authorization", Jstr.(v "Bearer " + token); 64 64 + Jstr.v "Content-Type", Jstr.v "application/json"; 65 65 + Jstr.v "Accept", Jstr.v "application/json"; 66 66 + ] 67 67 + 68 68 + let fetch_json ~url ~meth ~headers ?body () = 69 69 + Console.(log [str ">>> Request:"; str (Jstr.to_string meth); str (Jstr.to_string url)]); 70 70 + (match body with 71 71 + | Some b -> Console.(log [str ">>> Body:"; b]) 72 72 + | None -> Console.(log [str ">>> No body"])); 73 73 + let init = Brr_io.Fetch.Request.init 74 74 + ~method':meth 75 75 + ~headers 76 76 + ?body 77 77 + () 78 78 + in 79 79 + let req = Brr_io.Fetch.Request.v ~init url in 80 80 + let* response = Brr_io.Fetch.request req in 81 81 + match response with 82 82 + | Error e -> 83 83 + Console.(error [str "<<< Fetch error:"; e]); 84 84 + Fut.return (Error e) 85 85 + | Ok resp -> 86 86 + let status = Brr_io.Fetch.Response.status resp in 87 87 + Console.(log [str "<<< Response status:"; str (Jstr.of_int status)]); 88 88 + if not (Brr_io.Fetch.Response.ok resp) then begin 89 89 + let msg = Jstr.(v "HTTP error: " + of_int status) in 90 90 + (* Try to get response body for error details *) 91 91 + let body = Brr_io.Fetch.Response.as_body resp in 92 92 + let* text = Brr_io.Fetch.Body.text body in 93 93 + (match text with 94 94 + | Ok t -> Console.(error [str "<<< Error body:"; str (Jstr.to_string t)]) 95 95 + | Error _ -> ()); 96 96 + Fut.return (Error (Jv.Error.v msg)) 97 97 + end else begin 98 98 + let body = Brr_io.Fetch.Response.as_body resp in 99 99 + let* text = Brr_io.Fetch.Body.text body in 100 100 + match text with 101 101 + | Error e -> 102 102 + Console.(error [str "<<< Body read error:"; e]); 103 103 + Fut.return (Error e) 104 104 + | Ok text -> 105 105 + Console.(log [str "<<< Response body:"; str (Jstr.to_string text)]); 106 106 + Fut.return (Ok text) 107 107 + end 108 108 + 109 109 + (* Session establishment *) 110 110 + 111 111 + let get_session ~url ~token = 112 112 + Console.(log [str "get_session: token length ="; str (Jstr.of_int (Jstr.length token))]); 113 113 + log_request "GET Session" (Printf.sprintf "{\"url\": \"%s\"}" (Jstr.to_string url)); 114 114 + let headers = make_headers token in 115 115 + let* result = fetch_json ~url ~meth:(Jstr.v "GET") ~headers () in 116 116 + match result with 117 117 + | Error e -> Fut.return (Error e) 118 118 + | Ok text -> 119 119 + log_response "Session" (Jstr.to_string text); 120 120 + match Jsont_brr.decode Jmap.Proto.Session.jsont text with 121 121 + | Error e -> Fut.return (Error e) 122 122 + | Ok session -> 123 123 + let api_url = Jstr.v (Jmap.Proto.Session.api_url session) in 124 124 + Fut.return (Ok { session; api_url; token }) 125 125 + 126 126 + (* Making requests *) 127 127 + 128 128 + let request conn req = 129 129 + let headers = make_headers conn.token in 130 130 + match Jsont_brr.encode Jmap.Proto.Request.jsont req with 131 131 + | Error e -> Fut.return (Error e) 132 132 + | Ok body_str -> 133 133 + log_request "JMAP Request" (Jstr.to_string body_str); 134 134 + let body = Brr_io.Fetch.Body.of_jstr body_str in 135 135 + let* result = fetch_json 136 136 + ~url:conn.api_url 137 137 + ~meth:(Jstr.v "POST") 138 138 + ~headers 139 139 + ~body 140 140 + () 141 141 + in 142 142 + match result with 143 143 + | Error e -> Fut.return (Error e) 144 144 + | Ok text -> 145 145 + log_response "JMAP Response" (Jstr.to_string text); 146 146 + match Jsont_brr.decode Jmap.Proto.Response.jsont text with 147 147 + | Error e -> Fut.return (Error e) 148 148 + | Ok response -> Fut.return (Ok response) 149 149 + 150 150 + let request_json conn json = 151 151 + let headers = make_headers conn.token in 152 152 + match encode_json json with 153 153 + | Error e -> Fut.return (Error e) 154 154 + | Ok body_str -> 155 155 + let body = Brr_io.Fetch.Body.of_jstr body_str in 156 156 + let* result = fetch_json 157 157 + ~url:conn.api_url 158 158 + ~meth:(Jstr.v "POST") 159 159 + ~headers 160 160 + ~body 161 161 + () 162 162 + in 163 163 + match result with 164 164 + | Error e -> Fut.return (Error e) 165 165 + | Ok text -> 166 166 + match decode_json text with 167 167 + | Error e -> Fut.return (Error e) 168 168 + | Ok json -> Fut.return (Ok json) 169 169 + 170 170 + (* Toplevel support *) 171 171 + 172 172 + let install_printers () = 173 173 + (* In browser context, printers are registered via the OCaml console *) 174 174 + Console.(log [str "JMAP printers installed"])

+107

lib/js/jmap_brr.mli

··· 1 1 + (*--------------------------------------------------------------------------- 2 2 + Copyright (c) 2025 Anil Madhavapeddy. All rights reserved. 3 3 + SPDX-License-Identifier: ISC 4 4 + ---------------------------------------------------------------------------*) 5 5 + 6 6 + (** JMAP client for browsers using Brr. 7 7 + 8 8 + This module provides a JMAP client that runs in web browsers using 9 9 + the Fetch API. It can be used with js_of_ocaml to build browser-based 10 10 + email clients. 11 11 + 12 12 + {2 Example} 13 13 + 14 14 + {[ 15 15 + open Fut.Syntax 16 16 + 17 17 + let main () = 18 18 + let* session = Jmap_brr.get_session 19 19 + ~url:(Jstr.v "https://api.fastmail.com/jmap/session") 20 20 + ~token:(Jstr.v "your-api-token") 21 21 + in 22 22 + match session with 23 23 + | Error e -> Brr.Console.(error [str "Session error:"; e]); Fut.return () 24 24 + | Ok session -> 25 25 + Brr.Console.(log [str "Connected as:"; str (Jmap.Session.username session)]); 26 26 + Fut.return () 27 27 + 28 28 + let () = ignore (main ()) 29 29 + ]} *) 30 30 + 31 31 + (** {1 Connection} *) 32 32 + 33 33 + type connection 34 34 + (** A JMAP connection to a server. *) 35 35 + 36 36 + val session : connection -> Jmap.Proto.Session.t 37 37 + (** [session conn] returns the session information. *) 38 38 + 39 39 + val api_url : connection -> Jstr.t 40 40 + (** [api_url conn] returns the API URL for requests. *) 41 41 + 42 42 + (** {1 Session Establishment} *) 43 43 + 44 44 + val get_session : 45 45 + url:Jstr.t -> 46 46 + token:Jstr.t -> 47 47 + (connection, Jv.Error.t) result Fut.t 48 48 + (** [get_session ~url ~token] establishes a JMAP session. 49 49 + 50 50 + [url] is the session URL (e.g., ["https://api.fastmail.com/jmap/session"]). 51 51 + [token] is the Bearer authentication token. *) 52 52 + 53 53 + (** {1 Making Requests} *) 54 54 + 55 55 + val request : 56 56 + connection -> 57 57 + Jmap.Proto.Request.t -> 58 58 + (Jmap.Proto.Response.t, Jv.Error.t) result Fut.t 59 59 + (** [request conn req] sends a JMAP request and returns the response. *) 60 60 + 61 61 + val request_json : 62 62 + connection -> 63 63 + Jsont.json -> 64 64 + (Jsont.json, Jv.Error.t) result Fut.t 65 65 + (** [request_json conn json] sends a raw JSON request and returns the 66 66 + JSON response. Useful for debugging or custom requests. *) 67 67 + 68 68 + (** {1 JSON Encoding Utilities} 69 69 + 70 70 + These functions help visualize how OCaml types map to JMAP JSON, 71 71 + useful for the tutorial and debugging. *) 72 72 + 73 73 + val encode_request : Jmap.Proto.Request.t -> (Jstr.t, Jv.Error.t) result 74 74 + (** [encode_request req] encodes a request to JSON string. *) 75 75 + 76 76 + val encode_response : Jmap.Proto.Response.t -> (Jstr.t, Jv.Error.t) result 77 77 + (** [encode_response resp] encodes a response to JSON string. *) 78 78 + 79 79 + val encode_session : Jmap.Proto.Session.t -> (Jstr.t, Jv.Error.t) result 80 80 + (** [encode_session session] encodes a session to JSON string. *) 81 81 + 82 82 + val decode_json : Jstr.t -> (Jsont.json, Jv.Error.t) result 83 83 + (** [decode_json s] parses a JSON string to a Jsont.json value. *) 84 84 + 85 85 + val encode_json : Jsont.json -> (Jstr.t, Jv.Error.t) result 86 86 + (** [encode_json json] encodes a Jsont.json value to a string. *) 87 87 + 88 88 + val pp_json : Format.formatter -> Jsont.json -> unit 89 89 + (** [pp_json ppf json] pretty-prints JSON. For toplevel use. *) 90 90 + 91 91 + (** {1 Protocol Logging} *) 92 92 + 93 93 + val set_request_logger : (string -> string -> unit) -> unit 94 94 + (** [set_request_logger f] registers a callback [f label json] that will be 95 95 + called with each outgoing JMAP request. Useful for debugging and 96 96 + educational displays. *) 97 97 + 98 98 + val set_response_logger : (string -> string -> unit) -> unit 99 99 + (** [set_response_logger f] registers a callback [f label json] that will be 100 100 + called with each incoming JMAP response. Useful for debugging and 101 101 + educational displays. *) 102 102 + 103 103 + (** {1 Toplevel Support} *) 104 104 + 105 105 + val install_printers : unit -> unit 106 106 + (** [install_printers ()] installs toplevel pretty printers for JMAP types. 107 107 + This is useful when using the OCaml console in the browser. *)

+311 -66

lib/mail/mail_email.ml

··· 45 45 | `Gray 46 46 ] 47 47 48 48 - (* Flag color bitmask: 49 49 - - 000 = red, 100 = orange, 010 = yellow, 111 = green 50 50 - - 001 = blue, 101 = purple, 011 = gray *) 51 48 let flag_color_to_keywords = function 52 52 - | `Red -> [] (* 000 - no bits set *) 53 53 - | `Orange -> [mail_flag_bit0] (* 100 *) 54 54 - | `Yellow -> [mail_flag_bit1] (* 010 *) 55 55 - | `Green -> [mail_flag_bit0; mail_flag_bit1; mail_flag_bit2] (* 111 *) 56 56 - | `Blue -> [mail_flag_bit2] (* 001 *) 57 57 - | `Purple -> [mail_flag_bit0; mail_flag_bit2] (* 101 *) 58 58 - | `Gray -> [mail_flag_bit1; mail_flag_bit2] (* 011 *) 49 49 + | `Red -> [] 50 50 + | `Orange -> [mail_flag_bit0] 51 51 + | `Yellow -> [mail_flag_bit1] 52 52 + | `Green -> [mail_flag_bit0; mail_flag_bit1; mail_flag_bit2] 53 53 + | `Blue -> [mail_flag_bit2] 54 54 + | `Purple -> [mail_flag_bit0; mail_flag_bit2] 55 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 73 - | (true, true, false) -> None (* Invalid combination *) 70 70 + | (true, true, false) -> None 74 71 end 75 72 73 73 + (* Email property types *) 74 74 + 75 75 + type metadata_property = [ 76 76 + | `Id 77 77 + | `Blob_id 78 78 + | `Thread_id 79 79 + | `Mailbox_ids 80 80 + | `Keywords 81 81 + | `Size 82 82 + | `Received_at 83 83 + ] 84 84 + 85 85 + type header_convenience_property = [ 86 86 + | `Message_id 87 87 + | `In_reply_to 88 88 + | `References 89 89 + | `Sender 90 90 + | `From 91 91 + | `To 92 92 + | `Cc 93 93 + | `Bcc 94 94 + | `Reply_to 95 95 + | `Subject 96 96 + | `Sent_at 97 97 + | `Headers 98 98 + ] 99 99 + 100 100 + type body_property = [ 101 101 + | `Body_structure 102 102 + | `Body_values 103 103 + | `Text_body 104 104 + | `Html_body 105 105 + | `Attachments 106 106 + | `Has_attachment 107 107 + | `Preview 108 108 + ] 109 109 + 110 110 + type standard_property = [ 111 111 + | metadata_property 112 112 + | header_convenience_property 113 113 + | body_property 114 114 + ] 115 115 + 116 116 + type header_property = [ `Header of Mail_header.header_property ] 117 117 + 118 118 + type property = [ standard_property | header_property ] 119 119 + 120 120 + let standard_property_to_string : [< standard_property ] -> string = function 121 121 + | `Id -> "id" 122 122 + | `Blob_id -> "blobId" 123 123 + | `Thread_id -> "threadId" 124 124 + | `Mailbox_ids -> "mailboxIds" 125 125 + | `Keywords -> "keywords" 126 126 + | `Size -> "size" 127 127 + | `Received_at -> "receivedAt" 128 128 + | `Message_id -> "messageId" 129 129 + | `In_reply_to -> "inReplyTo" 130 130 + | `References -> "references" 131 131 + | `Sender -> "sender" 132 132 + | `From -> "from" 133 133 + | `To -> "to" 134 134 + | `Cc -> "cc" 135 135 + | `Bcc -> "bcc" 136 136 + | `Reply_to -> "replyTo" 137 137 + | `Subject -> "subject" 138 138 + | `Sent_at -> "sentAt" 139 139 + | `Headers -> "headers" 140 140 + | `Body_structure -> "bodyStructure" 141 141 + | `Body_values -> "bodyValues" 142 142 + | `Text_body -> "textBody" 143 143 + | `Html_body -> "htmlBody" 144 144 + | `Attachments -> "attachments" 145 145 + | `Has_attachment -> "hasAttachment" 146 146 + | `Preview -> "preview" 147 147 + 148 148 + let property_to_string : [< property ] -> string = function 149 149 + | `Header hp -> Mail_header.header_property_to_string hp 150 150 + | #standard_property as p -> standard_property_to_string p 151 151 + 152 152 + let standard_property_of_string s : standard_property option = 153 153 + match s with 154 154 + | "id" -> Some `Id 155 155 + | "blobId" -> Some `Blob_id 156 156 + | "threadId" -> Some `Thread_id 157 157 + | "mailboxIds" -> Some `Mailbox_ids 158 158 + | "keywords" -> Some `Keywords 159 159 + | "size" -> Some `Size 160 160 + | "receivedAt" -> Some `Received_at 161 161 + | "messageId" -> Some `Message_id 162 162 + | "inReplyTo" -> Some `In_reply_to 163 163 + | "references" -> Some `References 164 164 + | "sender" -> Some `Sender 165 165 + | "from" -> Some `From 166 166 + | "to" -> Some `To 167 167 + | "cc" -> Some `Cc 168 168 + | "bcc" -> Some `Bcc 169 169 + | "replyTo" -> Some `Reply_to 170 170 + | "subject" -> Some `Subject 171 171 + | "sentAt" -> Some `Sent_at 172 172 + | "headers" -> Some `Headers 173 173 + | "bodyStructure" -> Some `Body_structure 174 174 + | "bodyValues" -> Some `Body_values 175 175 + | "textBody" -> Some `Text_body 176 176 + | "htmlBody" -> Some `Html_body 177 177 + | "attachments" -> Some `Attachments 178 178 + | "hasAttachment" -> Some `Has_attachment 179 179 + | "preview" -> Some `Preview 180 180 + | _ -> None 181 181 + 182 182 + let property_of_string s : property option = 183 183 + match standard_property_of_string s with 184 184 + | Some p -> Some (p :> property) 185 185 + | None -> 186 186 + match Mail_header.header_property_of_string s with 187 187 + | Some hp -> Some (`Header hp) 188 188 + | None -> None 189 189 + 190 190 + (* Body part properties *) 191 191 + 192 192 + type body_part_property = [ 193 193 + | `Part_id 194 194 + | `Blob_id 195 195 + | `Size 196 196 + | `Part_headers 197 197 + | `Name 198 198 + | `Type 199 199 + | `Charset 200 200 + | `Disposition 201 201 + | `Cid 202 202 + | `Language 203 203 + | `Location 204 204 + | `Sub_parts 205 205 + ] 206 206 + 207 207 + let body_part_property_to_string : [< body_part_property ] -> string = function 208 208 + | `Part_id -> "partId" 209 209 + | `Blob_id -> "blobId" 210 210 + | `Size -> "size" 211 211 + | `Part_headers -> "headers" 212 212 + | `Name -> "name" 213 213 + | `Type -> "type" 214 214 + | `Charset -> "charset" 215 215 + | `Disposition -> "disposition" 216 216 + | `Cid -> "cid" 217 217 + | `Language -> "language" 218 218 + | `Location -> "location" 219 219 + | `Sub_parts -> "subParts" 220 220 + 221 221 + let body_part_property_of_string s : body_part_property option = 222 222 + match s with 223 223 + | "partId" -> Some `Part_id 224 224 + | "blobId" -> Some `Blob_id 225 225 + | "size" -> Some `Size 226 226 + | "headers" -> Some `Part_headers 227 227 + | "name" -> Some `Name 228 228 + | "type" -> Some `Type 229 229 + | "charset" -> Some `Charset 230 230 + | "disposition" -> Some `Disposition 231 231 + | "cid" -> Some `Cid 232 232 + | "language" -> Some `Language 233 233 + | "location" -> Some `Location 234 234 + | "subParts" -> Some `Sub_parts 235 235 + | _ -> None 236 236 + 237 237 + (* Email type with optional fields *) 238 238 + 76 239 type t = { 77 77 - id : Proto_id.t; 78 78 - blob_id : Proto_id.t; 79 79 - thread_id : Proto_id.t; 80 80 - size : int64; 81 81 - received_at : Ptime.t; 82 82 - mailbox_ids : (Proto_id.t * bool) list; 83 83 - keywords : (string * bool) list; 240 240 + id : Proto_id.t option; 241 241 + blob_id : Proto_id.t option; 242 242 + thread_id : Proto_id.t option; 243 243 + size : int64 option; 244 244 + received_at : Ptime.t option; 245 245 + mailbox_ids : (Proto_id.t * bool) list option; 246 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 101 - has_attachment : bool; 102 102 - preview : string; 264 264 + has_attachment : bool option; 265 265 + preview : string option; 266 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 295 + let dynamic_headers_raw t = t.dynamic_headers 296 296 + 297 297 + (* Parse header property name to determine form and :all flag *) 298 298 + let parse_header_prop name = 299 299 + if not (String.length name > 7 && String.sub name 0 7 = "header:") then 300 300 + None 301 301 + else 302 302 + let rest = String.sub name 7 (String.length name - 7) in 303 303 + let parts = String.split_on_char ':' rest in 304 304 + match parts with 305 305 + | [] -> None 306 306 + | [_name] -> Some (`Raw, false) 307 307 + | [_name; second] -> 308 308 + if second = "all" then Some (`Raw, true) 309 309 + else ( 310 310 + match Mail_header.form_of_string second with 311 311 + | Some form -> Some (form, false) 312 312 + | None -> None 313 313 + ) 314 314 + | [_name; form_str; "all"] -> 315 315 + (match Mail_header.form_of_string form_str with 316 316 + | Some form -> Some (form, true) 317 317 + | None -> None) 318 318 + | _ -> None 319 319 + 320 320 + (* Decode a raw JSON header value into typed header_value *) 321 321 + let decode_header_value prop_name json = 322 322 + match parse_header_prop prop_name with 323 323 + | None -> None 324 324 + | Some (form, all) -> 325 325 + let jsont = Mail_header.header_value_jsont ~form ~all in 326 326 + match Jsont.Json.decode' jsont json with 327 327 + | Ok v -> Some v 328 328 + | Error _ -> None 329 329 + 330 330 + let get_header t key = 331 331 + match List.assoc_opt key t.dynamic_headers with 332 332 + | None -> None 333 333 + | Some json -> decode_header_value key json 334 334 + 335 335 + let get_header_string t key = 336 336 + match get_header t key with 337 337 + | Some (Mail_header.String_single s) -> s 338 338 + | _ -> None 339 339 + 340 340 + let get_header_addresses t key = 341 341 + match get_header t key with 342 342 + | Some (Mail_header.Addresses_single addrs) -> addrs 343 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 135 - attachments has_attachment preview = 348 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 139 - text_body; html_body; attachments; has_attachment; preview } 352 352 + text_body; html_body; attachments; has_attachment; preview; dynamic_headers } 353 353 + 354 354 + (* Helper: null-safe list decoder - treats null as empty list. 355 355 + This allows fields that may be null or array to decode successfully. *) 356 356 + let null_safe_list inner_jsont = 357 357 + Jsont.map 358 358 + ~dec:(function None -> [] | Some l -> l) 359 359 + ~enc:(fun l -> Some l) 360 360 + (Jsont.option (Jsont.list inner_jsont)) 361 361 + 362 362 + module String_map = Map.Make(String) 363 363 + 364 364 + (* Filter unknown members to only keep header:* properties *) 365 365 + let filter_header_props (unknown : Jsont.json String_map.t) : (string * Jsont.json) list = 366 366 + String_map.to_seq unknown 367 367 + |> Seq.filter (fun (k, _) -> String.length k > 7 && String.sub k 0 7 = "header:") 368 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 144 - (* subject can be null per RFC 8621 Section 4.1.1 *) 145 145 - let nullable_string = Jsont.(option string) in 146 146 - Jsont.Object.map ~kind make 147 147 - |> Jsont.Object.mem "id" Proto_id.jsont ~enc:id 148 148 - |> Jsont.Object.mem "blobId" Proto_id.jsont ~enc:blob_id 149 149 - |> Jsont.Object.mem "threadId" Proto_id.jsont ~enc:thread_id 150 150 - |> Jsont.Object.mem "size" Proto_int53.Unsigned.jsont ~enc:size 151 151 - |> Jsont.Object.mem "receivedAt" Proto_date.Utc.jsont ~enc:received_at 152 152 - |> Jsont.Object.mem "mailboxIds" Proto_json_map.id_to_bool ~enc:mailbox_ids 153 153 - |> Jsont.Object.mem "keywords" Proto_json_map.string_to_bool ~dec_absent:[] ~enc:keywords 154 154 - (* Header fields can be absent or null per RFC 8621 *) 155 155 - |> Jsont.Object.mem "messageId" Jsont.(option (list string)) 156 156 - ~dec_absent:None ~enc_omit:Option.is_none ~enc:message_id 157 157 - |> Jsont.Object.mem "inReplyTo" Jsont.(option (list string)) 158 158 - ~dec_absent:None ~enc_omit:Option.is_none ~enc:in_reply_to 159 159 - |> Jsont.Object.mem "references" Jsont.(option (list string)) 160 160 - ~dec_absent:None ~enc_omit:Option.is_none ~enc:references 161 161 - |> Jsont.Object.mem "sender" Jsont.(option (list Mail_address.jsont)) 162 162 - ~dec_absent:None ~enc_omit:Option.is_none ~enc:sender 163 163 - |> Jsont.Object.mem "from" Jsont.(option (list Mail_address.jsont)) 164 164 - ~dec_absent:None ~enc_omit:Option.is_none ~enc:from 165 165 - |> Jsont.Object.mem "to" Jsont.(option (list Mail_address.jsont)) 166 166 - ~dec_absent:None ~enc_omit:Option.is_none ~enc:to_ 167 167 - |> Jsont.Object.mem "cc" Jsont.(option (list Mail_address.jsont)) 168 168 - ~dec_absent:None ~enc_omit:Option.is_none ~enc:cc 169 169 - |> Jsont.Object.mem "bcc" Jsont.(option (list Mail_address.jsont)) 170 170 - ~dec_absent:None ~enc_omit:Option.is_none ~enc:bcc 171 171 - |> Jsont.Object.mem "replyTo" Jsont.(option (list Mail_address.jsont)) 172 172 - ~dec_absent:None ~enc_omit:Option.is_none ~enc:reply_to 173 173 - |> Jsont.Object.mem "subject" nullable_string 174 174 - ~dec_absent:None ~enc_omit:Option.is_none ~enc:subject 373 373 + (* Use null_safe_list for address fields that can be null *) 374 374 + let addr_list = null_safe_list Mail_address.jsont in 375 375 + let str_list = null_safe_list Jsont.string in 376 376 + let part_list = null_safe_list Mail_body.Part.jsont in 377 377 + let hdr_list = null_safe_list Mail_header.jsont in 378 378 + Jsont.Object.map ~kind (fun id blob_id thread_id size received_at mailbox_ids keywords 379 379 + message_id in_reply_to references sender from to_ cc bcc reply_to 380 380 + subject sent_at headers body_structure body_values text_body html_body 381 381 + attachments has_attachment preview unknown -> 382 382 + let dynamic_headers = filter_header_props unknown in 383 383 + make id blob_id thread_id size received_at mailbox_ids keywords 384 384 + message_id in_reply_to references sender from to_ cc bcc reply_to 385 385 + subject sent_at headers body_structure body_values text_body html_body 386 386 + attachments has_attachment preview dynamic_headers) 387 387 + |> Jsont.Object.opt_mem "id" Proto_id.jsont ~enc:id 388 388 + |> Jsont.Object.opt_mem "blobId" Proto_id.jsont ~enc:blob_id 389 389 + |> Jsont.Object.opt_mem "threadId" Proto_id.jsont ~enc:thread_id 390 390 + |> Jsont.Object.opt_mem "size" Proto_int53.Unsigned.jsont ~enc:size 391 391 + |> Jsont.Object.opt_mem "receivedAt" Proto_date.Utc.jsont ~enc:received_at 392 392 + |> Jsont.Object.opt_mem "mailboxIds" Proto_json_map.id_to_bool ~enc:mailbox_ids 393 393 + |> Jsont.Object.opt_mem "keywords" Proto_json_map.string_to_bool ~enc:keywords 394 394 + |> Jsont.Object.opt_mem "messageId" str_list ~enc:message_id 395 395 + |> Jsont.Object.opt_mem "inReplyTo" str_list ~enc:in_reply_to 396 396 + |> Jsont.Object.opt_mem "references" str_list ~enc:references 397 397 + |> Jsont.Object.opt_mem "sender" addr_list ~enc:sender 398 398 + |> Jsont.Object.opt_mem "from" addr_list ~enc:from 399 399 + |> Jsont.Object.opt_mem "to" addr_list ~enc:to_ 400 400 + |> Jsont.Object.opt_mem "cc" addr_list ~enc:cc 401 401 + |> Jsont.Object.opt_mem "bcc" addr_list ~enc:bcc 402 402 + |> Jsont.Object.opt_mem "replyTo" addr_list ~enc:reply_to 403 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 176 - |> Jsont.Object.opt_mem "headers" (Jsont.list Mail_header.jsont) ~enc:headers 405 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 179 - |> Jsont.Object.opt_mem "textBody" (Jsont.list Mail_body.Part.jsont) ~enc:text_body 180 180 - |> Jsont.Object.opt_mem "htmlBody" (Jsont.list Mail_body.Part.jsont) ~enc:html_body 181 181 - |> Jsont.Object.opt_mem "attachments" (Jsont.list Mail_body.Part.jsont) ~enc:attachments 182 182 - |> Jsont.Object.mem "hasAttachment" Jsont.bool ~dec_absent:false ~enc:has_attachment 183 183 - |> Jsont.Object.mem "preview" Jsont.string ~dec_absent:"" ~enc:preview 408 408 + |> Jsont.Object.opt_mem "textBody" part_list ~enc:text_body 409 409 + |> Jsont.Object.opt_mem "htmlBody" part_list ~enc:html_body 410 410 + |> Jsont.Object.opt_mem "attachments" part_list ~enc:attachments 411 411 + |> Jsont.Object.opt_mem "hasAttachment" Jsont.bool ~enc:has_attachment 412 412 + |> Jsont.Object.opt_mem "preview" Jsont.string ~enc:preview 413 413 + |> Jsont.Object.keep_unknown 414 414 + (Jsont.Object.Mems.string_map Jsont.json) 415 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 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 265 - body_properties : string list option; 496 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 272 - let get_args_extra_make body_properties fetch_text_body_values 273 273 - fetch_html_body_values fetch_all_body_values max_body_value_bytes = 503 503 + let get_args_extra ?body_properties ?(fetch_text_body_values=false) 504 504 + ?(fetch_html_body_values=false) ?(fetch_all_body_values=false) 505 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 508 + 509 509 + let body_part_property_list_jsont = 510 510 + Jsont.list (Jsont.map ~kind:"body_part_property" 511 511 + ~dec:(fun s -> match body_part_property_of_string s with 512 512 + | Some p -> p 513 513 + | None -> Jsont.Error.msgf Jsont.Meta.none "Unknown body property: %s" s) 514 514 + ~enc:body_part_property_to_string 515 515 + Jsont.string) 276 516 277 517 let get_args_extra_jsont = 278 518 let kind = "Email/get extra args" in 279 279 - Jsont.Object.map ~kind get_args_extra_make 280 280 - |> Jsont.Object.opt_mem "bodyProperties" (Jsont.list Jsont.string) ~enc:(fun a -> a.body_properties) 519 519 + Jsont.Object.map ~kind (fun body_properties fetch_text_body_values 520 520 + fetch_html_body_values fetch_all_body_values max_body_value_bytes -> 521 521 + { body_properties; fetch_text_body_values; fetch_html_body_values; 522 522 + fetch_all_body_values; max_body_value_bytes }) 523 523 + |> Jsont.Object.opt_mem "bodyProperties" body_part_property_list_jsont 524 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 287 - |> Jsont.Object.opt_mem "maxBodyValueBytes" Proto_int53.Unsigned.jsont ~enc:(fun a -> a.max_body_value_bytes) 531 531 + |> Jsont.Object.opt_mem "maxBodyValueBytes" Proto_int53.Unsigned.jsont 532 532 + ~enc:(fun a -> a.max_body_value_bytes) 288 533 |> Jsont.Object.finish

+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 136 + (** {1 Email Properties} 137 137 + 138 138 + Polymorphic variants for type-safe property selection in Email/get requests. 139 139 + These correspond to the properties defined in RFC 8621 Section 4.1. *) 140 140 + 141 141 + (** Metadata properties (RFC 8621 Section 4.1.1). 142 142 + These represent data about the message in the mail store. *) 143 143 + type metadata_property = [ 144 144 + | `Id 145 145 + | `Blob_id 146 146 + | `Thread_id 147 147 + | `Mailbox_ids 148 148 + | `Keywords 149 149 + | `Size 150 150 + | `Received_at 151 151 + ] 152 152 + 153 153 + (** Convenience header properties (RFC 8621 Section 4.1.3). 154 154 + These are shortcuts for specific header:*:form properties. *) 155 155 + type header_convenience_property = [ 156 156 + | `Message_id (** = header:Message-ID:asMessageIds *) 157 157 + | `In_reply_to (** = header:In-Reply-To:asMessageIds *) 158 158 + | `References (** = header:References:asMessageIds *) 159 159 + | `Sender (** = header:Sender:asAddresses *) 160 160 + | `From (** = header:From:asAddresses *) 161 161 + | `To (** = header:To:asAddresses *) 162 162 + | `Cc (** = header:Cc:asAddresses *) 163 163 + | `Bcc (** = header:Bcc:asAddresses *) 164 164 + | `Reply_to (** = header:Reply-To:asAddresses *) 165 165 + | `Subject (** = header:Subject:asText *) 166 166 + | `Sent_at (** = header:Date:asDate *) 167 167 + | `Headers (** All headers in raw form *) 168 168 + ] 169 169 + 170 170 + (** Body properties (RFC 8621 Section 4.1.4). 171 171 + These represent the message body structure and content. *) 172 172 + type body_property = [ 173 173 + | `Body_structure 174 174 + | `Body_values 175 175 + | `Text_body 176 176 + | `Html_body 177 177 + | `Attachments 178 178 + | `Has_attachment 179 179 + | `Preview 180 180 + ] 181 181 + 182 182 + (** All standard Email properties. *) 183 183 + type standard_property = [ 184 184 + | metadata_property 185 185 + | header_convenience_property 186 186 + | body_property 187 187 + ] 188 188 + 189 189 + (** A dynamic header property request. 190 190 + Use {!Mail_header.header_property} for type-safe construction. *) 191 191 + type header_property = [ `Header of Mail_header.header_property ] 192 192 + 193 193 + (** Any Email property - standard or dynamic header. *) 194 194 + type property = [ standard_property | header_property ] 195 195 + 196 196 + val property_to_string : [< property ] -> string 197 197 + (** Convert a property to its wire name (e.g., [`From] -> "from"). *) 198 198 + 199 199 + val property_of_string : string -> property option 200 200 + (** Parse a property name. Returns [None] for unrecognized properties. 201 201 + Handles both standard properties and header:* properties. *) 202 202 + 203 203 + val standard_property_of_string : string -> standard_property option 204 204 + (** Parse only standard property names (not header:* properties). *) 205 205 + 206 206 + (** {1 Body Part Properties} 207 207 + 208 208 + Properties that can be requested for EmailBodyPart objects 209 209 + via the [bodyProperties] argument. *) 210 210 + 211 211 + type body_part_property = [ 212 212 + | `Part_id 213 213 + | `Blob_id 214 214 + | `Size 215 215 + | `Part_headers (** Named [headers] in the wire format *) 216 216 + | `Name 217 217 + | `Type 218 218 + | `Charset 219 219 + | `Disposition 220 220 + | `Cid 221 221 + | `Language 222 222 + | `Location 223 223 + | `Sub_parts 224 224 + ] 225 225 + 226 226 + val body_part_property_to_string : [< body_part_property ] -> string 227 227 + (** Convert a body part property to its wire name. *) 228 228 + 229 229 + val body_part_property_of_string : string -> body_part_property option 230 230 + (** Parse a body part property name. *) 231 231 + 136 232 (** {1 Email Object} *) 137 233 138 234 type t = { 139 235 (* Metadata - server-set, immutable *) 140 140 - id : Proto_id.t; 141 141 - blob_id : Proto_id.t; 142 142 - thread_id : Proto_id.t; 143 143 - size : int64; 144 144 - received_at : Ptime.t; 236 236 + id : Proto_id.t option; 237 237 + blob_id : Proto_id.t option; 238 238 + thread_id : Proto_id.t option; 239 239 + size : int64 option; 240 240 + received_at : Ptime.t option; 145 241 146 242 (* Metadata - mutable *) 147 147 - mailbox_ids : (Proto_id.t * bool) list; 148 148 - keywords : (string * bool) list; 243 243 + mailbox_ids : (Proto_id.t * bool) list option; 244 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 172 - has_attachment : bool; 173 173 - preview : string; 268 268 + has_attachment : bool option; 269 269 + preview : string option; 270 270 + 271 271 + (* Dynamic header properties - stored as raw JSON for lazy decoding *) 272 272 + dynamic_headers : (string * Jsont.json) list; 273 273 + (** Raw header values from [header:*] property requests. 274 274 + The key is the full property name (e.g., "header:X-Custom:asText"). 275 275 + Use {!decode_header_value} to parse into typed values. *) 174 276 } 175 277 176 176 - val id : t -> Proto_id.t 177 177 - val blob_id : t -> Proto_id.t 178 178 - val thread_id : t -> Proto_id.t 179 179 - val size : t -> int64 180 180 - val received_at : t -> Ptime.t 181 181 - val mailbox_ids : t -> (Proto_id.t * bool) list 182 182 - val keywords : t -> (string * bool) list 278 278 + (** {2 Accessors} 279 279 + 280 280 + All accessors return [option] types since the response only includes 281 281 + properties that were requested. *) 282 282 + 283 283 + val id : t -> Proto_id.t option 284 284 + val blob_id : t -> Proto_id.t option 285 285 + val thread_id : t -> Proto_id.t option 286 286 + val size : t -> int64 option 287 287 + val received_at : t -> Ptime.t option 288 288 + val mailbox_ids : t -> (Proto_id.t * bool) list option 289 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 200 - val has_attachment : t -> bool 201 201 - val preview : t -> string 307 307 + val has_attachment : t -> bool option 308 308 + val preview : t -> string option 309 309 + val dynamic_headers_raw : t -> (string * Jsont.json) list 310 310 + (** Get raw dynamic headers. Use {!decode_header_value} to parse them. *) 311 311 + 312 312 + (** {2 Dynamic Header Decoding} *) 313 313 + 314 314 + val decode_header_value : string -> Jsont.json -> Mail_header.header_value option 315 315 + (** [decode_header_value prop_name json] decodes a raw JSON value into a typed 316 316 + header value based on the property name. The property name determines the form: 317 317 + - [header:Name] or [header:Name:all] -> Raw/Text (String_single/String_all) 318 318 + - [header:Name:asText] -> Text (String_single) 319 319 + - [header:Name:asAddresses] -> Addresses (Addresses_single) 320 320 + - [header:Name:asGroupedAddresses] -> Grouped (Grouped_single) 321 321 + - [header:Name:asMessageIds] -> MessageIds (Strings_single) 322 322 + - [header:Name:asDate] -> Date (Date_single) 323 323 + - [header:Name:asURLs] -> URLs (Strings_single) 324 324 + Returns [None] if the property name is invalid or decoding fails. *) 325 325 + 326 326 + val get_header : t -> string -> Mail_header.header_value option 327 327 + (** [get_header email key] looks up and decodes a dynamic header by its full 328 328 + property name. E.g., [get_header email "header:X-Custom:asText"]. *) 329 329 + 330 330 + val get_header_string : t -> string -> string option 331 331 + (** [get_header_string email key] looks up a string header value. 332 332 + Returns [None] if not found or if the value is not a string type. *) 333 333 + 334 334 + val get_header_addresses : t -> string -> Mail_address.t list option 335 335 + (** [get_header_addresses email key] looks up an addresses header value. 336 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 339 + (** Permissive JSON codec that handles any subset of properties. 340 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 236 - (** Extra arguments for Email/get beyond standard /get. *) 373 373 + (** Extra arguments for Email/get beyond standard /get. 374 374 + 375 375 + Note: The standard [properties] argument from {!Proto_method.get_args} 376 376 + should use {!property} variants converted via {!property_to_string}. *) 237 377 type get_args_extra = { 238 238 - body_properties : string list option; 378 378 + body_properties : body_part_property list option; 379 379 + (** Properties to fetch for each EmailBodyPart. 380 380 + If omitted, defaults to all properties. *) 239 381 fetch_text_body_values : bool; 382 382 + (** If [true], fetch body values for text/* parts in textBody. *) 240 383 fetch_html_body_values : bool; 384 384 + (** If [true], fetch body values for text/* parts in htmlBody. *) 241 385 fetch_all_body_values : bool; 386 386 + (** If [true], fetch body values for all text/* parts. *) 242 387 max_body_value_bytes : int64 option; 388 388 + (** Maximum size of body values to return. Larger values are truncated. *) 243 389 } 390 390 + 391 391 + val get_args_extra : 392 392 + ?body_properties:body_part_property list -> 393 393 + ?fetch_text_body_values:bool -> 394 394 + ?fetch_html_body_values:bool -> 395 395 + ?fetch_all_body_values:bool -> 396 396 + ?max_body_value_bytes:int64 -> 397 397 + unit -> 398 398 + get_args_extra 399 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

··· 22 22 |> Jsont.Object.mem "value" Jsont.string ~enc:value 23 23 |> Jsont.Object.finish 24 24 25 25 - (* Header parsed forms - these are used with header:Name:form properties *) 25 25 + (* Header categories *) 26 26 + 27 27 + type address_header = [ 28 28 + | `From 29 29 + | `Sender 30 30 + | `Reply_to 31 31 + | `To 32 32 + | `Cc 33 33 + | `Bcc 34 34 + | `Resent_from 35 35 + | `Resent_sender 36 36 + | `Resent_reply_to 37 37 + | `Resent_to 38 38 + | `Resent_cc 39 39 + | `Resent_bcc 40 40 + ] 41 41 + 42 42 + type message_id_header = [ 43 43 + | `Message_id 44 44 + | `In_reply_to 45 45 + | `References 46 46 + | `Resent_message_id 47 47 + ] 48 48 + 49 49 + type date_header = [ 50 50 + | `Date 51 51 + | `Resent_date 52 52 + ] 53 53 + 54 54 + type url_header = [ 55 55 + | `List_help 56 56 + | `List_unsubscribe 57 57 + | `List_subscribe 58 58 + | `List_post 59 59 + | `List_owner 60 60 + | `List_archive 61 61 + ] 62 62 + 63 63 + type text_header = [ 64 64 + | `Subject 65 65 + | `Comments 66 66 + | `Keywords 67 67 + | `List_id 68 68 + ] 69 69 + 70 70 + type standard_header = [ 71 71 + | address_header 72 72 + | message_id_header 73 73 + | date_header 74 74 + | url_header 75 75 + | text_header 76 76 + ] 77 77 + 78 78 + type custom_header = [ `Custom of string ] 79 79 + 80 80 + type any_header = [ standard_header | custom_header ] 81 81 + 82 82 + let standard_header_to_string : [< standard_header ] -> string = function 83 83 + | `From -> "From" 84 84 + | `Sender -> "Sender" 85 85 + | `Reply_to -> "Reply-To" 86 86 + | `To -> "To" 87 87 + | `Cc -> "Cc" 88 88 + | `Bcc -> "Bcc" 89 89 + | `Resent_from -> "Resent-From" 90 90 + | `Resent_sender -> "Resent-Sender" 91 91 + | `Resent_reply_to -> "Resent-Reply-To" 92 92 + | `Resent_to -> "Resent-To" 93 93 + | `Resent_cc -> "Resent-Cc" 94 94 + | `Resent_bcc -> "Resent-Bcc" 95 95 + | `Message_id -> "Message-ID" 96 96 + | `In_reply_to -> "In-Reply-To" 97 97 + | `References -> "References" 98 98 + | `Resent_message_id -> "Resent-Message-ID" 99 99 + | `Date -> "Date" 100 100 + | `Resent_date -> "Resent-Date" 101 101 + | `List_help -> "List-Help" 102 102 + | `List_unsubscribe -> "List-Unsubscribe" 103 103 + | `List_subscribe -> "List-Subscribe" 104 104 + | `List_post -> "List-Post" 105 105 + | `List_owner -> "List-Owner" 106 106 + | `List_archive -> "List-Archive" 107 107 + | `Subject -> "Subject" 108 108 + | `Comments -> "Comments" 109 109 + | `Keywords -> "Keywords" 110 110 + | `List_id -> "List-Id" 111 111 + 112 112 + let standard_header_of_string s : standard_header option = 113 113 + match String.lowercase_ascii s with 114 114 + | "from" -> Some `From 115 115 + | "sender" -> Some `Sender 116 116 + | "reply-to" -> Some `Reply_to 117 117 + | "to" -> Some `To 118 118 + | "cc" -> Some `Cc 119 119 + | "bcc" -> Some `Bcc 120 120 + | "resent-from" -> Some `Resent_from 121 121 + | "resent-sender" -> Some `Resent_sender 122 122 + | "resent-reply-to" -> Some `Resent_reply_to 123 123 + | "resent-to" -> Some `Resent_to 124 124 + | "resent-cc" -> Some `Resent_cc 125 125 + | "resent-bcc" -> Some `Resent_bcc 126 126 + | "message-id" -> Some `Message_id 127 127 + | "in-reply-to" -> Some `In_reply_to 128 128 + | "references" -> Some `References 129 129 + | "resent-message-id" -> Some `Resent_message_id 130 130 + | "date" -> Some `Date 131 131 + | "resent-date" -> Some `Resent_date 132 132 + | "list-help" -> Some `List_help 133 133 + | "list-unsubscribe" -> Some `List_unsubscribe 134 134 + | "list-subscribe" -> Some `List_subscribe 135 135 + | "list-post" -> Some `List_post 136 136 + | "list-owner" -> Some `List_owner 137 137 + | "list-archive" -> Some `List_archive 138 138 + | "subject" -> Some `Subject 139 139 + | "comments" -> Some `Comments 140 140 + | "keywords" -> Some `Keywords 141 141 + | "list-id" -> Some `List_id 142 142 + | _ -> None 143 143 + 144 144 + let any_header_to_string : [< any_header ] -> string = function 145 145 + | `Custom s -> s 146 146 + | #standard_header as h -> standard_header_to_string h 147 147 + 148 148 + (* Header parsed forms *) 149 149 + 150 150 + type form = [ 151 151 + | `Raw 152 152 + | `Text 153 153 + | `Addresses 154 154 + | `Grouped_addresses 155 155 + | `Message_ids 156 156 + | `Date 157 157 + | `Urls 158 158 + ] 159 159 + 160 160 + let form_to_string : [< form ] -> string = function 161 161 + | `Raw -> "" 162 162 + | `Text -> "asText" 163 163 + | `Addresses -> "asAddresses" 164 164 + | `Grouped_addresses -> "asGroupedAddresses" 165 165 + | `Message_ids -> "asMessageIds" 166 166 + | `Date -> "asDate" 167 167 + | `Urls -> "asURLs" 168 168 + 169 169 + let form_of_string s : form option = 170 170 + match s with 171 171 + | "" -> Some `Raw 172 172 + | "asText" -> Some `Text 173 173 + | "asAddresses" -> Some `Addresses 174 174 + | "asGroupedAddresses" -> Some `Grouped_addresses 175 175 + | "asMessageIds" -> Some `Message_ids 176 176 + | "asDate" -> Some `Date 177 177 + | "asURLs" -> Some `Urls 178 178 + | _ -> None 179 179 + 180 180 + (* Header property requests *) 181 181 + 182 182 + type header_property = 183 183 + | Raw of { name : string; all : bool } 184 184 + | Text of { header : [ text_header | custom_header ]; all : bool } 185 185 + | Addresses of { header : [ address_header | custom_header ]; all : bool } 186 186 + | Grouped_addresses of { header : [ address_header | custom_header ]; all : bool } 187 187 + | Message_ids of { header : [ message_id_header | custom_header ]; all : bool } 188 188 + | Date of { header : [ date_header | custom_header ]; all : bool } 189 189 + | Urls of { header : [ url_header | custom_header ]; all : bool } 190 190 + 191 191 + let header_name_of_property : header_property -> string = function 192 192 + | Raw { name; _ } -> name 193 193 + | Text { header; _ } -> any_header_to_string (header :> any_header) 194 194 + | Addresses { header; _ } -> any_header_to_string (header :> any_header) 195 195 + | Grouped_addresses { header; _ } -> any_header_to_string (header :> any_header) 196 196 + | Message_ids { header; _ } -> any_header_to_string (header :> any_header) 197 197 + | Date { header; _ } -> any_header_to_string (header :> any_header) 198 198 + | Urls { header; _ } -> any_header_to_string (header :> any_header) 199 199 + 200 200 + let header_property_all : header_property -> bool = function 201 201 + | Raw { all; _ } -> all 202 202 + | Text { all; _ } -> all 203 203 + | Addresses { all; _ } -> all 204 204 + | Grouped_addresses { all; _ } -> all 205 205 + | Message_ids { all; _ } -> all 206 206 + | Date { all; _ } -> all 207 207 + | Urls { all; _ } -> all 208 208 + 209 209 + let header_property_form : header_property -> form = function 210 210 + | Raw _ -> `Raw 211 211 + | Text _ -> `Text 212 212 + | Addresses _ -> `Addresses 213 213 + | Grouped_addresses _ -> `Grouped_addresses 214 214 + | Message_ids _ -> `Message_ids 215 215 + | Date _ -> `Date 216 216 + | Urls _ -> `Urls 217 217 + 218 218 + let header_property_to_string prop = 219 219 + let name = header_name_of_property prop in 220 220 + let form = form_to_string (header_property_form prop) in 221 221 + let all_suffix = if header_property_all prop then ":all" else "" in 222 222 + let form_suffix = if form = "" then "" else ":" ^ form in 223 223 + "header:" ^ name ^ form_suffix ^ all_suffix 224 224 + 225 225 + let header_property_of_string s : header_property option = 226 226 + if not (String.length s > 7 && String.sub s 0 7 = "header:") then 227 227 + None 228 228 + else 229 229 + let rest = String.sub s 7 (String.length s - 7) in 230 230 + (* Parse the parts: name[:form][:all] *) 231 231 + let parts = String.split_on_char ':' rest in 232 232 + match parts with 233 233 + | [] -> None 234 234 + | [name] -> 235 235 + Some (Raw { name; all = false }) 236 236 + | [name; second] -> 237 237 + if second = "all" then 238 238 + Some (Raw { name; all = true }) 239 239 + else begin 240 240 + match form_of_string second with 241 241 + | None -> None 242 242 + | Some `Raw -> Some (Raw { name; all = false }) 243 243 + | Some `Text -> Some (Text { header = `Custom name; all = false }) 244 244 + | Some `Addresses -> Some (Addresses { header = `Custom name; all = false }) 245 245 + | Some `Grouped_addresses -> Some (Grouped_addresses { header = `Custom name; all = false }) 246 246 + | Some `Message_ids -> Some (Message_ids { header = `Custom name; all = false }) 247 247 + | Some `Date -> Some (Date { header = `Custom name; all = false }) 248 248 + | Some `Urls -> Some (Urls { header = `Custom name; all = false }) 249 249 + end 250 250 + | [name; form_str; "all"] -> 251 251 + begin match form_of_string form_str with 252 252 + | None -> None 253 253 + | Some `Raw -> Some (Raw { name; all = true }) 254 254 + | Some `Text -> Some (Text { header = `Custom name; all = true }) 255 255 + | Some `Addresses -> Some (Addresses { header = `Custom name; all = true }) 256 256 + | Some `Grouped_addresses -> Some (Grouped_addresses { header = `Custom name; all = true }) 257 257 + | Some `Message_ids -> Some (Message_ids { header = `Custom name; all = true }) 258 258 + | Some `Date -> Some (Date { header = `Custom name; all = true }) 259 259 + | Some `Urls -> Some (Urls { header = `Custom name; all = true }) 260 260 + end 261 261 + | _ -> None 262 262 + 263 263 + (* Convenience constructors *) 264 264 + 265 265 + let raw ?(all=false) name = Raw { name; all } 266 266 + 267 267 + let text ?(all=false) header = Text { header; all } 268 268 + 269 269 + let addresses ?(all=false) header = Addresses { header; all } 270 270 + 271 271 + let grouped_addresses ?(all=false) header = Grouped_addresses { header; all } 272 272 + 273 273 + let message_ids ?(all=false) header = Message_ids { header; all } 274 274 + 275 275 + let date ?(all=false) header = Date { header; all } 276 276 + 277 277 + let urls ?(all=false) header = Urls { header; all } 278 278 + 279 279 + (* Header values in responses *) 280 280 + 281 281 + type header_value = 282 282 + | String_single of string option 283 283 + | String_all of string list 284 284 + | Addresses_single of Mail_address.t list option 285 285 + | Addresses_all of Mail_address.t list list 286 286 + | Grouped_single of Mail_address.Group.t list option 287 287 + | Grouped_all of Mail_address.Group.t list list 288 288 + | Date_single of Ptime.t option 289 289 + | Date_all of Ptime.t option list 290 290 + | Strings_single of string list option 291 291 + | Strings_all of string list option list 292 292 + 293 293 + let header_value_jsont ~form ~all : header_value Jsont.t = 294 294 + match form, all with 295 295 + | (`Raw | `Text), false -> 296 296 + Jsont.map 297 297 + ~dec:(fun s -> String_single s) 298 298 + ~enc:(function String_single s -> s | _ -> None) 299 299 + (Jsont.option Jsont.string) 300 300 + | (`Raw | `Text), true -> 301 301 + Jsont.map 302 302 + ~dec:(fun l -> String_all l) 303 303 + ~enc:(function String_all l -> l | _ -> []) 304 304 + (Jsont.list Jsont.string) 305 305 + | `Addresses, false -> 306 306 + Jsont.map 307 307 + ~dec:(fun l -> Addresses_single l) 308 308 + ~enc:(function Addresses_single l -> l | _ -> None) 309 309 + (Jsont.option (Jsont.list Mail_address.jsont)) 310 310 + | `Addresses, true -> 311 311 + Jsont.map 312 312 + ~dec:(fun l -> Addresses_all l) 313 313 + ~enc:(function Addresses_all l -> l | _ -> []) 314 314 + (Jsont.list (Jsont.list Mail_address.jsont)) 315 315 + | `Grouped_addresses, false -> 316 316 + Jsont.map 317 317 + ~dec:(fun l -> Grouped_single l) 318 318 + ~enc:(function Grouped_single l -> l | _ -> None) 319 319 + (Jsont.option (Jsont.list Mail_address.Group.jsont)) 320 320 + | `Grouped_addresses, true -> 321 321 + Jsont.map 322 322 + ~dec:(fun l -> Grouped_all l) 323 323 + ~enc:(function Grouped_all l -> l | _ -> []) 324 324 + (Jsont.list (Jsont.list Mail_address.Group.jsont)) 325 325 + | `Message_ids, false -> 326 326 + Jsont.map 327 327 + ~dec:(fun l -> Strings_single l) 328 328 + ~enc:(function Strings_single l -> l | _ -> None) 329 329 + (Jsont.option (Jsont.list Jsont.string)) 330 330 + | `Message_ids, true -> 331 331 + Jsont.map 332 332 + ~dec:(fun l -> Strings_all l) 333 333 + ~enc:(function Strings_all l -> l | _ -> []) 334 334 + (Jsont.list (Jsont.option (Jsont.list Jsont.string))) 335 335 + | `Date, false -> 336 336 + Jsont.map 337 337 + ~dec:(fun t -> Date_single t) 338 338 + ~enc:(function Date_single t -> t | _ -> None) 339 339 + (Jsont.option Proto_date.Rfc3339.jsont) 340 340 + | `Date, true -> 341 341 + Jsont.map 342 342 + ~dec:(fun l -> Date_all l) 343 343 + ~enc:(function Date_all l -> l | _ -> []) 344 344 + (Jsont.list (Jsont.option Proto_date.Rfc3339.jsont)) 345 345 + | `Urls, false -> 346 346 + Jsont.map 347 347 + ~dec:(fun l -> Strings_single l) 348 348 + ~enc:(function Strings_single l -> l | _ -> None) 349 349 + (Jsont.option (Jsont.list Jsont.string)) 350 350 + | `Urls, true -> 351 351 + Jsont.map 352 352 + ~dec:(fun l -> Strings_all l) 353 353 + ~enc:(function Strings_all l -> l | _ -> []) 354 354 + (Jsont.list (Jsont.option (Jsont.list Jsont.string))) 355 355 + 356 356 + (* Low-level JSON codecs *) 26 357 27 358 let raw_jsont = Jsont.string 28 359

+234 -2

lib/mail/mail_header.mli

··· 3 3 SPDX-License-Identifier: ISC 4 4 ---------------------------------------------------------------------------*) 5 5 6 6 - (** Email header types as defined in RFC 8621 Section 4.1.2 6 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 27 + (** {1 Header Categories} 28 28 + 29 29 + RFC 8621 Section 4.1.2 restricts which parsed forms can be used with 30 30 + which headers. These polymorphic variant types encode those restrictions 31 31 + at the type level. 32 32 + 33 33 + Each category corresponds to headers that share the same allowed forms: 34 34 + - Address headers: can use [Addresses] and [Grouped_addresses] forms 35 35 + - Message-ID headers: can use [Message_ids] form 36 36 + - Date headers: can use [Date] form 37 37 + - URL headers: can use [Urls] form 38 38 + - Text headers: can use [Text] form 39 39 + - All headers can use [Raw] form 40 40 + - Custom headers (not in RFC 5322/2369) can use any form *) 41 41 + 42 42 + (** Headers that allow the [Addresses] and [Grouped_addresses] forms. 43 43 + These are address-list headers per RFC 5322. *) 44 44 + type address_header = [ 45 45 + | `From 46 46 + | `Sender 47 47 + | `Reply_to 48 48 + | `To 49 49 + | `Cc 50 50 + | `Bcc 51 51 + | `Resent_from 52 52 + | `Resent_sender 53 53 + | `Resent_reply_to 54 54 + | `Resent_to 55 55 + | `Resent_cc 56 56 + | `Resent_bcc 57 57 + ] 58 58 + 59 59 + (** Headers that allow the [Message_ids] form. 60 60 + These contain msg-id values per RFC 5322. *) 61 61 + type message_id_header = [ 62 62 + | `Message_id 63 63 + | `In_reply_to 64 64 + | `References 65 65 + | `Resent_message_id 66 66 + ] 67 67 + 68 68 + (** Headers that allow the [Date] form. 69 69 + These contain date-time values per RFC 5322. *) 70 70 + type date_header = [ 71 71 + | `Date 72 72 + | `Resent_date 73 73 + ] 74 74 + 75 75 + (** Headers that allow the [Urls] form. 76 76 + These are list-* headers per RFC 2369. *) 77 77 + type url_header = [ 78 78 + | `List_help 79 79 + | `List_unsubscribe 80 80 + | `List_subscribe 81 81 + | `List_post 82 82 + | `List_owner 83 83 + | `List_archive 84 84 + ] 85 85 + 86 86 + (** Headers that allow the [Text] form. 87 87 + These contain unstructured or phrase content. *) 88 88 + type text_header = [ 89 89 + | `Subject 90 90 + | `Comments 91 91 + | `Keywords 92 92 + | `List_id 93 93 + ] 94 94 + 95 95 + (** All standard headers defined in RFC 5322 and RFC 2369. *) 96 96 + type standard_header = [ 97 97 + | address_header 98 98 + | message_id_header 99 99 + | date_header 100 100 + | url_header 101 101 + | text_header 102 102 + ] 103 103 + 104 104 + (** A custom header not defined in RFC 5322 or RFC 2369. 105 105 + Custom headers can use any parsed form. *) 106 106 + type custom_header = [ `Custom of string ] 107 107 + 108 108 + (** Any header - standard or custom. *) 109 109 + type any_header = [ standard_header | custom_header ] 110 110 + 111 111 + (** {2 Header Name Conversion} *) 112 112 + 113 113 + val standard_header_to_string : [< standard_header ] -> string 114 114 + (** Convert a standard header variant to its wire name (e.g., [`From] -> "From"). *) 115 115 + 116 116 + val standard_header_of_string : string -> standard_header option 117 117 + (** Parse a header name to a standard header variant, case-insensitive. 118 118 + Returns [None] for non-standard headers. *) 119 119 + 120 120 + val any_header_to_string : [< any_header ] -> string 121 121 + (** Convert any header variant to its wire name. *) 122 122 + 27 123 (** {1 Header Parsed Forms} 28 124 29 125 RFC 8621 defines several parsed forms for headers. 30 30 - These can be requested via the header:Name:form properties. *) 126 126 + These can be requested via the [header:Name:form] properties. *) 127 127 + 128 128 + (** The parsed form to request for a header value. *) 129 129 + type form = [ 130 130 + | `Raw (** Raw octets, available for all headers *) 131 131 + | `Text (** Decoded text, for text headers or custom *) 132 132 + | `Addresses (** Flat address list, for address headers or custom *) 133 133 + | `Grouped_addresses (** Address list with groups, for address headers or custom *) 134 134 + | `Message_ids (** List of message-id strings, for message-id headers or custom *) 135 135 + | `Date (** Parsed date, for date headers or custom *) 136 136 + | `Urls (** List of URLs, for url headers or custom *) 137 137 + ] 138 138 + 139 139 + val form_to_string : [< form ] -> string 140 140 + (** Convert form to wire suffix (e.g., [`Addresses] -> "asAddresses"). 141 141 + [`Raw] returns the empty string (raw is the default). *) 142 142 + 143 143 + val form_of_string : string -> form option 144 144 + (** Parse a form suffix (e.g., "asAddresses" -> [`Addresses]). 145 145 + Empty string returns [`Raw]. *) 146 146 + 147 147 + (** {1 Header Property Requests} 148 148 + 149 149 + Type-safe construction of [header:Name:form:all] property strings. 150 150 + The GADT ensures that only valid form/header combinations are allowed. *) 151 151 + 152 152 + (** A header property request with type-safe form selection. 153 153 + 154 154 + The type parameter encodes what forms are allowed: 155 155 + - Address headers allow [Addresses] and [Grouped_addresses] 156 156 + - Message-ID headers allow [Message_ids] 157 157 + - Date headers allow [Date] 158 158 + - URL headers allow [Urls] 159 159 + - Text headers allow [Text] 160 160 + - All headers allow [Raw] 161 161 + - Custom headers allow any form *) 162 162 + type header_property = 163 163 + | Raw of { name : string; all : bool } 164 164 + (** Raw form, available for any header. *) 165 165 + 166 166 + | Text of { header : [ text_header | custom_header ]; all : bool } 167 167 + (** Text form, for text headers or custom. *) 168 168 + 169 169 + | Addresses of { header : [ address_header | custom_header ]; all : bool } 170 170 + (** Addresses form, for address headers or custom. *) 171 171 + 172 172 + | Grouped_addresses of { header : [ address_header | custom_header ]; all : bool } 173 173 + (** GroupedAddresses form, for address headers or custom. *) 174 174 + 175 175 + | Message_ids of { header : [ message_id_header | custom_header ]; all : bool } 176 176 + (** MessageIds form, for message-id headers or custom. *) 177 177 + 178 178 + | Date of { header : [ date_header | custom_header ]; all : bool } 179 179 + (** Date form, for date headers or custom. *) 180 180 + 181 181 + | Urls of { header : [ url_header | custom_header ]; all : bool } 182 182 + (** URLs form, for URL headers or custom. *) 183 183 + 184 184 + val header_property_to_string : header_property -> string 185 185 + (** Convert a header property request to wire format. 186 186 + E.g., [Addresses { header = `From; all = true }] -> "header:From:asAddresses:all" *) 187 187 + 188 188 + val header_property_of_string : string -> header_property option 189 189 + (** Parse a header property string. 190 190 + Returns [None] if the string doesn't match [header:*] format. *) 191 191 + 192 192 + (** {2 Convenience Constructors} *) 193 193 + 194 194 + val raw : ?all:bool -> string -> header_property 195 195 + (** [raw ?all name] creates a raw header property request. *) 196 196 + 197 197 + val text : ?all:bool -> [ text_header | custom_header ] -> header_property 198 198 + (** [text ?all header] creates a text header property request. *) 199 199 + 200 200 + val addresses : ?all:bool -> [ address_header | custom_header ] -> header_property 201 201 + (** [addresses ?all header] creates an addresses header property request. *) 202 202 + 203 203 + val grouped_addresses : ?all:bool -> [ address_header | custom_header ] -> header_property 204 204 + (** [grouped_addresses ?all header] creates a grouped addresses header property request. *) 205 205 + 206 206 + val message_ids : ?all:bool -> [ message_id_header | custom_header ] -> header_property 207 207 + (** [message_ids ?all header] creates a message-ids header property request. *) 208 208 + 209 209 + val date : ?all:bool -> [ date_header | custom_header ] -> header_property 210 210 + (** [date ?all header] creates a date header property request. *) 211 211 + 212 212 + val urls : ?all:bool -> [ url_header | custom_header ] -> header_property 213 213 + (** [urls ?all header] creates a URLs header property request. *) 214 214 + 215 215 + (** {1 Header Values in Responses} 216 216 + 217 217 + When fetching dynamic headers, the response value type depends on the 218 218 + requested form. This type captures all possible response shapes. *) 219 219 + 220 220 + (** A header value from the response. 221 221 + 222 222 + The variant encodes both the form and whether [:all] was requested: 223 223 + - [*_single] variants: value of the last header instance, or [None] if absent 224 224 + - [*_all] variants: list of values for all instances, empty if absent *) 225 225 + type header_value = 226 226 + | String_single of string option 227 227 + (** Raw or Text form, single instance. *) 228 228 + 229 229 + | String_all of string list 230 230 + (** Raw or Text form, all instances. *) 231 231 + 232 232 + | Addresses_single of Mail_address.t list option 233 233 + (** Addresses form, single instance. *) 234 234 + 235 235 + | Addresses_all of Mail_address.t list list 236 236 + (** Addresses form, all instances. *) 237 237 + 238 238 + | Grouped_single of Mail_address.Group.t list option 239 239 + (** GroupedAddresses form, single instance. *) 240 240 + 241 241 + | Grouped_all of Mail_address.Group.t list list 242 242 + (** GroupedAddresses form, all instances. *) 243 243 + 244 244 + | Date_single of Ptime.t option 245 245 + (** Date form, single instance. *) 246 246 + 247 247 + | Date_all of Ptime.t option list 248 248 + (** Date form, all instances. *) 249 249 + 250 250 + | Strings_single of string list option 251 251 + (** MessageIds or URLs form, single instance. *) 252 252 + 253 253 + | Strings_all of string list option list 254 254 + (** MessageIds or URLs form, all instances. *) 255 255 + 256 256 + val header_value_jsont : form:form -> all:bool -> header_value Jsont.t 257 257 + (** [header_value_jsont ~form ~all] returns a JSON codec for header values 258 258 + with the given form and multiplicity. *) 259 259 + 260 260 + (** {1 Low-level JSON Codecs} 261 261 + 262 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

··· 3 3 SPDX-License-Identifier: ISC 4 4 ---------------------------------------------------------------------------*) 5 5 6 6 + (* Identity properties *) 7 7 + 8 8 + type property = [ 9 9 + | `Id 10 10 + | `Name 11 11 + | `Email 12 12 + | `Reply_to 13 13 + | `Bcc 14 14 + | `Text_signature 15 15 + | `Html_signature 16 16 + | `May_delete 17 17 + ] 18 18 + 19 19 + let property_to_string : [< property ] -> string = function 20 20 + | `Id -> "id" 21 21 + | `Name -> "name" 22 22 + | `Email -> "email" 23 23 + | `Reply_to -> "replyTo" 24 24 + | `Bcc -> "bcc" 25 25 + | `Text_signature -> "textSignature" 26 26 + | `Html_signature -> "htmlSignature" 27 27 + | `May_delete -> "mayDelete" 28 28 + 29 29 + let property_of_string s : property option = 30 30 + match s with 31 31 + | "id" -> Some `Id 32 32 + | "name" -> Some `Name 33 33 + | "email" -> Some `Email 34 34 + | "replyTo" -> Some `Reply_to 35 35 + | "bcc" -> Some `Bcc 36 36 + | "textSignature" -> Some `Text_signature 37 37 + | "htmlSignature" -> Some `Html_signature 38 38 + | "mayDelete" -> Some `May_delete 39 39 + | _ -> None 40 40 + 41 41 + (* Identity type *) 42 42 + 6 43 type t = { 7 7 - id : Proto_id.t; 8 8 - name : string; 9 9 - email : string; 44 44 + id : Proto_id.t option; 45 45 + name : string option; 46 46 + email : string option; 10 47 reply_to : Mail_address.t list option; 11 48 bcc : Mail_address.t list option; 12 12 - text_signature : string; 13 13 - html_signature : string; 14 14 - may_delete : bool; 49 49 + text_signature : string option; 50 50 + html_signature : string option; 51 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 32 - |> Jsont.Object.mem "id" Proto_id.jsont ~enc:id 33 33 - |> Jsont.Object.mem "name" Jsont.string ~dec_absent:"" ~enc:name 34 34 - |> Jsont.Object.mem "email" Jsont.string ~enc:email 69 69 + |> Jsont.Object.opt_mem "id" Proto_id.jsont ~enc:id 70 70 + |> Jsont.Object.opt_mem "name" Jsont.string ~enc:name 71 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 37 - |> Jsont.Object.mem "textSignature" Jsont.string ~dec_absent:"" ~enc:text_signature 38 38 - |> Jsont.Object.mem "htmlSignature" Jsont.string ~dec_absent:"" ~enc:html_signature 39 39 - |> Jsont.Object.mem "mayDelete" Jsont.bool ~enc:may_delete 74 74 + |> Jsont.Object.opt_mem "textSignature" Jsont.string ~enc:text_signature 75 75 + |> Jsont.Object.opt_mem "htmlSignature" Jsont.string ~enc:html_signature 76 76 + |> Jsont.Object.opt_mem "mayDelete" Jsont.bool ~enc:may_delete 40 77 |> Jsont.Object.finish

+38 -13

lib/mail/mail_identity.mli

··· 3 3 SPDX-License-Identifier: ISC 4 4 ---------------------------------------------------------------------------*) 5 5 6 6 - (** Identity type as defined in RFC 8621 Section 6 6 6 + (** Identity type as defined in RFC 8621 Section 6 7 7 8 8 @canonical Jmap.Proto.Identity *) 9 9 10 10 + (** {1 Identity Properties} 11 11 + 12 12 + Polymorphic variants for type-safe property selection in Identity/get requests. 13 13 + These correspond to the properties defined in RFC 8621 Section 6. *) 14 14 + 15 15 + (** All Identity properties that can be requested. *) 16 16 + type property = [ 17 17 + | `Id 18 18 + | `Name 19 19 + | `Email 20 20 + | `Reply_to 21 21 + | `Bcc 22 22 + | `Text_signature 23 23 + | `Html_signature 24 24 + | `May_delete 25 25 + ] 26 26 + 27 27 + val property_to_string : [< property ] -> string 28 28 + (** Convert a property to its wire name (e.g., [`Text_signature] -> "textSignature"). *) 29 29 + 30 30 + val property_of_string : string -> property option 31 31 + (** Parse a property name, case-sensitive. *) 32 32 + 33 33 + (** {1 Identity Object} *) 34 34 + 10 35 type t = { 11 11 - id : Proto_id.t; 36 36 + id : Proto_id.t option; 12 37 (** Server-assigned identity id. *) 13 13 - name : string; 38 38 + name : string option; 14 39 (** Display name for sent emails. *) 15 15 - email : string; 40 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 21 - text_signature : string; 46 46 + text_signature : string option; 22 47 (** Plain text signature. *) 23 23 - html_signature : string; 48 48 + html_signature : string option; 24 49 (** HTML signature. *) 25 25 - may_delete : bool; 50 50 + may_delete : bool option; 26 51 (** Whether the user may delete this identity. *) 27 52 } 28 53 29 29 - val id : t -> Proto_id.t 30 30 - val name : t -> string 31 31 - val email : t -> string 54 54 + val id : t -> Proto_id.t option 55 55 + val name : t -> string option 56 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 34 - val text_signature : t -> string 35 35 - val html_signature : t -> string 36 36 - val may_delete : t -> bool 59 59 + val text_signature : t -> string option 60 60 + val html_signature : t -> string option 61 61 + val may_delete : t -> bool option 37 62 38 63 val jsont : t Jsont.t

+66 -25

lib/mail/mail_mailbox.ml

··· 3 3 SPDX-License-Identifier: ISC 4 4 ---------------------------------------------------------------------------*) 5 5 6 6 + (* Mailbox properties *) 7 7 + 8 8 + type property = [ 9 9 + | `Id 10 10 + | `Name 11 11 + | `Parent_id 12 12 + | `Role 13 13 + | `Sort_order 14 14 + | `Total_emails 15 15 + | `Unread_emails 16 16 + | `Total_threads 17 17 + | `Unread_threads 18 18 + | `My_rights 19 19 + | `Is_subscribed 20 20 + ] 21 21 + 22 22 + let property_to_string : [< property ] -> string = function 23 23 + | `Id -> "id" 24 24 + | `Name -> "name" 25 25 + | `Parent_id -> "parentId" 26 26 + | `Role -> "role" 27 27 + | `Sort_order -> "sortOrder" 28 28 + | `Total_emails -> "totalEmails" 29 29 + | `Unread_emails -> "unreadEmails" 30 30 + | `Total_threads -> "totalThreads" 31 31 + | `Unread_threads -> "unreadThreads" 32 32 + | `My_rights -> "myRights" 33 33 + | `Is_subscribed -> "isSubscribed" 34 34 + 35 35 + let property_of_string s : property option = 36 36 + match s with 37 37 + | "id" -> Some `Id 38 38 + | "name" -> Some `Name 39 39 + | "parentId" -> Some `Parent_id 40 40 + | "role" -> Some `Role 41 41 + | "sortOrder" -> Some `Sort_order 42 42 + | "totalEmails" -> Some `Total_emails 43 43 + | "unreadEmails" -> Some `Unread_emails 44 44 + | "totalThreads" -> Some `Total_threads 45 45 + | "unreadThreads" -> Some `Unread_threads 46 46 + | "myRights" -> Some `My_rights 47 47 + | "isSubscribed" -> Some `Is_subscribed 48 48 + | _ -> None 49 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 105 - id : Proto_id.t; 106 106 - name : string; 149 149 + id : Proto_id.t option; 150 150 + name : string option; 107 151 parent_id : Proto_id.t option; 108 152 role : role option; 109 109 - sort_order : int64; 110 110 - total_emails : int64; 111 111 - unread_emails : int64; 112 112 - total_threads : int64; 113 113 - unread_threads : int64; 114 114 - my_rights : Rights.t; 115 115 - is_subscribed : bool; 153 153 + sort_order : int64 option; 154 154 + total_emails : int64 option; 155 155 + unread_emails : int64 option; 156 156 + total_threads : int64 option; 157 157 + unread_threads : int64 option; 158 158 + my_rights : Rights.t option; 159 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 137 - (* parentId and role can be null - RFC 8621 Section 2 *) 138 138 - let nullable_id = Jsont.(option Proto_id.jsont) in 139 139 - let nullable_role = Jsont.(option role_jsont) in 140 181 Jsont.Object.map ~kind make 141 141 - |> Jsont.Object.mem "id" Proto_id.jsont ~enc:id 142 142 - |> Jsont.Object.mem "name" Jsont.string ~enc:name 143 143 - |> Jsont.Object.mem "parentId" nullable_id 144 144 - ~dec_absent:None ~enc_omit:Option.is_none ~enc:parent_id 145 145 - |> Jsont.Object.mem "role" nullable_role 146 146 - ~dec_absent:None ~enc_omit:Option.is_none ~enc:role 147 147 - |> Jsont.Object.mem "sortOrder" Proto_int53.Unsigned.jsont ~dec_absent:0L ~enc:sort_order 148 148 - |> Jsont.Object.mem "totalEmails" Proto_int53.Unsigned.jsont ~enc:total_emails 149 149 - |> Jsont.Object.mem "unreadEmails" Proto_int53.Unsigned.jsont ~enc:unread_emails 150 150 - |> Jsont.Object.mem "totalThreads" Proto_int53.Unsigned.jsont ~enc:total_threads 151 151 - |> Jsont.Object.mem "unreadThreads" Proto_int53.Unsigned.jsont ~enc:unread_threads 152 152 - |> Jsont.Object.mem "myRights" Rights.jsont ~enc:my_rights 153 153 - |> Jsont.Object.mem "isSubscribed" Jsont.bool ~enc:is_subscribed 182 182 + |> Jsont.Object.opt_mem "id" Proto_id.jsont ~enc:id 183 183 + |> Jsont.Object.opt_mem "name" Jsont.string ~enc:name 184 184 + (* parentId can be null meaning top-level, or absent if not requested *) 185 185 + |> Jsont.Object.opt_mem "parentId" Proto_id.jsont ~enc:parent_id 186 186 + (* role can be null meaning no role, or absent if not requested *) 187 187 + |> Jsont.Object.opt_mem "role" role_jsont ~enc:role 188 188 + |> Jsont.Object.opt_mem "sortOrder" Proto_int53.Unsigned.jsont ~enc:sort_order 189 189 + |> Jsont.Object.opt_mem "totalEmails" Proto_int53.Unsigned.jsont ~enc:total_emails 190 190 + |> Jsont.Object.opt_mem "unreadEmails" Proto_int53.Unsigned.jsont ~enc:unread_emails 191 191 + |> Jsont.Object.opt_mem "totalThreads" Proto_int53.Unsigned.jsont ~enc:total_threads 192 192 + |> Jsont.Object.opt_mem "unreadThreads" Proto_int53.Unsigned.jsont ~enc:unread_threads 193 193 + |> Jsont.Object.opt_mem "myRights" Rights.jsont ~enc:my_rights 194 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

··· 3 3 SPDX-License-Identifier: ISC 4 4 ---------------------------------------------------------------------------*) 5 5 6 6 - (** Mailbox type as defined in RFC 8621 Section 2 6 6 + (** Mailbox type as defined in RFC 8621 Section 2 7 7 8 8 @canonical Jmap.Proto.Mailbox *) 9 9 + 10 10 + (** {1 Mailbox Properties} 11 11 + 12 12 + Polymorphic variants for type-safe property selection in Mailbox/get requests. 13 13 + These correspond to the properties defined in RFC 8621 Section 2. *) 14 14 + 15 15 + (** All Mailbox properties that can be requested. *) 16 16 + type property = [ 17 17 + | `Id 18 18 + | `Name 19 19 + | `Parent_id 20 20 + | `Role 21 21 + | `Sort_order 22 22 + | `Total_emails 23 23 + | `Unread_emails 24 24 + | `Total_threads 25 25 + | `Unread_threads 26 26 + | `My_rights 27 27 + | `Is_subscribed 28 28 + ] 29 29 + 30 30 + val property_to_string : [< property ] -> string 31 31 + (** Convert a property to its wire name (e.g., [`Parent_id] -> "parentId"). *) 32 32 + 33 33 + val property_of_string : string -> property option 34 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 66 - id : Proto_id.t; 92 92 + id : Proto_id.t option; 67 93 (** Server-assigned mailbox id. *) 68 68 - name : string; 94 94 + name : string option; 69 95 (** User-visible name (UTF-8). *) 70 96 parent_id : Proto_id.t option; 71 71 - (** Id of parent mailbox, or [None] for root. *) 97 97 + (** Id of parent mailbox, or [None] for root. Note: [None] can mean 98 98 + either "not requested" or "top-level mailbox". *) 72 99 role : role option; 73 73 - (** Standard role, if any. *) 74 74 - sort_order : int64; 100 100 + (** Standard role, if any. Note: [None] can mean either "not requested" 101 101 + or "no role assigned". *) 102 102 + sort_order : int64 option; 75 103 (** Sort order hint (lower = displayed first). *) 76 76 - total_emails : int64; 104 104 + total_emails : int64 option; 77 105 (** Total number of emails in mailbox. *) 78 78 - unread_emails : int64; 106 106 + unread_emails : int64 option; 79 107 (** Number of unread emails. *) 80 80 - total_threads : int64; 108 108 + total_threads : int64 option; 81 109 (** Total number of threads. *) 82 82 - unread_threads : int64; 110 110 + unread_threads : int64 option; 83 111 (** Number of threads with unread emails. *) 84 84 - my_rights : Rights.t; 112 112 + my_rights : Rights.t option; 85 113 (** User's rights on this mailbox. *) 86 86 - is_subscribed : bool; 114 114 + is_subscribed : bool option; 87 115 (** Whether user is subscribed to this mailbox. *) 88 116 } 89 117 90 90 - val id : t -> Proto_id.t 91 91 - val name : t -> string 118 118 + val id : t -> Proto_id.t option 119 119 + val name : t -> string option 92 120 val parent_id : t -> Proto_id.t option 93 121 val role : t -> role option 94 94 - val sort_order : t -> int64 95 95 - val total_emails : t -> int64 96 96 - val unread_emails : t -> int64 97 97 - val total_threads : t -> int64 98 98 - val unread_threads : t -> int64 99 99 - val my_rights : t -> Rights.t 100 100 - val is_subscribed : t -> bool 122 122 + val sort_order : t -> int64 option 123 123 + val total_emails : t -> int64 option 124 124 + val unread_emails : t -> int64 option 125 125 + val total_threads : t -> int64 option 126 126 + val unread_threads : t -> int64 option 127 127 + val my_rights : t -> Rights.t option 128 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

··· 3 3 SPDX-License-Identifier: ISC 4 4 ---------------------------------------------------------------------------*) 5 5 6 6 + (* EmailSubmission properties *) 7 7 + 8 8 + type property = [ 9 9 + | `Id 10 10 + | `Identity_id 11 11 + | `Email_id 12 12 + | `Thread_id 13 13 + | `Envelope 14 14 + | `Send_at 15 15 + | `Undo_status 16 16 + | `Delivery_status 17 17 + | `Dsn_blob_ids 18 18 + | `Mdn_blob_ids 19 19 + ] 20 20 + 21 21 + let property_to_string : [< property ] -> string = function 22 22 + | `Id -> "id" 23 23 + | `Identity_id -> "identityId" 24 24 + | `Email_id -> "emailId" 25 25 + | `Thread_id -> "threadId" 26 26 + | `Envelope -> "envelope" 27 27 + | `Send_at -> "sendAt" 28 28 + | `Undo_status -> "undoStatus" 29 29 + | `Delivery_status -> "deliveryStatus" 30 30 + | `Dsn_blob_ids -> "dsnBlobIds" 31 31 + | `Mdn_blob_ids -> "mdnBlobIds" 32 32 + 33 33 + let property_of_string s : property option = 34 34 + match s with 35 35 + | "id" -> Some `Id 36 36 + | "identityId" -> Some `Identity_id 37 37 + | "emailId" -> Some `Email_id 38 38 + | "threadId" -> Some `Thread_id 39 39 + | "envelope" -> Some `Envelope 40 40 + | "sendAt" -> Some `Send_at 41 41 + | "undoStatus" -> Some `Undo_status 42 42 + | "deliveryStatus" -> Some `Delivery_status 43 43 + | "dsnBlobIds" -> Some `Dsn_blob_ids 44 44 + | "mdnBlobIds" -> Some `Mdn_blob_ids 45 45 + | _ -> None 46 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 117 - id : Proto_id.t; 118 118 - identity_id : Proto_id.t; 119 119 - email_id : Proto_id.t; 120 120 - thread_id : Proto_id.t; 158 158 + id : Proto_id.t option; 159 159 + identity_id : Proto_id.t option; 160 160 + email_id : Proto_id.t option; 161 161 + thread_id : Proto_id.t option; 121 162 envelope : Envelope.t option; 122 122 - send_at : Ptime.t; 123 123 - undo_status : undo_status; 163 163 + send_at : Ptime.t option; 164 164 + undo_status : undo_status option; 124 165 delivery_status : (string * Delivery_status.t) list option; 125 125 - dsn_blob_ids : Proto_id.t list; 126 126 - mdn_blob_ids : Proto_id.t list; 166 166 + dsn_blob_ids : Proto_id.t list option; 167 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 148 - |> Jsont.Object.mem "id" Proto_id.jsont ~enc:id 149 149 - |> Jsont.Object.mem "identityId" Proto_id.jsont ~enc:identity_id 150 150 - |> Jsont.Object.mem "emailId" Proto_id.jsont ~enc:email_id 151 151 - |> Jsont.Object.mem "threadId" Proto_id.jsont ~enc:thread_id 189 189 + |> Jsont.Object.opt_mem "id" Proto_id.jsont ~enc:id 190 190 + |> Jsont.Object.opt_mem "identityId" Proto_id.jsont ~enc:identity_id 191 191 + |> Jsont.Object.opt_mem "emailId" Proto_id.jsont ~enc:email_id 192 192 + |> Jsont.Object.opt_mem "threadId" Proto_id.jsont ~enc:thread_id 152 193 |> Jsont.Object.opt_mem "envelope" Envelope.jsont ~enc:envelope 153 153 - |> Jsont.Object.mem "sendAt" Proto_date.Utc.jsont ~enc:send_at 154 154 - |> Jsont.Object.mem "undoStatus" undo_status_jsont ~enc:undo_status 194 194 + |> Jsont.Object.opt_mem "sendAt" Proto_date.Utc.jsont ~enc:send_at 195 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 156 - |> Jsont.Object.mem "dsnBlobIds" (Jsont.list Proto_id.jsont) ~dec_absent:[] ~enc:dsn_blob_ids 157 157 - |> Jsont.Object.mem "mdnBlobIds" (Jsont.list Proto_id.jsont) ~dec_absent:[] ~enc:mdn_blob_ids 197 197 + |> Jsont.Object.opt_mem "dsnBlobIds" (Jsont.list Proto_id.jsont) ~enc:dsn_blob_ids 198 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

··· 3 3 SPDX-License-Identifier: ISC 4 4 ---------------------------------------------------------------------------*) 5 5 6 6 - (** EmailSubmission type as defined in RFC 8621 Section 7 6 6 + (** EmailSubmission type as defined in RFC 8621 Section 7 7 7 8 8 @canonical Jmap.Proto.Submission *) 9 9 + 10 10 + (** {1 EmailSubmission Properties} 11 11 + 12 12 + Polymorphic variants for type-safe property selection in EmailSubmission/get requests. 13 13 + These correspond to the properties defined in RFC 8621 Section 7. *) 14 14 + 15 15 + (** All EmailSubmission properties that can be requested. *) 16 16 + type property = [ 17 17 + | `Id 18 18 + | `Identity_id 19 19 + | `Email_id 20 20 + | `Thread_id 21 21 + | `Envelope 22 22 + | `Send_at 23 23 + | `Undo_status 24 24 + | `Delivery_status 25 25 + | `Dsn_blob_ids 26 26 + | `Mdn_blob_ids 27 27 + ] 28 28 + 29 29 + val property_to_string : [< property ] -> string 30 30 + (** Convert a property to its wire name (e.g., [`Identity_id] -> "identityId"). *) 31 31 + 32 32 + val property_of_string : string -> property option 33 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 89 - id : Proto_id.t; 114 114 + id : Proto_id.t option; 90 115 (** Server-assigned submission id. *) 91 91 - identity_id : Proto_id.t; 116 116 + identity_id : Proto_id.t option; 92 117 (** The identity used to send. *) 93 93 - email_id : Proto_id.t; 118 118 + email_id : Proto_id.t option; 94 119 (** The email that was submitted. *) 95 95 - thread_id : Proto_id.t; 120 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 99 - send_at : Ptime.t; 124 124 + send_at : Ptime.t option; 100 125 (** When the email was/will be sent. *) 101 101 - undo_status : undo_status; 126 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 105 - dsn_blob_ids : Proto_id.t list; 130 130 + dsn_blob_ids : Proto_id.t list option; 106 131 (** Blob ids of received DSN messages. *) 107 107 - mdn_blob_ids : Proto_id.t list; 132 132 + mdn_blob_ids : Proto_id.t list option; 108 133 (** Blob ids of received MDN messages. *) 109 134 } 110 135 111 111 - val id : t -> Proto_id.t 112 112 - val identity_id : t -> Proto_id.t 113 113 - val email_id : t -> Proto_id.t 114 114 - val thread_id : t -> Proto_id.t 136 136 + val id : t -> Proto_id.t option 137 137 + val identity_id : t -> Proto_id.t option 138 138 + val email_id : t -> Proto_id.t option 139 139 + val thread_id : t -> Proto_id.t option 115 140 val envelope : t -> Envelope.t option 116 116 - val send_at : t -> Ptime.t 117 117 - val undo_status : t -> undo_status 141 141 + val send_at : t -> Ptime.t option 142 142 + val undo_status : t -> undo_status option 118 143 val delivery_status : t -> (string * Delivery_status.t) list option 119 119 - val dsn_blob_ids : t -> Proto_id.t list 120 120 - val mdn_blob_ids : t -> Proto_id.t list 144 144 + val dsn_blob_ids : t -> Proto_id.t list option 145 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

··· 3 3 SPDX-License-Identifier: ISC 4 4 ---------------------------------------------------------------------------*) 5 5 6 6 + (* Thread properties *) 7 7 + 8 8 + type property = [ 9 9 + | `Id 10 10 + | `Email_ids 11 11 + ] 12 12 + 13 13 + let property_to_string : [< property ] -> string = function 14 14 + | `Id -> "id" 15 15 + | `Email_ids -> "emailIds" 16 16 + 17 17 + let property_of_string s : property option = 18 18 + match s with 19 19 + | "id" -> Some `Id 20 20 + | "emailIds" -> Some `Email_ids 21 21 + | _ -> None 22 22 + 23 23 + (* Thread type *) 24 24 + 6 25 type t = { 7 7 - id : Proto_id.t; 8 8 - email_ids : Proto_id.t list; 26 26 + id : Proto_id.t option; 27 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 19 - |> Jsont.Object.mem "id" Proto_id.jsont ~enc:id 20 20 - |> Jsont.Object.mem "emailIds" (Jsont.list Proto_id.jsont) ~enc:email_ids 38 38 + |> Jsont.Object.opt_mem "id" Proto_id.jsont ~enc:id 39 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

··· 3 3 SPDX-License-Identifier: ISC 4 4 ---------------------------------------------------------------------------*) 5 5 6 6 - (** Thread type as defined in RFC 8621 Section 3 6 6 + (** Thread type as defined in RFC 8621 Section 3 7 7 8 8 @canonical Jmap.Proto.Thread *) 9 9 10 10 + (** {1 Thread Properties} 11 11 + 12 12 + Polymorphic variants for type-safe property selection in Thread/get requests. 13 13 + Threads have only two properties per RFC 8621 Section 3. *) 14 14 + 15 15 + (** All Thread properties that can be requested. *) 16 16 + type property = [ 17 17 + | `Id 18 18 + | `Email_ids 19 19 + ] 20 20 + 21 21 + val property_to_string : [< property ] -> string 22 22 + (** Convert a property to its wire name (e.g., [`Email_ids] -> "emailIds"). *) 23 23 + 24 24 + val property_of_string : string -> property option 25 25 + (** Parse a property name, case-sensitive. *) 26 26 + 27 27 + (** {1 Thread Object} *) 28 28 + 10 29 type t = { 11 11 - id : Proto_id.t; 30 30 + id : Proto_id.t option; 12 31 (** Server-assigned thread id. *) 13 13 - email_ids : Proto_id.t list; 32 32 + email_ids : Proto_id.t list option; 14 33 (** Ids of emails in this thread, in date order. *) 15 34 } 16 35 17 17 - val id : t -> Proto_id.t 18 18 - val email_ids : t -> Proto_id.t list 36 36 + val id : t -> Proto_id.t option 37 37 + val email_ids : t -> Proto_id.t list option 19 38 20 39 val jsont : t Jsont.t

+6

lib/top/dune

··· 1 1 + (include_subdirs no) 2 2 + 3 3 + (library 4 4 + (name jmap_top) 5 5 + (public_name jmap.top) 6 6 + (libraries jmap jsont.bytesrw compiler-libs.toplevel))

+68

lib/top/jmap_top.ml

··· 1 1 + (* Toplevel printers for JMAP types 2 2 + 3 3 + Usage in toplevel: 4 4 + #require "jmap.top";; 5 5 + 6 6 + Printers are automatically installed when the library is loaded. 7 7 + *) 8 8 + 9 9 + (* JSON printers *) 10 10 + 11 11 + let json_printer ppf (json : Jsont.json) = 12 12 + match Jsont_bytesrw.encode_string Jsont.json json with 13 13 + | Ok s -> Format.pp_print_string ppf s 14 14 + | Error e -> Format.fprintf ppf "<json encoding error: %s>" e 15 15 + 16 16 + let jsont_error_printer ppf (e : Jsont.Error.t) = 17 17 + Format.pp_print_string ppf (Jsont.Error.to_string e) 18 18 + 19 19 + (* JSON encoding helpers *) 20 20 + 21 21 + let encode (type a) (codec : a Jsont.t) (value : a) : Jsont.json = 22 22 + match Jsont.Json.encode codec value with 23 23 + | Ok json -> json 24 24 + | Error e -> invalid_arg e 25 25 + 26 26 + let encode_string (type a) (codec : a Jsont.t) (value : a) : string = 27 27 + match Jsont_bytesrw.encode_string codec value with 28 28 + | Ok s -> s 29 29 + | Error e -> invalid_arg e 30 30 + 31 31 + let pp_as_json (type a) (codec : a Jsont.t) ppf (value : a) = 32 32 + json_printer ppf (encode codec value) 33 33 + 34 34 + (* Automatic printer installation *) 35 35 + 36 36 + let printers = 37 37 + [ "Jmap.Id.pp"; 38 38 + "Jmap.Keyword.pp"; 39 39 + "Jmap.Role.pp"; 40 40 + "Jmap.Capability.pp"; 41 41 + "Jmap.Error.pp"; 42 42 + "Jmap_top.json_printer"; 43 43 + "Jmap_top.jsont_error_printer" ] 44 44 + 45 45 + (* Suppress stderr during printer installation to avoid noise in MDX tests *) 46 46 + let null_formatter = Format.make_formatter (fun _ _ _ -> ()) (fun () -> ()) 47 47 + 48 48 + let eval_string_quiet str = 49 49 + try 50 50 + let lexbuf = Lexing.from_string str in 51 51 + let phrase = !Toploop.parse_toplevel_phrase lexbuf in 52 52 + Toploop.execute_phrase false null_formatter phrase 53 53 + with _ -> false 54 54 + 55 55 + let rec do_install_printers = function 56 56 + | [] -> true 57 57 + | printer :: rest -> 58 58 + let cmd = Printf.sprintf "#install_printer %s;;" printer in 59 59 + eval_string_quiet cmd && do_install_printers rest 60 60 + 61 61 + let install () = 62 62 + (* Silently ignore failures - this handles non-toplevel contexts like MDX *) 63 63 + ignore (do_install_printers printers) 64 64 + 65 65 + (* Only auto-install when OCAML_TOPLEVEL_NAME is set, indicating a real toplevel *) 66 66 + let () = 67 67 + if Sys.getenv_opt "OCAML_TOPLEVEL_NAME" <> None then 68 68 + install ()

+50

lib/top/jmap_top.mli

··· 1 1 + (** Toplevel printers for JMAP types. 2 2 + 3 3 + Printers are automatically installed when the library is loaded: 4 4 + {[ 5 5 + #require "jmap.top";; 6 6 + ]} 7 7 + 8 8 + After loading, JMAP types will display nicely: 9 9 + {[ 10 10 + # Jmap.Id.of_string_exn "abc123";; 11 11 + - : Jmap.Id.t = <id:abc123> 12 12 + 13 13 + # Jmap.Keyword.of_string "$seen";; 14 14 + - : Jmap.Keyword.t = `Seen 15 15 + 16 16 + # Jmap.Role.of_string "inbox";; 17 17 + - : Jmap.Role.t = `Inbox 18 18 + ]} 19 19 + 20 20 + JSON values display as formatted strings, making it easy to see 21 21 + how OCaml types map to JMAP JSON. *) 22 22 + 23 23 + (** {1 JSON Printers} *) 24 24 + 25 25 + val json_printer : Format.formatter -> Jsont.json -> unit 26 26 + (** Formats a JSON value as a compact JSON string. *) 27 27 + 28 28 + val jsont_error_printer : Format.formatter -> Jsont.Error.t -> unit 29 29 + (** Formats a Jsont parsing error. *) 30 30 + 31 31 + (** {1 JSON Encoding Helpers} 32 32 + 33 33 + These functions encode OCaml types to JSON, useful for understanding 34 34 + how the library maps to JMAP wire format. *) 35 35 + 36 36 + val encode : 'a Jsont.t -> 'a -> Jsont.json 37 37 + (** [encode codec value] encodes a value to JSON using the given codec. 38 38 + Raises [Invalid_argument] on encoding failure. *) 39 39 + 40 40 + val encode_string : 'a Jsont.t -> 'a -> string 41 41 + (** [encode_string codec value] encodes a value to a JSON string. *) 42 42 + 43 43 + val pp_as_json : 'a Jsont.t -> Format.formatter -> 'a -> unit 44 44 + (** [pp_as_json codec ppf value] pretty-prints a value as JSON. *) 45 45 + 46 46 + (** {1 Installation} *) 47 47 + 48 48 + val install : unit -> unit 49 49 + (** [install ()] installs all printers. This is called automatically when 50 50 + the library is loaded, but can be called again if needed. *)

+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 51 + (* Helpers for extracting values from optional fields in tests *) 52 52 + let get_id opt = match opt with Some id -> Jmap.Proto.Id.to_string id | None -> Alcotest.fail "expected id" 53 53 + let get_string opt = match opt with Some s -> s | None -> Alcotest.fail "expected string" 54 54 + let get_int64 opt = match opt with Some n -> n | None -> Alcotest.fail "expected int64" 55 55 + let get_bool opt = match opt with Some b -> b | None -> Alcotest.fail "expected bool" 56 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 610 - Alcotest.(check string) "id" "mb1" (Jmap.Proto.Id.to_string (Mailbox.id mb)); 611 611 - Alcotest.(check string) "name" "Inbox" (Mailbox.name mb); 616 616 + Alcotest.(check string) "id" "mb1" (get_id (Mailbox.id mb)); 617 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 613 - Alcotest.(check int64) "totalEmails" 150L (Mailbox.total_emails mb); 614 614 - Alcotest.(check int64) "unreadEmails" 5L (Mailbox.unread_emails mb) 619 619 + Alcotest.(check int64) "totalEmails" 150L (get_int64 (Mailbox.total_emails mb)); 620 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 631 - Alcotest.(check int64) "totalEmails" 1000L (Mailbox.total_emails mb) 637 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 662 - Alcotest.(check string) "id" "e1" (Jmap.Proto.Id.to_string (Email.id email)); 663 663 - Alcotest.(check string) "blobId" "blob1" (Jmap.Proto.Id.to_string (Email.blob_id email)); 664 664 - Alcotest.(check int64) "size" 1024L (Email.size email) 668 668 + Alcotest.(check string) "id" "e1" (get_id (Email.id email)); 669 669 + Alcotest.(check string) "blobId" "blob1" (get_id (Email.blob_id email)); 670 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 672 - Alcotest.(check bool) "hasAttachment" true (Email.has_attachment email); 678 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 705 - let keywords = Email.keywords email in 711 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 715 - let mailbox_ids = Email.mailbox_ids email in 721 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 750 - Alcotest.(check string) "id" "t2" (Jmap.Proto.Id.to_string (Thread.id thread)); 751 751 - Alcotest.(check int) "emailIds count" 5 (List.length (Thread.email_ids thread)) 756 756 + Alcotest.(check string) "id" "t2" (get_id (Thread.id thread)); 757 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 772 - Alcotest.(check string) "name" "Work Identity" (Identity.name ident); 773 773 - Alcotest.(check string) "email" "john.doe@company.com" (Identity.email ident); 774 774 - Alcotest.(check bool) "mayDelete" true (Identity.may_delete ident) 778 778 + Alcotest.(check string) "name" "Work Identity" (get_string (Identity.name ident)); 779 779 + Alcotest.(check string) "email" "john.doe@company.com" (get_string (Identity.email ident)); 780 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 951 - Alcotest.(check string) "id" "sub1" (Jmap.Proto.Id.to_string (Submission.id sub)); 957 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 954 - | `Pending -> () 960 960 + | Some `Pending -> () 955 961 | _ -> Alcotest.fail "expected undoStatus to be pending" 956 962 957 963 let tests = [

+562

web/brr.html

··· 1 1 + <!DOCTYPE html> 2 2 + <html lang="en"> 3 3 + <head> 4 4 + <meta charset="utf-8"> 5 5 + <meta name="viewport" content="width=device-width, initial-scale=1.0"> 6 6 + <title>JMAP Email Client</title> 7 7 + <style> 8 8 + :root { 9 9 + --bg-color: #1a1a2e; 10 10 + --card-bg: #16213e; 11 11 + --accent: #0f3460; 12 12 + --highlight: #e94560; 13 13 + --text: #eee; 14 14 + --text-muted: #888; 15 15 + --success: #4ade80; 16 16 + --error: #f87171; 17 17 + --warning: #fbbf24; 18 18 + } 19 19 + 20 20 + * { 21 21 + box-sizing: border-box; 22 22 + margin: 0; 23 23 + padding: 0; 24 24 + } 25 25 + 26 26 + body { 27 27 + font-family: -apple-system, BlinkMacSystemFont, 'Segoe UI', Roboto, Oxygen, Ubuntu, sans-serif; 28 28 + background: var(--bg-color); 29 29 + color: var(--text); 30 30 + min-height: 100vh; 31 31 + padding: 20px; 32 32 + } 33 33 + 34 34 + .container { 35 35 + max-width: 1200px; 36 36 + margin: 0 auto; 37 37 + } 38 38 + 39 39 + header { 40 40 + text-align: center; 41 41 + margin-bottom: 30px; 42 42 + } 43 43 + 44 44 + h1 { 45 45 + font-size: 2rem; 46 46 + margin-bottom: 10px; 47 47 + } 48 48 + 49 49 + h1 span { 50 50 + color: var(--highlight); 51 51 + } 52 52 + 53 53 + .subtitle { 54 54 + color: var(--text-muted); 55 55 + font-size: 0.9rem; 56 56 + } 57 57 + 58 58 + /* Top Section - Two Column Layout */ 59 59 + .top-section { 60 60 + display: grid; 61 61 + grid-template-columns: 1fr 1fr; 62 62 + gap: 20px; 63 63 + margin-bottom: 20px; 64 64 + } 65 65 + 66 66 + @media (max-width: 800px) { 67 67 + .top-section { 68 68 + grid-template-columns: 1fr; 69 69 + } 70 70 + } 71 71 + 72 72 + /* Login Form */ 73 73 + .login-card { 74 74 + background: var(--card-bg); 75 75 + border-radius: 12px; 76 76 + padding: 16px; 77 77 + box-shadow: 0 4px 20px rgba(0,0,0,0.3); 78 78 + } 79 79 + 80 80 + .login-card h3 { 81 81 + margin-bottom: 12px; 82 82 + font-size: 0.9rem; 83 83 + color: var(--text-muted); 84 84 + text-transform: uppercase; 85 85 + letter-spacing: 1px; 86 86 + } 87 87 + 88 88 + .form-row { 89 89 + display: flex; 90 90 + gap: 12px; 91 91 + margin-bottom: 12px; 92 92 + } 93 93 + 94 94 + .form-group { 95 95 + flex: 1; 96 96 + margin-bottom: 12px; 97 97 + } 98 98 + 99 99 + .form-group:last-child { 100 100 + margin-bottom: 0; 101 101 + } 102 102 + 103 103 + .form-group.small { 104 104 + flex: 0.4; 105 105 + } 106 106 + 107 107 + label { 108 108 + display: block; 109 109 + margin-bottom: 4px; 110 110 + font-weight: 500; 111 111 + font-size: 0.75rem; 112 112 + color: var(--text-muted); 113 113 + } 114 114 + 115 115 + input[type="text"], 116 116 + input[type="password"] { 117 117 + width: 100%; 118 118 + padding: 8px 12px; 119 119 + border: 2px solid var(--accent); 120 120 + border-radius: 6px; 121 121 + background: var(--bg-color); 122 122 + color: var(--text); 123 123 + font-size: 0.85rem; 124 124 + transition: border-color 0.2s; 125 125 + } 126 126 + 127 127 + input:focus { 128 128 + outline: none; 129 129 + border-color: var(--highlight); 130 130 + } 131 131 + 132 132 + .btn-row { 133 133 + display: flex; 134 134 + gap: 8px; 135 135 + } 136 136 + 137 137 + .btn { 138 138 + flex: 1; 139 139 + padding: 10px; 140 140 + border: none; 141 141 + border-radius: 6px; 142 142 + font-size: 0.85rem; 143 143 + font-weight: 600; 144 144 + cursor: pointer; 145 145 + transition: transform 0.1s, opacity 0.2s; 146 146 + } 147 147 + 148 148 + .btn:hover { 149 149 + transform: translateY(-1px); 150 150 + } 151 151 + 152 152 + .btn:active { 153 153 + transform: translateY(0); 154 154 + } 155 155 + 156 156 + .btn:disabled { 157 157 + opacity: 0.5; 158 158 + cursor: not-allowed; 159 159 + transform: none; 160 160 + } 161 161 + 162 162 + .btn-primary { 163 163 + background: var(--highlight); 164 164 + color: white; 165 165 + } 166 166 + 167 167 + .btn-secondary { 168 168 + background: var(--accent); 169 169 + color: var(--text); 170 170 + } 171 171 + 172 172 + /* Status/Log Panel */ 173 173 + .log-panel { 174 174 + background: var(--card-bg); 175 175 + border-radius: 12px; 176 176 + padding: 20px; 177 177 + margin-bottom: 30px; 178 178 + max-height: 500px; 179 179 + overflow-y: auto; 180 180 + } 181 181 + 182 182 + .log-panel h3 { 183 183 + margin-bottom: 15px; 184 184 + font-size: 0.9rem; 185 185 + color: var(--text-muted); 186 186 + text-transform: uppercase; 187 187 + letter-spacing: 1px; 188 188 + } 189 189 + 190 190 + .log-entry { 191 191 + font-family: 'SF Mono', Monaco, 'Courier New', monospace; 192 192 + font-size: 0.85rem; 193 193 + padding: 8px 0; 194 194 + border-bottom: 1px solid var(--accent); 195 195 + } 196 196 + 197 197 + .log-entry:last-child { 198 198 + border-bottom: none; 199 199 + } 200 200 + 201 201 + .log-entry-header { 202 202 + display: flex; 203 203 + align-items: center; 204 204 + gap: 8px; 205 205 + } 206 206 + 207 207 + .log-info .log-entry-header { color: var(--text); } 208 208 + .log-success .log-entry-header { color: var(--success); } 209 209 + .log-error .log-entry-header { color: var(--error); } 210 210 + .log-warning .log-entry-header { color: var(--warning); } 211 211 + 212 212 + .log-time { 213 213 + color: var(--text-muted); 214 214 + font-size: 0.8rem; 215 215 + flex-shrink: 0; 216 216 + } 217 217 + 218 218 + .log-message { 219 219 + flex: 1; 220 220 + } 221 221 + 222 222 + .log-expand-btn { 223 223 + background: var(--accent); 224 224 + border: none; 225 225 + color: var(--text-muted); 226 226 + padding: 2px 8px; 227 227 + border-radius: 4px; 228 228 + font-size: 0.7rem; 229 229 + cursor: pointer; 230 230 + font-family: inherit; 231 231 + transition: background 0.2s, color 0.2s; 232 232 + flex-shrink: 0; 233 233 + } 234 234 + 235 235 + .log-expand-btn:hover { 236 236 + background: var(--highlight); 237 237 + color: white; 238 238 + } 239 239 + 240 240 + .log-expand-btn.expanded { 241 241 + background: var(--highlight); 242 242 + color: white; 243 243 + } 244 244 + 245 245 + /* JSON content within log entry */ 246 246 + .log-json { 247 247 + display: none; 248 248 + margin-top: 8px; 249 249 + border-radius: 8px; 250 250 + overflow: hidden; 251 251 + } 252 252 + 253 253 + .log-json.visible { 254 254 + display: block; 255 255 + } 256 256 + 257 257 + .log-json-header { 258 258 + padding: 6px 12px; 259 259 + font-size: 0.75rem; 260 260 + font-weight: 600; 261 261 + display: flex; 262 262 + justify-content: space-between; 263 263 + align-items: center; 264 264 + } 265 265 + 266 266 + .log-json.request .log-json-header { 267 267 + background: var(--accent); 268 268 + color: var(--highlight); 269 269 + } 270 270 + 271 271 + .log-json.response .log-json-header { 272 272 + background: #1a3a2e; 273 273 + color: var(--success); 274 274 + } 275 275 + 276 276 + .log-json-body { 277 277 + background: var(--bg-color); 278 278 + padding: 12px; 279 279 + font-size: 0.75rem; 280 280 + line-height: 1.4; 281 281 + white-space: pre-wrap; 282 282 + word-break: break-all; 283 283 + max-height: 300px; 284 284 + overflow-y: auto; 285 285 + color: var(--text-muted); 286 286 + } 287 287 + 288 288 + .log-json-body.collapsed { 289 289 + max-height: 100px; 290 290 + } 291 291 + 292 292 + .json-toggle-size { 293 293 + background: none; 294 294 + border: none; 295 295 + color: inherit; 296 296 + cursor: pointer; 297 297 + font-size: 0.7rem; 298 298 + opacity: 0.7; 299 299 + } 300 300 + 301 301 + .json-toggle-size:hover { 302 302 + opacity: 1; 303 303 + } 304 304 + 305 305 + /* Session Info */ 306 306 + .session-info { 307 307 + background: var(--card-bg); 308 308 + border-radius: 12px; 309 309 + padding: 16px; 310 310 + display: none; 311 311 + box-shadow: 0 4px 20px rgba(0,0,0,0.3); 312 312 + } 313 313 + 314 314 + .session-info.visible { 315 315 + display: block; 316 316 + } 317 317 + 318 318 + .session-info h3 { 319 319 + margin-bottom: 12px; 320 320 + font-size: 0.9rem; 321 321 + color: var(--success); 322 322 + text-transform: uppercase; 323 323 + letter-spacing: 1px; 324 324 + } 325 325 + 326 326 + .session-detail { 327 327 + display: flex; 328 328 + margin-bottom: 6px; 329 329 + font-size: 0.85rem; 330 330 + } 331 331 + 332 332 + .session-detail .label { 333 333 + width: 100px; 334 334 + color: var(--text-muted); 335 335 + flex-shrink: 0; 336 336 + } 337 337 + 338 338 + .session-detail .value { 339 339 + color: var(--text); 340 340 + word-break: break-all; 341 341 + font-family: 'SF Mono', Monaco, 'Courier New', monospace; 342 342 + font-size: 0.8rem; 343 343 + } 344 344 + 345 345 + .search-box { 346 346 + margin-top: 12px; 347 347 + padding-top: 12px; 348 348 + border-top: 1px solid var(--accent); 349 349 + display: flex; 350 350 + gap: 8px; 351 351 + } 352 352 + 353 353 + .search-box input { 354 354 + flex: 1; 355 355 + padding: 8px 12px; 356 356 + border: 2px solid var(--accent); 357 357 + border-radius: 6px; 358 358 + background: var(--bg-color); 359 359 + color: var(--text); 360 360 + font-size: 0.85rem; 361 361 + } 362 362 + 363 363 + .search-box input:focus { 364 364 + outline: none; 365 365 + border-color: var(--highlight); 366 366 + } 367 367 + 368 368 + .btn-small { 369 369 + flex: 0; 370 370 + padding: 8px 16px; 371 371 + white-space: nowrap; 372 372 + } 373 373 + 374 374 + /* Email List */ 375 375 + .email-list { 376 376 + display: none; 377 377 + } 378 378 + 379 379 + .email-list.visible { 380 380 + display: block; 381 381 + } 382 382 + 383 383 + .email-list h2 { 384 384 + margin-bottom: 20px; 385 385 + } 386 386 + 387 387 + .email-item { 388 388 + background: var(--card-bg); 389 389 + border-radius: 8px; 390 390 + padding: 16px 20px; 391 391 + margin-bottom: 12px; 392 392 + cursor: pointer; 393 393 + transition: background 0.2s, transform 0.1s; 394 394 + border-left: 4px solid transparent; 395 395 + } 396 396 + 397 397 + .email-item:hover { 398 398 + background: var(--accent); 399 399 + transform: translateX(4px); 400 400 + } 401 401 + 402 402 + .email-item.unread { 403 403 + border-left-color: var(--highlight); 404 404 + } 405 405 + 406 406 + .email-header { 407 407 + display: flex; 408 408 + justify-content: space-between; 409 409 + align-items: flex-start; 410 410 + margin-bottom: 8px; 411 411 + } 412 412 + 413 413 + .email-from { 414 414 + font-weight: 600; 415 415 + font-size: 1rem; 416 416 + } 417 417 + 418 418 + .email-date { 419 419 + color: var(--text-muted); 420 420 + font-size: 0.85rem; 421 421 + } 422 422 + 423 423 + .email-subject { 424 424 + font-size: 0.95rem; 425 425 + color: var(--text); 426 426 + margin-bottom: 6px; 427 427 + } 428 428 + 429 429 + .email-preview { 430 430 + color: var(--text-muted); 431 431 + font-size: 0.85rem; 432 432 + white-space: nowrap; 433 433 + overflow: hidden; 434 434 + text-overflow: ellipsis; 435 435 + } 436 436 + 437 437 + .email-keywords { 438 438 + margin-top: 8px; 439 439 + } 440 440 + 441 441 + .keyword-tag { 442 442 + display: inline-block; 443 443 + background: var(--accent); 444 444 + color: var(--text-muted); 445 445 + padding: 2px 8px; 446 446 + border-radius: 4px; 447 447 + font-size: 0.75rem; 448 448 + margin-right: 6px; 449 449 + } 450 450 + 451 451 + .keyword-tag.flagged { 452 452 + background: var(--warning); 453 453 + color: var(--bg-color); 454 454 + } 455 455 + 456 456 + /* Loading spinner */ 457 457 + .spinner { 458 458 + display: inline-block; 459 459 + width: 20px; 460 460 + height: 20px; 461 461 + border: 2px solid var(--text-muted); 462 462 + border-top-color: var(--highlight); 463 463 + border-radius: 50%; 464 464 + animation: spin 0.8s linear infinite; 465 465 + margin-right: 10px; 466 466 + vertical-align: middle; 467 467 + } 468 468 + 469 469 + @keyframes spin { 470 470 + to { transform: rotate(360deg); } 471 471 + } 472 472 + 473 473 + /* Responsive */ 474 474 + @media (max-width: 600px) { 475 475 + body { 476 476 + padding: 10px; 477 477 + } 478 478 + 479 479 + .login-card { 480 480 + padding: 20px; 481 481 + } 482 482 + 483 483 + h1 { 484 484 + font-size: 1.5rem; 485 485 + } 486 486 + } 487 487 + </style> 488 488 + </head> 489 489 + <body> 490 490 + <div class="container"> 491 491 + <header> 492 492 + <h1>JMAP <span>Email Client</span></h1> 493 493 + <p class="subtitle">Built with OCaml and Brr</p> 494 494 + </header> 495 495 + 496 496 + <!-- Top Section: Login + Session Info --> 497 497 + <div class="top-section"> 498 498 + <!-- Login Form --> 499 499 + <div class="login-card" id="login-card"> 500 500 + <h3>Connection</h3> 501 501 + <div class="form-group"> 502 502 + <label for="session-url">Session URL</label> 503 503 + <input type="text" id="session-url" 504 504 + value="https://api.fastmail.com/jmap/session" 505 505 + placeholder="https://api.fastmail.com/jmap/session"> 506 506 + </div> 507 507 + <div class="form-row"> 508 508 + <div class="form-group"> 509 509 + <label for="api-token">API Token</label> 510 510 + <input type="password" id="api-token" 511 511 + placeholder="Enter your JMAP API token"> 512 512 + </div> 513 513 + </div> 514 514 + <div class="btn-row"> 515 515 + <button class="btn btn-primary" id="connect-btn">Connect</button> 516 516 + <button class="btn btn-secondary" id="disconnect-btn" style="display: none;">Disconnect</button> 517 517 + </div> 518 518 + </div> 519 519 + 520 520 + <!-- Session Info --> 521 521 + <div class="session-info" id="session-info"> 522 522 + <h3>Connected</h3> 523 523 + <div class="session-detail"> 524 524 + <span class="label">Username:</span> 525 525 + <span class="value" id="session-username">-</span> 526 526 + </div> 527 527 + <div class="session-detail"> 528 528 + <span class="label">API URL:</span> 529 529 + <span class="value" id="session-api-url">-</span> 530 530 + </div> 531 531 + <div class="session-detail"> 532 532 + <span class="label">Account ID:</span> 533 533 + <span class="value" id="session-account-id">-</span> 534 534 + </div> 535 535 + <div class="search-box"> 536 536 + <input type="text" id="email-search" placeholder="Search emails..."> 537 537 + <button class="btn btn-primary btn-small" id="search-btn">Search</button> 538 538 + </div> 539 539 + </div> 540 540 + </div> 541 541 + 542 542 + <!-- Log Panel with expandable JSON --> 543 543 + <div class="log-panel" id="log-panel"> 544 544 + <h3>Activity Log</h3> 545 545 + <div id="log-entries"></div> 546 546 + </div> 547 547 + 548 548 + <!-- Email List --> 549 549 + <div class="email-list" id="email-list"> 550 550 + <h2>Recent Emails</h2> 551 551 + <div id="emails"></div> 552 552 + </div> 553 553 + </div> 554 554 + 555 555 + <script type="text/javascript" defer src="brr.js"></script> 556 556 + <noscript> 557 557 + <p style="text-align: center; padding: 50px; color: #888;"> 558 558 + Please enable JavaScript to use this application. 559 559 + </p> 560 560 + </noscript> 561 561 + </body> 562 562 + </html>

+539

web/brr_app.ml

··· 1 1 + (*--------------------------------------------------------------------------- 2 2 + JMAP Email Client - Browser Application 3 3 + Built with OCaml, Brr, and jmap-brr 4 4 + ---------------------------------------------------------------------------*) 5 5 + 6 6 + open Brr 7 7 + open Fut.Syntax 8 8 + 9 9 + (* ---- Shared timestamp utilities ---- *) 10 10 + 11 11 + let get_time_str () = 12 12 + let date = Jv.new' (Jv.get Jv.global "Date") [||] in 13 13 + let h = Jv.to_int (Jv.call date "getHours" [||]) in 14 14 + let m = Jv.to_int (Jv.call date "getMinutes" [||]) in 15 15 + let s = Jv.to_int (Jv.call date "getSeconds" [||]) in 16 16 + Printf.sprintf "%02d:%02d:%02d" h m s 17 17 + 18 18 + (* ---- JSON Masking ---- *) 19 19 + 20 20 + module JsonMask = struct 21 21 + let sensitive_keys = [ 22 22 + "accountId"; "blobId"; "threadId"; "emailId"; "id"; 23 23 + "username"; "apiUrl"; "downloadUrl"; "uploadUrl"; "eventSourceUrl"; 24 24 + "state"; "oldState"; "newState" 25 25 + ] 26 26 + 27 27 + let is_sensitive key = 28 28 + List.exists (fun k -> String.lowercase_ascii k = String.lowercase_ascii key) sensitive_keys 29 29 + 30 30 + let mask_value s = 31 31 + let len = String.length s in 32 32 + if len <= 4 then String.make len '*' 33 33 + else 34 34 + let visible = min 4 (len / 4) in 35 35 + (String.sub s 0 visible) ^ String.make (len - visible) '*' 36 36 + 37 37 + let rec mask_json (json : Jv.t) : Jv.t = 38 38 + if Jv.is_null json || Jv.is_undefined json then json 39 39 + else if Jv.is_array json then 40 40 + let arr = Jv.to_list Fun.id json in 41 41 + let masked = List.map mask_json arr in 42 42 + Jv.of_list Fun.id masked 43 43 + else if Jstr.equal (Jv.typeof json) (Jstr.v "object") && not (Jv.is_array json) then 44 44 + let obj = Jv.obj [||] in 45 45 + let keys = Jv.call (Jv.get Jv.global "Object") "keys" [|json|] in 46 46 + let key_list = Jv.to_list Jv.to_string keys in 47 47 + List.iter (fun key -> 48 48 + let value = Jv.get json key in 49 49 + let masked_value = 50 50 + if is_sensitive key && Jstr.equal (Jv.typeof value) (Jstr.v "string") then 51 51 + Jv.of_string (mask_value (Jv.to_string value)) 52 52 + else 53 53 + mask_json value 54 54 + in 55 55 + Jv.set obj key masked_value 56 56 + ) key_list; 57 57 + obj 58 58 + else 59 59 + json 60 60 + 61 61 + let format_json json = 62 62 + let json_obj = Jv.get Jv.global "JSON" in 63 63 + Jv.to_string (Jv.call json_obj "stringify" [|json; Jv.null; Jv.of_int 2|]) 64 64 + 65 65 + let mask_and_format json_str = 66 66 + try 67 67 + let json_obj = Jv.get Jv.global "JSON" in 68 68 + let parsed = Jv.call json_obj "parse" [|Jv.of_string json_str|] in 69 69 + let masked = mask_json parsed in 70 70 + format_json masked 71 71 + with _ -> json_str 72 72 + end 73 73 + 74 74 + (* ---- Logging with expandable JSON ---- *) 75 75 + 76 76 + module Log = struct 77 77 + type level = Info | Success | Error | Warning 78 78 + 79 79 + let log_entries_el () = 80 80 + Document.find_el_by_id G.document (Jstr.v "log-entries") 81 81 + 82 82 + (* Reference to the last created entry for attaching JSON *) 83 83 + let last_entry : El.t option ref = ref None 84 84 + 85 85 + let add level msg = 86 86 + match log_entries_el () with 87 87 + | None -> Console.(log [str msg]) 88 88 + | Some container -> 89 89 + let time_str = get_time_str () in 90 90 + let class_name = match level with 91 91 + | Info -> "log-info" 92 92 + | Success -> "log-success" 93 93 + | Error -> "log-error" 94 94 + | Warning -> "log-warning" 95 95 + in 96 96 + let header = El.div ~at:At.[class' (Jstr.v "log-entry-header")] [ 97 97 + El.span ~at:At.[class' (Jstr.v "log-time")] [El.txt' time_str]; 98 98 + El.span ~at:At.[class' (Jstr.v "log-message")] [El.txt' msg]; 99 99 + ] in 100 100 + let entry = El.div ~at:At.[class' (Jstr.v ("log-entry " ^ class_name))] [header] in 101 101 + last_entry := Some entry; 102 102 + El.append_children container [entry]; 103 103 + (* Scroll to bottom *) 104 104 + let scroll_height = Jv.get (El.to_jv container) "scrollHeight" in 105 105 + Jv.set (El.to_jv container) "scrollTop" scroll_height 106 106 + 107 107 + let attach_json direction label json_str = 108 108 + match !last_entry with 109 109 + | None -> () 110 110 + | Some entry -> 111 111 + let formatted = JsonMask.mask_and_format json_str in 112 112 + let class_name = match direction with 113 113 + | `Request -> "log-json request" 114 114 + | `Response -> "log-json response" 115 115 + in 116 116 + let arrow = match direction with 117 117 + | `Request -> ">>> " 118 118 + | `Response -> "<<< " 119 119 + in 120 120 + (* Create the JSON container (hidden by default) *) 121 121 + let json_body = El.pre ~at:At.[class' (Jstr.v "log-json-body collapsed")] [El.txt' formatted] in 122 122 + let expand_size_btn = El.button ~at:At.[class' (Jstr.v "json-toggle-size")] [El.txt' "[expand]"] in 123 123 + let json_div = El.div ~at:At.[class' (Jstr.v class_name)] [ 124 124 + El.div ~at:At.[class' (Jstr.v "log-json-header")] [ 125 125 + El.span [El.txt' (arrow ^ label)]; 126 126 + expand_size_btn; 127 127 + ]; 128 128 + json_body; 129 129 + ] in 130 130 + (* Add expand button to header if not already there *) 131 131 + let header = El.children entry |> List.hd in 132 132 + let existing_btns = El.children header |> List.filter (fun el -> 133 133 + match El.at (Jstr.v "class") el with 134 134 + | Some cls -> Option.is_some (Jstr.find_sub ~sub:(Jstr.v "log-expand-btn") cls) 135 135 + | None -> false 136 136 + ) in 137 137 + if List.length existing_btns = 0 then begin 138 138 + let expand_btn = El.button ~at:At.[class' (Jstr.v "log-expand-btn")] [El.txt' "JSON"] in 139 139 + El.append_children header [expand_btn]; 140 140 + (* Toggle visibility on click *) 141 141 + ignore @@ Ev.listen Ev.click (fun _ev -> 142 142 + let json_els = El.children entry |> List.filter (fun el -> 143 143 + match El.at (Jstr.v "class") el with 144 144 + | Some cls -> Option.is_some (Jstr.find_sub ~sub:(Jstr.v "log-json") cls) 145 145 + | None -> false 146 146 + ) in 147 147 + let is_visible = List.exists (fun el -> 148 148 + El.class' (Jstr.v "visible") el 149 149 + ) json_els in 150 150 + List.iter (fun el -> 151 151 + El.set_class (Jstr.v "visible") (not is_visible) el 152 152 + ) json_els; 153 153 + El.set_class (Jstr.v "expanded") (not is_visible) expand_btn 154 154 + ) (El.as_target expand_btn) 155 155 + end; 156 156 + (* Toggle body size *) 157 157 + ignore @@ Ev.listen Ev.click (fun _ev -> 158 158 + let is_collapsed = El.class' (Jstr.v "collapsed") json_body in 159 159 + El.set_class (Jstr.v "collapsed") (not is_collapsed) json_body; 160 160 + El.set_children expand_size_btn [El.txt' (if is_collapsed then "[collapse]" else "[expand]")] 161 161 + ) (El.as_target expand_size_btn); 162 162 + El.append_children entry [json_div]; 163 163 + (* Scroll to bottom *) 164 164 + match log_entries_el () with 165 165 + | Some container -> 166 166 + let scroll_height = Jv.get (El.to_jv container) "scrollHeight" in 167 167 + Jv.set (El.to_jv container) "scrollTop" scroll_height 168 168 + | None -> () 169 169 + 170 170 + let info msg = add Info msg 171 171 + let success msg = add Success msg 172 172 + let error msg = add Error msg 173 173 + let warning msg = add Warning msg 174 174 + end 175 175 + 176 176 + (* ---- JSON Protocol Logging (bridges to Log.attach_json) ---- *) 177 177 + 178 178 + module JsonLog = struct 179 179 + let request label json = Log.attach_json `Request label json 180 180 + let response label json = Log.attach_json `Response label json 181 181 + let clear () = () (* No longer needed *) 182 182 + end 183 183 + 184 184 + (* ---- DOM Helpers ---- *) 185 185 + 186 186 + let get_el id = 187 187 + match Document.find_el_by_id G.document (Jstr.v id) with 188 188 + | Some el -> el 189 189 + | None -> failwith (Printf.sprintf "Element not found: %s" id) 190 190 + 191 191 + let get_input_value id = 192 192 + let el = get_el id in 193 193 + Jstr.to_string (El.prop El.Prop.value el) 194 194 + 195 195 + let set_text id text = 196 196 + let el = get_el id in 197 197 + El.set_children el [El.txt' text] 198 198 + 199 199 + let show_el id = 200 200 + let el = get_el id in 201 201 + El.set_class (Jstr.v "visible") true el 202 202 + 203 203 + let hide_el id = 204 204 + let el = get_el id in 205 205 + El.set_class (Jstr.v "visible") false el 206 206 + 207 207 + let set_button_loading id loading = 208 208 + let el = get_el id in 209 209 + El.set_at At.Name.disabled (if loading then Some (Jstr.v "") else None) el; 210 210 + if loading then 211 211 + El.set_children el [ 212 212 + El.span ~at:At.[class' (Jstr.v "spinner")] []; 213 213 + El.txt' "Connecting..." 214 214 + ] 215 215 + else 216 216 + El.set_children el [El.txt' "Connect"] 217 217 + 218 218 + (* ---- Email Display ---- *) 219 219 + 220 220 + let format_date ptime = 221 221 + let date, time = Ptime.to_date_time ptime in 222 222 + let y, m, d = date in 223 223 + let (h, min, _), _ = time in 224 224 + Printf.sprintf "%04d-%02d-%02d %02d:%02d" y m d h min 225 225 + 226 226 + let format_address (addr : Jmap.Proto.Email_address.t) = 227 227 + match addr.name with 228 228 + | Some name -> Printf.sprintf "%s <%s>" name addr.email 229 229 + | None -> addr.email 230 230 + 231 231 + let format_addresses = function 232 232 + | None -> "Unknown" 233 233 + | Some [] -> "Unknown" 234 234 + | Some (addr :: _) -> format_address addr 235 235 + 236 236 + let render_email (email : Jmap.Proto.Email.t) = 237 237 + let keywords = Option.value ~default:[] email.keywords in 238 238 + let is_unread = not (List.exists (fun (k, v) -> k = "$seen" && v) keywords) in 239 239 + let is_flagged = List.exists (fun (k, v) -> k = "$flagged" && v) keywords in 240 240 + 241 241 + let from_str = format_addresses email.from in 242 242 + let subject = Option.value ~default:"(No Subject)" email.subject in 243 243 + let date_str = match email.received_at with Some t -> format_date t | None -> "?" in 244 244 + let preview = Option.value ~default:"" email.preview in 245 245 + 246 246 + let keyword_tags = 247 247 + if is_flagged then 248 248 + [El.span ~at:At.[class' (Jstr.v "keyword-tag flagged")] [El.txt' "Flagged"]] 249 249 + else 250 250 + [] 251 251 + in 252 252 + 253 253 + let classes = "email-item" ^ (if is_unread then " unread" else "") in 254 254 + 255 255 + El.div ~at:At.[class' (Jstr.v classes)] [ 256 256 + El.div ~at:At.[class' (Jstr.v "email-header")] [ 257 257 + El.span ~at:At.[class' (Jstr.v "email-from")] [El.txt' from_str]; 258 258 + El.span ~at:At.[class' (Jstr.v "email-date")] [El.txt' date_str]; 259 259 + ]; 260 260 + El.div ~at:At.[class' (Jstr.v "email-subject")] [El.txt' subject]; 261 261 + El.div ~at:At.[class' (Jstr.v "email-preview")] [El.txt' preview]; 262 262 + El.div ~at:At.[class' (Jstr.v "email-keywords")] keyword_tags; 263 263 + ] 264 264 + 265 265 + let display_emails emails = 266 266 + let container = get_el "emails" in 267 267 + let email_els = List.map render_email emails in 268 268 + El.set_children container email_els; 269 269 + show_el "email-list" 270 270 + 271 271 + (* ---- State ---- *) 272 272 + 273 273 + type state = { 274 274 + mutable connection : Jmap_brr.connection option; 275 275 + mutable account_id : Jmap.Proto.Id.t option; 276 276 + } 277 277 + 278 278 + let state = { connection = None; account_id = None } 279 279 + 280 280 + (* ---- JMAP Operations ---- *) 281 281 + 282 282 + let fetch_emails ?(search_text="") conn account_id = 283 283 + let search_msg = if search_text = "" then "Fetching recent emails..." 284 284 + else Printf.sprintf "Searching emails for '%s'..." search_text in 285 285 + Log.info search_msg; 286 286 + 287 287 + let capabilities = [ 288 288 + Jmap.Capability.core_uri; 289 289 + Jmap.Capability.mail_uri 290 290 + ] in 291 291 + 292 292 + (* First, get mailboxes to find the inbox *) 293 293 + let request, mailbox_handle = 294 294 + let open Jmap.Chain in 295 295 + build ~capabilities (mailbox_get ~account_id ()) 296 296 + in 297 297 + 298 298 + let* response = Jmap_brr.request conn request in 299 299 + match response with 300 300 + | Error e -> 301 301 + Log.error (Printf.sprintf "Failed to get mailboxes: %s" 302 302 + (Jstr.to_string (Jv.Error.message e))); 303 303 + Fut.return () 304 304 + | Ok resp -> 305 305 + match Jmap.Chain.parse mailbox_handle resp with 306 306 + | Error e -> 307 307 + Log.error (Printf.sprintf "Failed to parse mailboxes: %s" 308 308 + (Jsont.Error.to_string e)); 309 309 + Fut.return () 310 310 + | Ok mailbox_resp -> 311 311 + let mailboxes = mailbox_resp.list in 312 312 + Log.info (Printf.sprintf "Found %d mailboxes" (List.length mailboxes)); 313 313 + 314 314 + (* Find inbox or use first mailbox *) 315 315 + let inbox_id = 316 316 + match List.find_opt (fun m -> 317 317 + match m.Jmap.Proto.Mailbox.role with 318 318 + | Some `Inbox -> true 319 319 + | _ -> false 320 320 + ) mailboxes with 321 321 + | Some m -> m.Jmap.Proto.Mailbox.id 322 322 + | None -> 323 323 + match mailboxes with 324 324 + | m :: _ -> m.Jmap.Proto.Mailbox.id 325 325 + | [] -> 326 326 + Log.error "No mailboxes found"; 327 327 + failwith "No mailboxes" 328 328 + in 329 329 + let inbox_id = match inbox_id with 330 330 + | Some id -> id 331 331 + | None -> 332 332 + Log.error "Inbox has no ID"; 333 333 + failwith "Inbox has no ID" 334 334 + in 335 335 + 336 336 + let query_msg = if search_text = "" then "Querying emails from inbox..." 337 337 + else Printf.sprintf "Querying inbox for '%s'..." search_text in 338 338 + Log.info query_msg; 339 339 + 340 340 + (* Query for recent emails with optional text search *) 341 341 + let text_filter = if search_text = "" then None else Some search_text in 342 342 + let filter_condition : Jmap.Proto.Email.Filter_condition.t = { 343 343 + in_mailbox = Some inbox_id; 344 344 + in_mailbox_other_than = None; 345 345 + before = None; 346 346 + after = None; 347 347 + min_size = None; 348 348 + max_size = None; 349 349 + all_in_thread_have_keyword = None; 350 350 + some_in_thread_have_keyword = None; 351 351 + none_in_thread_have_keyword = None; 352 352 + has_keyword = None; 353 353 + not_keyword = None; 354 354 + has_attachment = None; 355 355 + text = text_filter; 356 356 + from = None; 357 357 + to_ = None; 358 358 + cc = None; 359 359 + bcc = None; 360 360 + subject = None; 361 361 + body = None; 362 362 + header = None; 363 363 + } in 364 364 + 365 365 + let request2, email_handle = 366 366 + let open Jmap.Chain in 367 367 + build ~capabilities begin 368 368 + let* query = email_query ~account_id 369 369 + ~filter:(Jmap.Proto.Filter.Condition filter_condition) 370 370 + ~sort:[Jmap.Proto.Filter.comparator ~is_ascending:false "receivedAt"] 371 371 + ~limit:20L 372 372 + () 373 373 + in 374 374 + email_get ~account_id 375 375 + ~ids:(from_query query) 376 376 + ~properties:["id"; "blobId"; "threadId"; "mailboxIds"; "keywords"; 377 377 + "size"; "receivedAt"; "from"; "subject"; "preview"; 378 378 + "hasAttachment"] 379 379 + () 380 380 + end 381 381 + in 382 382 + 383 383 + Log.info "Sending email query request..."; 384 384 + let* response2 = Jmap_brr.request conn request2 in 385 385 + Log.info "Got email query response"; 386 386 + match response2 with 387 387 + | Error e -> 388 388 + Log.error (Printf.sprintf "Failed to query emails: %s" 389 389 + (Jstr.to_string (Jv.Error.message e))); 390 390 + Fut.return () 391 391 + | Ok resp2 -> 392 392 + Log.info "Parsing email response..."; 393 393 + match Jmap.Chain.parse email_handle resp2 with 394 394 + | Error e -> 395 395 + Log.error (Printf.sprintf "Failed to parse emails: %s" 396 396 + (Jsont.Error.to_string e)); 397 397 + Fut.return () 398 398 + | Ok email_resp -> 399 399 + let emails = email_resp.list in 400 400 + Log.success (Printf.sprintf "Loaded %d emails" (List.length emails)); 401 401 + (try 402 402 + display_emails emails 403 403 + with exn -> 404 404 + Log.error (Printf.sprintf "Display error: %s" (Printexc.to_string exn))); 405 405 + Fut.return () 406 406 + 407 407 + (* ---- Connection ---- *) 408 408 + 409 409 + let connect () = 410 410 + let session_url = get_input_value "session-url" in 411 411 + let api_token = get_input_value "api-token" in 412 412 + 413 413 + if String.length api_token = 0 then begin 414 414 + Log.error "Please enter an API token"; 415 415 + Fut.return () 416 416 + end else begin 417 417 + Log.info (Printf.sprintf "Connecting to %s..." session_url); 418 418 + set_button_loading "connect-btn" true; 419 419 + 420 420 + let* result = Jmap_brr.get_session 421 421 + ~url:(Jstr.v session_url) 422 422 + ~token:(Jstr.v api_token) 423 423 + in 424 424 + 425 425 + set_button_loading "connect-btn" false; 426 426 + 427 427 + match result with 428 428 + | Error e -> 429 429 + let msg = Jstr.to_string (Jv.Error.message e) in 430 430 + Log.error (Printf.sprintf "Connection failed: %s" msg); 431 431 + Fut.return () 432 432 + | Ok conn -> 433 433 + let session = Jmap_brr.session conn in 434 434 + let username = Jmap.Proto.Session.username session in 435 435 + let api_url = Jmap.Proto.Session.api_url session in 436 436 + 437 437 + Log.success (Printf.sprintf "Connected as %s" username); 438 438 + 439 439 + (* Find primary mail account *) 440 440 + let account_id = 441 441 + match Jmap.Proto.Session.primary_account_for 442 442 + Jmap.Capability.mail_uri session with 443 443 + | Some id -> id 444 444 + | None -> 445 445 + match Jmap.Proto.Session.accounts session with 446 446 + | (id, _) :: _ -> id 447 447 + | [] -> failwith "No accounts found" 448 448 + in 449 449 + 450 450 + state.connection <- Some conn; 451 451 + state.account_id <- Some account_id; 452 452 + 453 453 + (* Update UI *) 454 454 + set_text "session-username" username; 455 455 + set_text "session-api-url" api_url; 456 456 + set_text "session-account-id" (Jmap.Proto.Id.to_string account_id); 457 457 + show_el "session-info"; 458 458 + 459 459 + (* Show disconnect button *) 460 460 + let connect_btn = get_el "connect-btn" in 461 461 + let disconnect_btn = get_el "disconnect-btn" in 462 462 + El.set_inline_style (Jstr.v "display") (Jstr.v "none") connect_btn; 463 463 + El.set_inline_style (Jstr.v "display") (Jstr.v "block") disconnect_btn; 464 464 + 465 465 + (* Fetch emails *) 466 466 + fetch_emails conn account_id 467 467 + end 468 468 + 469 469 + let disconnect () = 470 470 + state.connection <- None; 471 471 + state.account_id <- None; 472 472 + 473 473 + hide_el "session-info"; 474 474 + hide_el "email-list"; 475 475 + 476 476 + (* Reset buttons *) 477 477 + let connect_btn = get_el "connect-btn" in 478 478 + let disconnect_btn = get_el "disconnect-btn" in 479 479 + El.set_inline_style (Jstr.v "display") (Jstr.v "block") connect_btn; 480 480 + El.set_inline_style (Jstr.v "display") (Jstr.v "none") disconnect_btn; 481 481 + 482 482 + Log.info "Disconnected" 483 483 + 484 484 + let search_emails () = 485 485 + match state.connection, state.account_id with 486 486 + | Some conn, Some account_id -> 487 487 + let search_text = get_input_value "email-search" in 488 488 + ignore (fetch_emails ~search_text conn account_id) 489 489 + | _ -> 490 490 + Log.warning "Not connected" 491 491 + 492 492 + (* ---- Main ---- *) 493 493 + 494 494 + let setup_handlers () = 495 495 + let connect_btn = get_el "connect-btn" in 496 496 + let disconnect_btn = get_el "disconnect-btn" in 497 497 + 498 498 + (* Connect button click *) 499 499 + ignore @@ Ev.listen Ev.click (fun _ev -> 500 500 + ignore (connect ()) 501 501 + ) (El.as_target connect_btn); 502 502 + 503 503 + (* Disconnect button click *) 504 504 + ignore @@ Ev.listen Ev.click (fun _ev -> 505 505 + disconnect () 506 506 + ) (El.as_target disconnect_btn); 507 507 + 508 508 + (* Enter key in token field *) 509 509 + let token_input = get_el "api-token" in 510 510 + ignore @@ Ev.listen Ev.keydown (fun ev -> 511 511 + let kev = Ev.as_type ev in 512 512 + if Jstr.equal (Ev.Keyboard.key kev) (Jstr.v "Enter") then 513 513 + ignore (connect ()) 514 514 + ) (El.as_target token_input); 515 515 + 516 516 + (* Search button click *) 517 517 + let search_btn = get_el "search-btn" in 518 518 + ignore @@ Ev.listen Ev.click (fun _ev -> 519 519 + search_emails () 520 520 + ) (El.as_target search_btn); 521 521 + 522 522 + (* Enter key in search field *) 523 523 + let search_input = get_el "email-search" in 524 524 + ignore @@ Ev.listen Ev.keydown (fun ev -> 525 525 + let kev = Ev.as_type ev in 526 526 + if Jstr.equal (Ev.Keyboard.key kev) (Jstr.v "Enter") then 527 527 + search_emails () 528 528 + ) (El.as_target search_input) 529 529 + 530 530 + let main () = 531 531 + (* Register JSON loggers *) 532 532 + Jmap_brr.set_request_logger JsonLog.request; 533 533 + Jmap_brr.set_response_logger JsonLog.response; 534 534 + 535 535 + Log.info "JMAP Email Client initialized"; 536 536 + Log.info "Enter your JMAP server URL and API token to connect"; 537 537 + setup_handlers () 538 538 + 539 539 + let () = main ()

+15

web/dune

··· 1 1 + (executable 2 2 + (name brr_app) 3 3 + (libraries jmap_brr brr) 4 4 + (modes js) 5 5 + (flags (:standard -w -32-69)) 6 6 + (js_of_ocaml)) 7 7 + 8 8 + (rule 9 9 + (targets brr.js) 10 10 + (deps brr_app.bc.js) 11 11 + (action (copy %{deps} %{targets}))) 12 12 + 13 13 + (alias 14 14 + (name web) 15 15 + (deps brr.js brr.html))