+20 -1

.gitignore

··· 1 1 - _build 1 1 + # OCaml build artifacts 2 2 + _build/ 3 3 + *.install 4 4 + *.merlin 5 5 + 6 6 + # Third-party sources (fetch locally with opam source) 7 7 + third_party/ 8 8 + 9 9 + # Editor and OS files 10 10 + .DS_Store 11 11 + *.swp 12 12 + *~ 13 13 + .vscode/ 14 14 + .idea/ 15 15 + 16 16 + # Opam local switch 17 17 + _opam/ 18 18 + 19 19 + # Environment and secrets 2 20 .env 3 21 .api-key 22 22 + .api-key-rw 4 23 .api-url

+1

.ocamlformat

··· 1 1 + version=0.28.1

+53

.tangled/workflows/build.yml

··· 1 1 + when: 2 2 + - event: ["push", "pull_request"] 3 3 + branch: ["main"] 4 4 + 5 5 + engine: nixery 6 6 + 7 7 + dependencies: 8 8 + nixpkgs: 9 9 + - shell 10 10 + - stdenv 11 11 + - findutils 12 12 + - binutils 13 13 + - libunwind 14 14 + - ncurses 15 15 + - opam 16 16 + - git 17 17 + - gawk 18 18 + - gnupatch 19 19 + - gnum4 20 20 + - gnumake 21 21 + - gnutar 22 22 + - gnused 23 23 + - gnugrep 24 24 + - diffutils 25 25 + - gzip 26 26 + - bzip2 27 27 + - gcc 28 28 + - ocaml 29 29 + - pkg-config 30 30 + 31 31 + steps: 32 32 + - name: opam 33 33 + command: | 34 34 + opam init --disable-sandboxing -a -y 35 35 + - name: repo 36 36 + command: | 37 37 + opam repo add aoah https://tangled.org/anil.recoil.org/aoah-opam-repo.git 38 38 + - name: switch 39 39 + command: | 40 40 + opam install . --confirm-level=unsafe-yes --deps-only 41 41 + - name: build 42 42 + command: | 43 43 + opam exec -- dune build -p jmap 44 44 + - name: switch-test 45 45 + command: | 46 46 + opam install . --confirm-level=unsafe-yes --deps-only --with-test 47 47 + - name: test 48 48 + command: | 49 49 + opam exec -- dune runtest --verbose 50 50 + - name: doc 51 51 + command: | 52 52 + opam install -y odoc 53 53 + opam exec -- dune build @doc

+15

LICENSE.md

··· 1 1 + ISC License 2 2 + 3 3 + Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org> 4 4 + 5 5 + Permission to use, copy, modify, and distribute this software for any 6 6 + purpose with or without fee is hereby granted, provided that the above 7 7 + copyright notice and this permission notice appear in all copies. 8 8 + 9 9 + THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 10 10 + WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 11 11 + MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 12 12 + ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 13 13 + WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 14 14 + ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 15 15 + OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.

+54

README.md

··· 1 1 + # ocaml-jmap - JMAP Protocol Implementation for OCaml 2 2 + 3 3 + A complete implementation of the JSON Meta Application Protocol (JMAP) as specified in RFC 8620 (core) and RFC 8621 (mail). 4 4 + 5 5 + ## Packages 6 6 + 7 7 + - **jmap** - Core JMAP protocol types and serialization 8 8 + - **jmap-eio** - JMAP client using Eio for async I/O 9 9 + - **jmap-brr** - JMAP client for browsers using js_of_ocaml 10 10 + 11 11 + ## Key Features 12 12 + 13 13 + - Full RFC 8620 (JMAP Core) support: sessions, accounts, method calls, and error handling 14 14 + - Full RFC 8621 (JMAP Mail) support: mailboxes, emails, threads, identities, and submissions 15 15 + - Type-safe API with comprehensive type definitions 16 16 + - Multiple backends: Eio for native async, Brr for browser-based clients 17 17 + - JSON serialization via jsont 18 18 + 19 19 + ## Usage 20 20 + 21 21 + ```ocaml 22 22 + (* Query emails from a mailbox *) 23 23 + open Jmap 24 24 + 25 25 + let query_emails ~client ~account_id ~mailbox_id = 26 26 + let filter = Email.Query.Filter.(in_mailbox mailbox_id) in 27 27 + let query = Email.Query.make ~account_id ~filter () in 28 28 + Client.call client query 29 29 + ``` 30 30 + 31 31 + ## Installation 32 32 + 33 33 + ``` 34 34 + opam install jmap jmap-eio 35 35 + ``` 36 36 + 37 37 + For browser-based applications: 38 38 + 39 39 + ``` 40 40 + opam install jmap jmap-brr 41 41 + ``` 42 42 + 43 43 + ## Documentation 44 44 + 45 45 + API documentation is available via: 46 46 + 47 47 + ``` 48 48 + opam install jmap 49 49 + odig doc jmap 50 50 + ``` 51 51 + 52 52 + ## License 53 53 + 54 54 + ISC

+11 -2

bin/dune

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

+841 -38

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 ··· 716 782 let info = Cmd.info "identities" ~doc in 717 783 Cmd.v info Term.(const run $ Jmap_eio.Cli.config_term) 718 784 785 785 + (** {1 Chained Commands - Using the Chain monad} *) 786 786 + 787 787 + (** Inbox command - demonstrates simple query+get chain *) 788 788 + let inbox_cmd = 789 789 + let limit_term = 790 790 + let doc = "Maximum number of emails to show" in 791 791 + Arg.(value & opt int 20 & info ["limit"; "n"] ~docv:"N" ~doc) 792 792 + in 793 793 + let run cfg limit = 794 794 + Eio_main.run @@ fun env -> 795 795 + Eio.Switch.run @@ fun sw -> 796 796 + let client = Jmap_eio.Cli.create_client ~sw env cfg in 797 797 + let account_id = Jmap_eio.Cli.get_account_id cfg client in 798 798 + 799 799 + Jmap_eio.Cli.debug cfg "Fetching inbox emails using Chain API"; 800 800 + 801 801 + (* Find inbox mailbox first *) 802 802 + let mbox_req = Jmap_eio.Client.Build.( 803 803 + make_request 804 804 + ~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail] 805 805 + [mailbox_get ~call_id:"m1" ~account_id ()] 806 806 + ) in 807 807 + 808 808 + match Jmap_eio.Client.request client mbox_req with 809 809 + | Error e -> 810 810 + Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e); 811 811 + exit 1 812 812 + | Ok mbox_response -> 813 813 + match Jmap_eio.Client.Parse.parse_mailbox_get ~call_id:"m1" mbox_response with 814 814 + | Error e -> 815 815 + Fmt.epr "Parse error: %s@." (Jsont.Error.to_string e); 816 816 + exit 1 817 817 + | Ok mbox_result -> 818 818 + (* Find inbox *) 819 819 + let inbox = 820 820 + List.find_opt (fun (m : Jmap.Proto.Mailbox.t) -> 821 821 + m.role = Some `Inbox 822 822 + ) mbox_result.list 823 823 + in 824 824 + match inbox with 825 825 + | None -> 826 826 + Fmt.epr "No inbox found@."; 827 827 + exit 1 828 828 + | Some inbox -> 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); 836 836 + 837 837 + (* Now use Chain API to query and get emails in one request *) 838 838 + let open Jmap_eio.Chain in 839 839 + let filter_cond : Jmap.Proto.Email.Filter_condition.t = { 840 840 + in_mailbox = Some inbox_id; 841 841 + in_mailbox_other_than = None; 842 842 + before = None; after = None; 843 843 + min_size = None; max_size = None; 844 844 + all_in_thread_have_keyword = None; 845 845 + some_in_thread_have_keyword = None; 846 846 + none_in_thread_have_keyword = None; 847 847 + has_keyword = None; not_keyword = None; 848 848 + has_attachment = None; 849 849 + text = None; from = None; to_ = None; 850 850 + cc = None; bcc = None; subject = None; 851 851 + body = None; header = None; 852 852 + } in 853 853 + let sort = [Jmap.Proto.Filter.comparator ~is_ascending:false "receivedAt"] in 854 854 + 855 855 + let request, email_handle = build 856 856 + ~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail] 857 857 + begin 858 858 + let* query = email_query ~account_id 859 859 + ~filter:(Jmap.Proto.Filter.Condition filter_cond) 860 860 + ~sort 861 861 + ~limit:(Int64.of_int limit) 862 862 + () 863 863 + in 864 864 + let* emails = email_get ~account_id 865 865 + ~ids:(from_query query) 866 866 + ~properties:["id"; "blobId"; "threadId"; "mailboxIds"; "size"; "receivedAt"; "subject"; "from"; "preview"; "keywords"] 867 867 + () 868 868 + in 869 869 + return emails 870 870 + end in 871 871 + 872 872 + Jmap_eio.Cli.debug cfg "Sending chained request (query + get in one round trip)"; 873 873 + 874 874 + match Jmap_eio.Client.request client request with 875 875 + | Error e -> 876 876 + Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e); 877 877 + exit 1 878 878 + | Ok response -> 879 879 + match parse email_handle response with 880 880 + | Error e -> 881 881 + Fmt.epr "Parse error: %s@." (Jsont.Error.to_string e); 882 882 + exit 1 883 883 + | Ok result -> 884 884 + Fmt.pr "@[<v>%a (%d emails in inbox)@,@," 885 885 + Fmt.(styled `Bold string) "Inbox" 886 886 + (List.length result.list); 887 887 + List.iter (fun (email : Jmap.Proto.Email.t) -> 888 888 + let from_str = match email.from with 889 889 + | Some (addr :: _) -> 890 890 + Option.value addr.name ~default:addr.email 891 891 + | _ -> "?" 892 892 + in 893 893 + let subject = Option.value email.subject ~default:"(no subject)" in 894 894 + let flags = format_keywords (email_keywords email) in 895 895 + Fmt.pr " %a %s@," 896 896 + Fmt.(styled `Cyan string) (email_id email) 897 897 + (email_received_at email); 898 898 + Fmt.pr " From: %s@," (truncate_string 40 from_str); 899 899 + Fmt.pr " Subject: %a%s@," 900 900 + Fmt.(styled `White string) (truncate_string 50 subject) 901 901 + (if flags = "" then "" else " [" ^ flags ^ "]"); 902 902 + Fmt.pr "@," 903 903 + ) result.list; 904 904 + Fmt.pr "@]@." 905 905 + in 906 906 + let doc = "List inbox emails (uses Chain API for query+get in single request)" in 907 907 + let info = Cmd.info "inbox" ~doc in 908 908 + Cmd.v info Term.(const run $ Jmap_eio.Cli.config_term $ limit_term) 909 909 + 910 910 + (** Thread-view command - demonstrates multi-step chaining (RFC 8620 example) *) 911 911 + let thread_view_cmd = 912 912 + let limit_term = 913 913 + let doc = "Number of threads to show" in 914 914 + Arg.(value & opt int 10 & info ["limit"; "n"] ~docv:"N" ~doc) 915 915 + in 916 916 + let run cfg limit = 917 917 + Eio_main.run @@ fun env -> 918 918 + Eio.Switch.run @@ fun sw -> 919 919 + let client = Jmap_eio.Cli.create_client ~sw env cfg in 920 920 + let account_id = Jmap_eio.Cli.get_account_id cfg client in 921 921 + 922 922 + Jmap_eio.Cli.debug cfg "Fetching threaded view using multi-step Chain API"; 923 923 + 924 924 + (* 925 925 + This implements the RFC 8620 example: 926 926 + 1. Email/query with collapseThreads to get one email per thread 927 927 + 2. Email/get to fetch threadId for each 928 928 + 3. Thread/get to fetch all emailIds in each thread 929 929 + 4. Email/get to fetch details for all emails in those threads 930 930 + *) 931 931 + let open Jmap_eio.Chain in 932 932 + let sort = [Jmap.Proto.Filter.comparator ~is_ascending:false "receivedAt"] in 933 933 + 934 934 + let request, (query_h, final_emails_h) = build 935 935 + ~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail] 936 936 + begin 937 937 + (* Step 1: Query for recent emails, collapsing threads *) 938 938 + let* query = email_query ~account_id 939 939 + ~sort 940 940 + ~collapse_threads:true 941 941 + ~limit:(Int64.of_int limit) 942 942 + () 943 943 + in 944 944 + (* Step 2: Get just threadId for those emails *) 945 945 + let* emails1 = email_get ~account_id 946 946 + ~ids:(from_query query) 947 947 + ~properties:["id"; "blobId"; "threadId"; "mailboxIds"; "size"; "receivedAt"] 948 948 + () 949 949 + in 950 950 + (* Step 3: Get threads using threadIds from step 2 *) 951 951 + let* threads = thread_get ~account_id 952 952 + ~ids:(from_get_field emails1 "threadId") 953 953 + () 954 954 + in 955 955 + (* Step 4: Get all emails in those threads *) 956 956 + let* emails2 = email_get ~account_id 957 957 + ~ids:(from_get_field threads "emailIds") 958 958 + ~properties:["id"; "blobId"; "threadId"; "mailboxIds"; "size"; "receivedAt"; "subject"; "from"; "preview"] 959 959 + () 960 960 + in 961 961 + return (query, emails2) 962 962 + end in 963 963 + 964 964 + Jmap_eio.Cli.debug cfg "Sending 4-step chained request in single round trip"; 965 965 + 966 966 + match Jmap_eio.Client.request client request with 967 967 + | Error e -> 968 968 + Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e); 969 969 + exit 1 970 970 + | Ok response -> 971 971 + let query_result = parse_exn query_h response in 972 972 + let emails_result = parse_exn final_emails_h response in 973 973 + 974 974 + (* Group emails by thread *) 975 975 + let threads_map = Hashtbl.create 16 in 976 976 + List.iter (fun (email : Jmap.Proto.Email.t) -> 977 977 + let tid = email_thread_id email in 978 978 + let existing = try Hashtbl.find threads_map tid with Not_found -> [] in 979 979 + Hashtbl.replace threads_map tid (email :: existing) 980 980 + ) emails_result.list; 981 981 + 982 982 + Fmt.pr "@[<v>%a (%d threads, %d total emails)@,@," 983 983 + Fmt.(styled `Bold string) "Threaded View" 984 984 + (Hashtbl.length threads_map) 985 985 + (List.length emails_result.list); 986 986 + Fmt.pr "Query found %s total matching emails@,@," 987 987 + (match query_result.total with Some n -> Int64.to_string n | None -> "?"); 988 988 + 989 989 + (* Print threads *) 990 990 + Hashtbl.iter (fun _tid emails -> 991 991 + let emails = List.sort (fun (a : Jmap.Proto.Email.t) (b : Jmap.Proto.Email.t) -> 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 995 995 + ) emails in 996 996 + let first_email = List.hd emails in 997 997 + let subject = Option.value first_email.subject ~default:"(no subject)" in 998 998 + Fmt.pr " %a Thread: %s (%d emails)@," 999 999 + Fmt.(styled `Bold string) "▸" 1000 1000 + (truncate_string 50 subject) 1001 1001 + (List.length emails); 1002 1002 + List.iter (fun (email : Jmap.Proto.Email.t) -> 1003 1003 + let from_str = match email.from with 1004 1004 + | Some (addr :: _) -> Option.value addr.name ~default:addr.email 1005 1005 + | _ -> "?" 1006 1006 + in 1007 1007 + Fmt.pr " %s %s %s@," 1008 1008 + (email_id email |> truncate_string 12) 1009 1009 + (email_received_at email) 1010 1010 + (truncate_string 30 from_str) 1011 1011 + ) emails; 1012 1012 + Fmt.pr "@," 1013 1013 + ) threads_map; 1014 1014 + Fmt.pr "@]@." 1015 1015 + in 1016 1016 + let doc = "Show threaded view (demonstrates RFC 8620 multi-step chain)" in 1017 1017 + let info = Cmd.info "thread-view" ~doc in 1018 1018 + Cmd.v info Term.(const run $ Jmap_eio.Cli.config_term $ limit_term) 1019 1019 + 1020 1020 + (** Mark-read command - demonstrates email_set for updating keywords *) 1021 1021 + let mark_read_cmd = 1022 1022 + let email_id_term = 1023 1023 + let doc = "Email ID to mark as read" in 1024 1024 + Arg.(required & pos 0 (some string) None & info [] ~docv:"EMAIL_ID" ~doc) 1025 1025 + in 1026 1026 + let unread_term = 1027 1027 + let doc = "Mark as unread instead of read" in 1028 1028 + Arg.(value & flag & info ["unread"; "u"] ~doc) 1029 1029 + in 1030 1030 + let run cfg email_id_str unread = 1031 1031 + Eio_main.run @@ fun env -> 1032 1032 + Eio.Switch.run @@ fun sw -> 1033 1033 + let client = Jmap_eio.Cli.create_client ~sw env cfg in 1034 1034 + let account_id = Jmap_eio.Cli.get_account_id cfg client in 1035 1035 + let email_id = Jmap.Proto.Id.of_string_exn email_id_str in 1036 1036 + 1037 1037 + Jmap_eio.Cli.debug cfg "%s email %s" 1038 1038 + (if unread then "Marking as unread" else "Marking as read") 1039 1039 + email_id_str; 1040 1040 + 1041 1041 + (* Build the patch object - set or unset $seen keyword *) 1042 1042 + let patch = 1043 1043 + let open Jmap_eio.Chain in 1044 1044 + if unread then 1045 1045 + json_obj [("keywords/$seen", json_null)] 1046 1046 + else 1047 1047 + json_obj [("keywords/$seen", json_bool true)] 1048 1048 + in 1049 1049 + 1050 1050 + let open Jmap_eio.Chain in 1051 1051 + let request, set_h = build 1052 1052 + ~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail] 1053 1053 + begin 1054 1054 + email_set ~account_id 1055 1055 + ~update:[(email_id, patch)] 1056 1056 + () 1057 1057 + end in 1058 1058 + 1059 1059 + match Jmap_eio.Client.request client request with 1060 1060 + | Error e -> 1061 1061 + Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e); 1062 1062 + exit 1 1063 1063 + | Ok response -> 1064 1064 + match parse set_h response with 1065 1065 + | Error e -> 1066 1066 + Fmt.epr "Parse error: %s@." (Jsont.Error.to_string e); 1067 1067 + exit 1 1068 1068 + | Ok result -> 1069 1069 + (* Check if update succeeded *) 1070 1070 + let updated_ids = 1071 1071 + result.updated 1072 1072 + |> Option.value ~default:[] 1073 1073 + |> List.map (fun (id, _) -> Jmap.Proto.Id.to_string id) 1074 1074 + in 1075 1075 + if List.mem email_id_str updated_ids then 1076 1076 + Fmt.pr "Email %s marked as %s@." 1077 1077 + email_id_str 1078 1078 + (if unread then "unread" else "read") 1079 1079 + else ( 1080 1080 + Fmt.epr "Failed to update email. "; 1081 1081 + let not_updated = Option.value ~default:[] result.not_updated in 1082 1082 + (match List.find_opt (fun (id, _) -> Jmap.Proto.Id.to_string id = email_id_str) not_updated with 1083 1083 + | Some (_, err) -> 1084 1084 + let open Jmap.Proto.Error in 1085 1085 + let err_type = set_error_type_to_string err.type_ in 1086 1086 + let err_desc = Option.value ~default:"" err.description in 1087 1087 + Fmt.epr "Error: %s (%s)@." err_type err_desc 1088 1088 + | None -> 1089 1089 + Fmt.epr "Unknown error@."); 1090 1090 + exit 1 1091 1091 + ) 1092 1092 + in 1093 1093 + let doc = "Mark an email as read/unread (demonstrates Email/set)" in 1094 1094 + let info = Cmd.info "mark-read" ~doc in 1095 1095 + Cmd.v info Term.(const run $ Jmap_eio.Cli.config_term $ email_id_term $ unread_term) 1096 1096 + 1097 1097 + (** Delete email command - demonstrates email_set destroy *) 1098 1098 + let delete_email_cmd = 1099 1099 + let email_ids_term = 1100 1100 + let doc = "Email IDs to delete" in 1101 1101 + Arg.(non_empty & pos_all string [] & info [] ~docv:"EMAIL_ID" ~doc) 1102 1102 + in 1103 1103 + let run cfg email_id_strs = 1104 1104 + Eio_main.run @@ fun env -> 1105 1105 + Eio.Switch.run @@ fun sw -> 1106 1106 + let client = Jmap_eio.Cli.create_client ~sw env cfg in 1107 1107 + let account_id = Jmap_eio.Cli.get_account_id cfg client in 1108 1108 + let email_ids = List.map Jmap.Proto.Id.of_string_exn email_id_strs in 1109 1109 + 1110 1110 + Jmap_eio.Cli.debug cfg "Deleting %d email(s)" (List.length email_ids); 1111 1111 + 1112 1112 + let open Jmap_eio.Chain in 1113 1113 + let request, set_h = build 1114 1114 + ~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail] 1115 1115 + begin 1116 1116 + email_set ~account_id 1117 1117 + ~destroy:(ids email_ids) 1118 1118 + () 1119 1119 + end in 1120 1120 + 1121 1121 + match Jmap_eio.Client.request client request with 1122 1122 + | Error e -> 1123 1123 + Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e); 1124 1124 + exit 1 1125 1125 + | Ok response -> 1126 1126 + match parse set_h response with 1127 1127 + | Error e -> 1128 1128 + Fmt.epr "Parse error: %s@." (Jsont.Error.to_string e); 1129 1129 + exit 1 1130 1130 + | Ok result -> 1131 1131 + let destroyed = Option.value ~default:[] result.destroyed in 1132 1132 + let destroyed_ids = List.map Jmap.Proto.Id.to_string destroyed in 1133 1133 + Fmt.pr "Deleted %d email(s):@." (List.length destroyed_ids); 1134 1134 + List.iter (fun id -> Fmt.pr " %s@." id) destroyed_ids; 1135 1135 + (* Report any failures *) 1136 1136 + let not_destroyed = Option.value ~default:[] result.not_destroyed in 1137 1137 + if not_destroyed <> [] then begin 1138 1138 + Fmt.epr "Failed to delete %d email(s):@." (List.length not_destroyed); 1139 1139 + List.iter (fun (id, err) -> 1140 1140 + let open Jmap.Proto.Error in 1141 1141 + let err_type = set_error_type_to_string err.type_ in 1142 1142 + Fmt.epr " %s: %s@." 1143 1143 + (Jmap.Proto.Id.to_string id) 1144 1144 + err_type 1145 1145 + ) not_destroyed 1146 1146 + end 1147 1147 + in 1148 1148 + let doc = "Delete emails (demonstrates Email/set destroy)" in 1149 1149 + let info = Cmd.info "delete" ~doc in 1150 1150 + Cmd.v info Term.(const run $ Jmap_eio.Cli.config_term $ email_ids_term) 1151 1151 + 1152 1152 + (** Changes command - demonstrates email_changes for sync *) 1153 1153 + let changes_cmd = 1154 1154 + let state_term = 1155 1155 + let doc = "State to get changes since (use 'current' to just show current state)" in 1156 1156 + Arg.(required & pos 0 (some string) None & info [] ~docv:"STATE" ~doc) 1157 1157 + in 1158 1158 + let run cfg state_str = 1159 1159 + Eio_main.run @@ fun env -> 1160 1160 + Eio.Switch.run @@ fun sw -> 1161 1161 + let client = Jmap_eio.Cli.create_client ~sw env cfg in 1162 1162 + let account_id = Jmap_eio.Cli.get_account_id cfg client in 1163 1163 + 1164 1164 + if state_str = "current" then ( 1165 1165 + (* Just get current state by doing a minimal query *) 1166 1166 + let open Jmap_eio.Chain in 1167 1167 + let request, get_h = build 1168 1168 + ~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail] 1169 1169 + begin 1170 1170 + (* Get empty list just to see state *) 1171 1171 + email_get ~account_id ~ids:(ids []) () 1172 1172 + end in 1173 1173 + 1174 1174 + match Jmap_eio.Client.request client request with 1175 1175 + | Error e -> 1176 1176 + Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e); 1177 1177 + exit 1 1178 1178 + | Ok response -> 1179 1179 + match parse get_h response with 1180 1180 + | Error e -> 1181 1181 + Fmt.epr "Parse error: %s@." (Jsont.Error.to_string e); 1182 1182 + exit 1 1183 1183 + | Ok result -> 1184 1184 + Fmt.pr "Current email state: %a@." 1185 1185 + Fmt.(styled `Cyan string) result.state 1186 1186 + ) else ( 1187 1187 + Jmap_eio.Cli.debug cfg "Getting changes since state: %s" state_str; 1188 1188 + 1189 1189 + let open Jmap_eio.Chain in 1190 1190 + let request, changes_h = build 1191 1191 + ~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail] 1192 1192 + begin 1193 1193 + email_changes ~account_id ~since_state:state_str () 1194 1194 + end in 1195 1195 + 1196 1196 + match Jmap_eio.Client.request client request with 1197 1197 + | Error e -> 1198 1198 + Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e); 1199 1199 + exit 1 1200 1200 + | Ok response -> 1201 1201 + match parse changes_h response with 1202 1202 + | Error e -> 1203 1203 + Fmt.epr "Parse error: %s@." (Jsont.Error.to_string e); 1204 1204 + exit 1 1205 1205 + | Ok result -> 1206 1206 + Fmt.pr "@[<v>%a@,@," 1207 1207 + Fmt.(styled `Bold string) "Email Changes"; 1208 1208 + Fmt.pr "Old state: %s@," result.old_state; 1209 1209 + Fmt.pr "New state: %a@," Fmt.(styled `Cyan string) result.new_state; 1210 1210 + Fmt.pr "Has more changes: %b@,@," result.has_more_changes; 1211 1211 + Fmt.pr "Created: %d email(s)@," (List.length result.created); 1212 1212 + List.iter (fun id -> 1213 1213 + Fmt.pr " + %s@," (Jmap.Proto.Id.to_string id) 1214 1214 + ) result.created; 1215 1215 + Fmt.pr "Updated: %d email(s)@," (List.length result.updated); 1216 1216 + List.iter (fun id -> 1217 1217 + Fmt.pr " ~ %s@," (Jmap.Proto.Id.to_string id) 1218 1218 + ) result.updated; 1219 1219 + Fmt.pr "Destroyed: %d email(s)@," (List.length result.destroyed); 1220 1220 + List.iter (fun id -> 1221 1221 + Fmt.pr " - %s@," (Jmap.Proto.Id.to_string id) 1222 1222 + ) result.destroyed; 1223 1223 + Fmt.pr "@]@." 1224 1224 + ) 1225 1225 + in 1226 1226 + let doc = "Show email changes since a state (demonstrates Email/changes)" in 1227 1227 + let info = Cmd.info "changes" ~doc in 1228 1228 + Cmd.v info Term.(const run $ Jmap_eio.Cli.config_term $ state_term) 1229 1229 + 1230 1230 + (** Sync command - demonstrates changes + get pattern for incremental sync *) 1231 1231 + let sync_cmd = 1232 1232 + let state_term = 1233 1233 + let doc = "State to sync from" in 1234 1234 + Arg.(required & pos 0 (some string) None & info [] ~docv:"STATE" ~doc) 1235 1235 + in 1236 1236 + let run cfg state_str = 1237 1237 + Eio_main.run @@ fun env -> 1238 1238 + Eio.Switch.run @@ fun sw -> 1239 1239 + let client = Jmap_eio.Cli.create_client ~sw env cfg in 1240 1240 + let account_id = Jmap_eio.Cli.get_account_id cfg client in 1241 1241 + 1242 1242 + Jmap_eio.Cli.debug cfg "Syncing from state: %s" state_str; 1243 1243 + 1244 1244 + (* Chain: changes → get created → get updated *) 1245 1245 + let open Jmap_eio.Chain in 1246 1246 + let request, (changes_h, created_h, updated_h) = build 1247 1247 + ~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail] 1248 1248 + begin 1249 1249 + let* changes = email_changes ~account_id ~since_state:state_str () in 1250 1250 + let* created = email_get ~account_id 1251 1251 + ~ids:(from_changes_created changes) 1252 1252 + ~properties:["id"; "blobId"; "threadId"; "mailboxIds"; "size"; "receivedAt"; "subject"; "from"; "preview"] 1253 1253 + () 1254 1254 + in 1255 1255 + let* updated = email_get ~account_id 1256 1256 + ~ids:(from_changes_updated changes) 1257 1257 + ~properties:["id"; "blobId"; "threadId"; "mailboxIds"; "size"; "receivedAt"; "subject"; "from"; "keywords"] 1258 1258 + () 1259 1259 + in 1260 1260 + return (changes, created, updated) 1261 1261 + end in 1262 1262 + 1263 1263 + Jmap_eio.Cli.debug cfg "Sending chained sync request"; 1264 1264 + 1265 1265 + match Jmap_eio.Client.request client request with 1266 1266 + | Error e -> 1267 1267 + Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e); 1268 1268 + exit 1 1269 1269 + | Ok response -> 1270 1270 + let changes_result = parse_exn changes_h response in 1271 1271 + let created_result = parse_exn created_h response in 1272 1272 + let updated_result = parse_exn updated_h response in 1273 1273 + 1274 1274 + Fmt.pr "@[<v>%a (state: %s → %s)@,@," 1275 1275 + Fmt.(styled `Bold string) "Sync Results" 1276 1276 + changes_result.old_state 1277 1277 + changes_result.new_state; 1278 1278 + 1279 1279 + if List.length created_result.list > 0 then begin 1280 1280 + Fmt.pr "%a (%d)@," 1281 1281 + Fmt.(styled `Green string) "New emails" 1282 1282 + (List.length created_result.list); 1283 1283 + List.iter (fun (email : Jmap.Proto.Email.t) -> 1284 1284 + let from_str = match email.from with 1285 1285 + | Some (addr :: _) -> Option.value addr.name ~default:addr.email 1286 1286 + | _ -> "?" 1287 1287 + in 1288 1288 + let subject = Option.value email.subject ~default:"(no subject)" in 1289 1289 + Fmt.pr " + %s %s %s@," 1290 1290 + (email_id email |> truncate_string 12) 1291 1291 + (truncate_string 20 from_str) 1292 1292 + (truncate_string 40 subject) 1293 1293 + ) created_result.list; 1294 1294 + Fmt.pr "@," 1295 1295 + end; 1296 1296 + 1297 1297 + if List.length updated_result.list > 0 then begin 1298 1298 + Fmt.pr "%a (%d)@," 1299 1299 + Fmt.(styled `Yellow string) "Updated emails" 1300 1300 + (List.length updated_result.list); 1301 1301 + List.iter (fun (email : Jmap.Proto.Email.t) -> 1302 1302 + let flags = format_keywords (email_keywords email) in 1303 1303 + Fmt.pr " ~ %s [%s]@," 1304 1304 + (email_id email |> truncate_string 12) 1305 1305 + flags 1306 1306 + ) updated_result.list; 1307 1307 + Fmt.pr "@," 1308 1308 + end; 1309 1309 + 1310 1310 + if List.length changes_result.destroyed > 0 then begin 1311 1311 + Fmt.pr "%a (%d)@," 1312 1312 + Fmt.(styled `Red string) "Deleted emails" 1313 1313 + (List.length changes_result.destroyed); 1314 1314 + List.iter (fun id -> 1315 1315 + Fmt.pr " - %s@," (Jmap.Proto.Id.to_string id) 1316 1316 + ) changes_result.destroyed; 1317 1317 + Fmt.pr "@," 1318 1318 + end; 1319 1319 + 1320 1320 + if changes_result.has_more_changes then 1321 1321 + Fmt.pr "%a - call sync again with state %s@," 1322 1322 + Fmt.(styled `Bold string) "More changes available" 1323 1323 + changes_result.new_state; 1324 1324 + 1325 1325 + Fmt.pr "@]@." 1326 1326 + in 1327 1327 + let doc = "Incremental sync (demonstrates changes + get chain)" in 1328 1328 + let info = Cmd.info "sync" ~doc in 1329 1329 + Cmd.v info Term.(const run $ Jmap_eio.Cli.config_term $ state_term) 1330 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 + 719 1514 (** {1 Main Command Group} *) 720 1515 721 1516 let main_cmd = ··· 742 1537 recent_cmd; 743 1538 threads_cmd; 744 1539 identities_cmd; 1540 1540 + headers_cmd; 1541 1541 + (* Chain API examples *) 1542 1542 + inbox_cmd; 1543 1543 + thread_view_cmd; 1544 1544 + mark_read_cmd; 1545 1545 + delete_email_cmd; 1546 1546 + changes_cmd; 1547 1547 + sync_cmd; 745 1548 ] 746 1549 747 1550 let () =

+662

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 verbose_term = 312 312 + let doc = "Show the raw JMAP server response" in 313 313 + Arg.(value & flag & info ["v"; "verbose"] ~doc) 314 314 + in 315 315 + let run cfg verbose email_id_strs = 316 316 + Eio_main.run @@ fun env -> 317 317 + Eio.Switch.run @@ fun sw -> 318 318 + let client = Jmap_eio.Cli.create_client ~sw env cfg in 319 319 + let account_id = Jmap_eio.Cli.get_account_id cfg client in 320 320 + let email_ids = List.map Jmap.Proto.Id.of_string_exn email_id_strs in 321 321 + 322 322 + Jmap_eio.Cli.debug cfg "Marking %d email(s) with '%s' keyword" 323 323 + (List.length email_ids) zulip_processed_keyword; 324 324 + 325 325 + (* Build patch to add the zulip-processed keyword and mark as read *) 326 326 + let patch = 327 327 + let open Jmap_eio.Chain in 328 328 + json_obj [ 329 329 + ("keywords/" ^ zulip_processed_keyword, json_bool true); 330 330 + ("keywords/$seen", json_bool true); 331 331 + ] 332 332 + in 333 333 + 334 334 + (* Build updates list: each email ID gets the same patch *) 335 335 + let updates = List.map (fun id -> (id, patch)) email_ids in 336 336 + 337 337 + let open Jmap_eio.Chain in 338 338 + let request, set_h = build 339 339 + ~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail] 340 340 + begin 341 341 + email_set ~account_id 342 342 + ~update:updates 343 343 + () 344 344 + end in 345 345 + 346 346 + match Jmap_eio.Client.request client request with 347 347 + | Error e -> 348 348 + Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e); 349 349 + exit 1 350 350 + | Ok response -> 351 351 + (* Print raw response if verbose *) 352 352 + if verbose then begin 353 353 + Fmt.pr "@[<v>%a:@," Fmt.(styled `Bold string) "Server Response"; 354 354 + (match Jsont_bytesrw.encode_string' ~format:Jsont.Indent 355 355 + Jmap.Proto.Response.jsont response with 356 356 + | Ok json_str -> Fmt.pr "%s@,@]@." json_str 357 357 + | Error e -> Fmt.epr "JSON encoding error: %s@." (Jsont.Error.to_string e)) 358 358 + end; 359 359 + (* Check for JMAP method-level errors first *) 360 360 + let call_id = Jmap_eio.Chain.call_id set_h in 361 361 + (match Jmap.Proto.Response.find_response call_id response with 362 362 + | None -> 363 363 + Fmt.epr "Error: No response found for call_id %s@." call_id; 364 364 + exit 1 365 365 + | Some inv when Jmap.Proto.Response.is_error inv -> 366 366 + (match Jmap.Proto.Response.get_error inv with 367 367 + | Some err -> 368 368 + Fmt.epr "JMAP Error: %s%s@." 369 369 + (Jmap.Proto.Error.method_error_type_to_string err.type_) 370 370 + (match err.description with Some d -> " - " ^ d | None -> ""); 371 371 + exit 1 372 372 + | None -> 373 373 + Fmt.epr "JMAP Error: Unknown error@."; 374 374 + exit 1) 375 375 + | Some _ -> 376 376 + match parse set_h response with 377 377 + | Error e -> 378 378 + Fmt.epr "Parse error: %s@." (Jsont.Error.to_string e); 379 379 + exit 1 380 380 + | Ok result -> 381 381 + (* Report successes *) 382 382 + let updated_ids = 383 383 + result.updated 384 384 + |> Option.value ~default:[] 385 385 + |> List.map (fun (id, _) -> Jmap.Proto.Id.to_string id) 386 386 + in 387 387 + if List.length updated_ids > 0 then begin 388 388 + Fmt.pr "@[<v>%a %d email(s) as read with '%s':@," 389 389 + Fmt.(styled `Green string) "Marked" 390 390 + (List.length updated_ids) 391 391 + zulip_processed_keyword; 392 392 + List.iter (fun id -> Fmt.pr " %s@," id) updated_ids; 393 393 + Fmt.pr "@]@." 394 394 + end; 395 395 + 396 396 + (* Report failures *) 397 397 + let not_updated = Option.value ~default:[] result.not_updated in 398 398 + if not_updated <> [] then begin 399 399 + Fmt.epr "@[<v>%a to mark %d email(s):@," 400 400 + Fmt.(styled `Red string) "Failed" 401 401 + (List.length not_updated); 402 402 + List.iter (fun (id, err) -> 403 403 + let open Jmap.Proto.Error in 404 404 + let err_type = set_error_type_to_string err.type_ in 405 405 + let err_desc = Option.value ~default:"" err.description in 406 406 + Fmt.epr " %s: %s%s@," 407 407 + (Jmap.Proto.Id.to_string id) 408 408 + err_type 409 409 + (if err_desc = "" then "" else " - " ^ err_desc) 410 410 + ) not_updated; 411 411 + Fmt.epr "@]@."; 412 412 + exit 1 413 413 + end) 414 414 + in 415 415 + let doc = "Mark Zulip notification emails as processed" in 416 416 + let man = [ 417 417 + `S Manpage.s_description; 418 418 + `P (Printf.sprintf "Adds the '%s' keyword to the specified email(s). \ 419 419 + This keyword can be used to filter processed Zulip notifications \ 420 420 + or set up server-side rules to auto-archive them." 421 421 + zulip_processed_keyword); 422 422 + `S Manpage.s_examples; 423 423 + `P "Mark a single email as processed:"; 424 424 + `Pre " jmapq zulip-timeout StrrDTS_WEa3"; 425 425 + `P "Mark multiple emails as processed:"; 426 426 + `Pre " jmapq zulip-timeout StrrDTS_WEa3 StrsGZ7P8Dpc StrsGuCSXJ3Z"; 427 427 + ] in 428 428 + let info = Cmd.info "zulip-timeout" ~doc ~man in 429 429 + Cmd.v info Term.(const run $ Jmap_eio.Cli.config_term $ verbose_term $ email_ids_term) 430 430 + 431 431 + (** {1 Zulip View Command} *) 432 432 + 433 433 + let zulip_view_cmd = 434 434 + let json_term = 435 435 + let doc = "Output as JSON" in 436 436 + Arg.(value & flag & info ["json"] ~doc) 437 437 + in 438 438 + let limit_term = 439 439 + let doc = "Maximum number of messages to fetch (default: all)" in 440 440 + Arg.(value & opt (some int) None & info ["limit"; "n"] ~docv:"N" ~doc) 441 441 + in 442 442 + let verbose_term = 443 443 + let doc = "Show the raw JMAP request and response" in 444 444 + Arg.(value & flag & info ["v"; "verbose"] ~doc) 445 445 + in 446 446 + let run cfg json_output limit verbose = 447 447 + Eio_main.run @@ fun env -> 448 448 + Eio.Switch.run @@ fun sw -> 449 449 + let client = Jmap_eio.Cli.create_client ~sw env cfg in 450 450 + let account_id = Jmap_eio.Cli.get_account_id cfg client in 451 451 + 452 452 + Jmap_eio.Cli.debug cfg "Searching for Zulip emails marked as processed"; 453 453 + 454 454 + (* Build filter for emails from noreply@zulip.com with zulip-processed keyword *) 455 455 + let cond : Jmap.Proto.Email.Filter_condition.t = { 456 456 + in_mailbox = None; in_mailbox_other_than = None; 457 457 + before = None; after = None; 458 458 + min_size = None; max_size = None; 459 459 + all_in_thread_have_keyword = None; 460 460 + some_in_thread_have_keyword = None; 461 461 + none_in_thread_have_keyword = None; 462 462 + has_keyword = Some zulip_processed_keyword; 463 463 + not_keyword = None; 464 464 + has_attachment = None; 465 465 + text = None; 466 466 + from = Some "noreply@zulip.com"; 467 467 + to_ = None; 468 468 + cc = None; bcc = None; subject = None; 469 469 + body = None; header = None; 470 470 + } in 471 471 + let filter = Jmap.Proto.Filter.Condition cond in 472 472 + let sort = [Jmap.Proto.Filter.comparator ~is_ascending:false "receivedAt"] in 473 473 + 474 474 + (* Query for processed Zulip emails *) 475 475 + let query_limit = match limit with 476 476 + | Some n -> Int64.of_int n 477 477 + | None -> Int64.of_int 10000 478 478 + in 479 479 + let query_inv = Jmap_eio.Client.Build.email_query 480 480 + ~call_id:"q1" 481 481 + ~account_id 482 482 + ~filter 483 483 + ~sort 484 484 + ~limit:query_limit 485 485 + () 486 486 + in 487 487 + 488 488 + let req = Jmap_eio.Client.Build.( 489 489 + make_request 490 490 + ~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail] 491 491 + [query_inv] 492 492 + ) in 493 493 + 494 494 + (* Print request if verbose *) 495 495 + if verbose then begin 496 496 + Fmt.pr "@[<v>%a:@," Fmt.(styled `Bold string) "Request"; 497 497 + (match Jsont_bytesrw.encode_string' ~format:Jsont.Indent 498 498 + Jmap.Proto.Request.jsont req with 499 499 + | Ok json_str -> Fmt.pr "%s@,@]@." json_str 500 500 + | Error e -> Fmt.epr "JSON encoding error: %s@." (Jsont.Error.to_string e)) 501 501 + end; 502 502 + 503 503 + match Jmap_eio.Client.request client req with 504 504 + | Error e -> 505 505 + Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e); 506 506 + exit 1 507 507 + | Ok response -> 508 508 + (* Print response if verbose *) 509 509 + if verbose then begin 510 510 + Fmt.pr "@[<v>%a:@," Fmt.(styled `Bold string) "Response"; 511 511 + (match Jsont_bytesrw.encode_string' ~format:Jsont.Indent 512 512 + Jmap.Proto.Response.jsont response with 513 513 + | Ok json_str -> Fmt.pr "%s@,@]@." json_str 514 514 + | Error e -> Fmt.epr "JSON encoding error: %s@." (Jsont.Error.to_string e)) 515 515 + end; 516 516 + match Jmap_eio.Client.Parse.parse_email_query ~call_id:"q1" response with 517 517 + | Error e -> 518 518 + Fmt.epr "Parse error: %s@." (Jsont.Error.to_string e); 519 519 + exit 1 520 520 + | Ok query_result -> 521 521 + let email_ids = query_result.ids in 522 522 + Jmap_eio.Cli.debug cfg "Found %d processed Zulip email IDs" (List.length email_ids); 523 523 + 524 524 + if List.length email_ids = 0 then ( 525 525 + if json_output then 526 526 + Fmt.pr "[]@." 527 527 + else 528 528 + Fmt.pr "No Zulip emails marked as processed.@." 529 529 + ) else ( 530 530 + (* Fetch email details *) 531 531 + let get_inv = Jmap_eio.Client.Build.email_get 532 532 + ~call_id:"g1" 533 533 + ~account_id 534 534 + ~ids:email_ids 535 535 + ~properties:["id"; "blobId"; "threadId"; "mailboxIds"; "keywords"; 536 536 + "size"; "receivedAt"; "subject"; "from"] 537 537 + () 538 538 + in 539 539 + let req2 = Jmap_eio.Client.Build.( 540 540 + make_request 541 541 + ~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail] 542 542 + [get_inv] 543 543 + ) in 544 544 + 545 545 + match Jmap_eio.Client.request client req2 with 546 546 + | Error e -> 547 547 + Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e); 548 548 + exit 1 549 549 + | Ok response2 -> 550 550 + match Jmap_eio.Client.Parse.parse_email_get ~call_id:"g1" response2 with 551 551 + | Error e -> 552 552 + Fmt.epr "Parse error: %s@." (Jsont.Error.to_string e); 553 553 + exit 1 554 554 + | Ok get_result -> 555 555 + (* Parse Zulip subjects and filter successful parses *) 556 556 + let zulip_messages = 557 557 + get_result.list 558 558 + |> List.filter_map Zulip_message.of_email 559 559 + in 560 560 + 561 561 + Jmap_eio.Cli.debug cfg "Parsed %d Zulip messages from %d emails" 562 562 + (List.length zulip_messages) 563 563 + (List.length get_result.list); 564 564 + 565 565 + if json_output then ( 566 566 + (* Output as JSON *) 567 567 + match Jsont_bytesrw.encode_string' ~format:Jsont.Indent Zulip_message.list_jsont zulip_messages with 568 568 + | Ok json_str -> Fmt.pr "%s@." json_str 569 569 + | Error e -> Fmt.epr "JSON encoding error: %s@." (Jsont.Error.to_string e) 570 570 + ) else ( 571 571 + (* Human-readable output *) 572 572 + Fmt.pr "@[<v>%a (%d messages)@,@," 573 573 + Fmt.(styled `Bold string) "Processed Zulip Notifications" 574 574 + (List.length zulip_messages); 575 575 + 576 576 + (* Group by server, then by channel *) 577 577 + let by_server = Hashtbl.create 8 in 578 578 + List.iter (fun (msg : Zulip_message.t) -> 579 579 + let existing = try Hashtbl.find by_server msg.server with Not_found -> [] in 580 580 + Hashtbl.replace by_server msg.server (msg :: existing) 581 581 + ) zulip_messages; 582 582 + 583 583 + Hashtbl.iter (fun server msgs -> 584 584 + Fmt.pr "%a [%s]@," 585 585 + Fmt.(styled `Bold string) "Server:" 586 586 + server; 587 587 + 588 588 + (* Group by channel within server *) 589 589 + let by_channel = Hashtbl.create 8 in 590 590 + List.iter (fun (msg : Zulip_message.t) -> 591 591 + let existing = try Hashtbl.find by_channel msg.channel with Not_found -> [] in 592 592 + Hashtbl.replace by_channel msg.channel (msg :: existing) 593 593 + ) msgs; 594 594 + 595 595 + Hashtbl.iter (fun channel channel_msgs -> 596 596 + Fmt.pr " %a #%s (%d)@," 597 597 + Fmt.(styled `Cyan string) "Channel:" 598 598 + channel 599 599 + (List.length channel_msgs); 600 600 + 601 601 + (* Sort by date descending *) 602 602 + let sorted = List.sort (fun a b -> 603 603 + Ptime.compare b.Zulip_message.date a.Zulip_message.date 604 604 + ) channel_msgs in 605 605 + 606 606 + List.iter (fun (msg : Zulip_message.t) -> 607 607 + let read_marker = if msg.is_read then " " else "*" in 608 608 + let labels_str = match msg.labels with 609 609 + | [] -> "" 610 610 + | ls -> " [" ^ String.concat ", " ls ^ "]" 611 611 + in 612 612 + Fmt.pr " %s %s %a %s%s@," 613 613 + read_marker 614 614 + (ptime_to_string msg.date) 615 615 + Fmt.(styled `Yellow string) (truncate_string 40 msg.topic) 616 616 + (truncate_string 12 msg.id) 617 617 + labels_str 618 618 + ) sorted; 619 619 + Fmt.pr "@," 620 620 + ) by_channel 621 621 + ) by_server; 622 622 + 623 623 + Fmt.pr "@]@." 624 624 + ) 625 625 + ) 626 626 + in 627 627 + let doc = "List Zulip emails that have been marked as processed" in 628 628 + let man = [ 629 629 + `S Manpage.s_description; 630 630 + `P (Printf.sprintf "Lists all Zulip notification emails that have the '%s' keyword." 631 631 + zulip_processed_keyword); 632 632 + `S Manpage.s_examples; 633 633 + `P "List all processed Zulip notifications:"; 634 634 + `Pre " jmapq zulip-view"; 635 635 + `P "Output as JSON:"; 636 636 + `Pre " jmapq zulip-view --json"; 637 637 + `P "Limit to 50 most recent:"; 638 638 + `Pre " jmapq zulip-view -n 50"; 639 639 + ] in 640 640 + let info = Cmd.info "zulip-view" ~doc ~man in 641 641 + Cmd.v info Term.(const run $ Jmap_eio.Cli.config_term $ json_term $ limit_term $ verbose_term) 642 642 + 643 643 + (** {1 Main Command Group} *) 644 644 + 645 645 + let main_cmd = 646 646 + let doc = "JMAPQ - Specialist JMAP workflow commands" in 647 647 + let man = [ 648 648 + `S Manpage.s_description; 649 649 + `P "A collection of specialist workflow commands for JMAP email processing."; 650 650 + `S Manpage.s_environment; 651 651 + `P Jmap_eio.Cli.env_docs; 652 652 + ] in 653 653 + let info = Cmd.info "jmapq" ~version:"0.1.0" ~doc ~man in 654 654 + Cmd.group info [ 655 655 + zulip_list_cmd; 656 656 + zulip_timeout_cmd; 657 657 + zulip_view_cmd; 658 658 + ] 659 659 + 660 660 + let () = 661 661 + Fmt_tty.setup_std_outputs (); 662 662 + 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}}

+13 -17

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) 6 8 7 7 - (source 8 8 - (github avsm/ocaml-jmap)) 9 9 + (license ISC) 9 10 10 11 (authors "Anil Madhavapeddy <anil@recoil.org>") 11 12 12 13 (maintainers "Anil Madhavapeddy <anil@recoil.org>") 13 14 14 14 - (license ISC) 15 15 + (homepage "https://tangled.org/@anil.recoil.org/ocaml-jmap") 16 16 + 17 17 + (bug_reports "https://tangled.org/@anil.recoil.org/ocaml-jmap/issues") 15 18 16 16 - (documentation https://avsm.github.io/ocaml-jmap) 19 19 + (maintenance_intent "(latest)") 17 20 18 21 (package 19 22 (name jmap) 20 23 (synopsis "JMAP protocol implementation for OCaml") 21 24 (description 22 22 - "A complete implementation of the JSON Meta Application Protocol (JMAP) as specified in RFC 8620 (core) and RFC 8621 (mail).") 25 25 + "A complete implementation of the JSON Meta Application Protocol (JMAP) as specified in RFC 8620 (core) and RFC 8621 (mail). Includes subpackages for Eio (jmap.eio) and browser (jmap.brr) clients.") 23 26 (depends 24 27 (ocaml (>= 5.4.0)) 25 28 (jsont (>= 0.2.0)) 26 29 json-pointer 27 27 - (ptime (>= 1.0.0)))) 28 28 - 29 29 - (package 30 30 - (name jmap-eio) 31 31 - (synopsis "JMAP client for Eio") 32 32 - (description "High-level JMAP client using Eio for async I/O and the Requests HTTP library.") 33 33 - (depends 34 34 - (ocaml (>= 5.4.0)) 35 35 - (jmap (= :version)) 36 36 - (jsont (>= 0.2.0)) 37 37 - eio 38 38 - requests)) 30 30 + (ptime (>= 1.0.0)) 31 31 + (eio :with-test) 32 32 + (requests :with-test) 33 33 + (brr :with-test)) 34 34 + (depopts eio requests brr))

+2 -1

eio/dune

··· 1 1 (library 2 2 (name jmap_eio) 3 3 - (public_name jmap-eio) 3 3 + (public_name jmap.eio) 4 4 + (optional) 4 5 (libraries jmap jsont jsont.bytesrw eio requests uri str cmdliner fmt.tty) 5 6 (modules jmap_eio codec client cli))

+1

eio/jmap_eio.ml

··· 6 6 module Codec = Codec 7 7 module Client = Client 8 8 module Cli = Cli 9 9 + module Chain = Jmap.Chain

+7

eio/jmap_eio.mli

··· 74 74 75 75 (** CLI configuration and cmdliner terms for JMAP tools. *) 76 76 module Cli = Cli 77 77 + 78 78 + (** Method chaining with automatic result references. 79 79 + 80 80 + Provides a monadic interface for building JMAP requests where method 81 81 + calls can reference results from previous calls in the same request. 82 82 + Call IDs are generated automatically. *) 83 83 + module Chain = Jmap.Chain

-36

jmap-eio.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 Eio" 4 4 - description: 5 5 - "High-level JMAP client using Eio for async I/O and the Requests HTTP library." 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 - "eio" 18 18 - "requests" 19 19 - "odoc" {with-doc} 20 20 - ] 21 21 - build: [ 22 22 - ["dune" "subst"] {dev} 23 23 - [ 24 24 - "dune" 25 25 - "build" 26 26 - "-p" 27 27 - name 28 28 - "-j" 29 29 - jobs 30 30 - "@install" 31 31 - "@runtest" {with-test} 32 32 - "@doc" {with-doc} 33 33 - ] 34 34 - ] 35 35 - dev-repo: "git+https://github.com/avsm/ocaml-jmap.git" 36 36 - x-maintenance-intent: ["(latest)"]

+7 -5

jmap.opam

··· 2 2 opam-version: "2.0" 3 3 synopsis: "JMAP protocol implementation for OCaml" 4 4 description: 5 5 - "A complete implementation of the JSON Meta Application Protocol (JMAP) as specified in RFC 8620 (core) and RFC 8621 (mail)." 5 5 + "A complete implementation of the JSON Meta Application Protocol (JMAP) as specified in RFC 8620 (core) and RFC 8621 (mail). Includes subpackages for Eio (jmap.eio) and browser (jmap.brr) clients." 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" 9 9 + homepage: "https://tangled.org/@anil.recoil.org/ocaml-jmap" 10 10 + bug-reports: "https://tangled.org/@anil.recoil.org/ocaml-jmap/issues" 12 11 depends: [ 13 12 "dune" {>= "3.20"} 14 13 "ocaml" {>= "5.4.0"} 15 14 "jsont" {>= "0.2.0"} 16 15 "json-pointer" 17 16 "ptime" {>= "1.0.0"} 17 17 + "eio" {with-test} 18 18 + "requests" {with-test} 19 19 + "brr" {with-test} 18 20 "odoc" {with-doc} 19 21 ] 22 22 + depopts: ["eio" "requests" "brr"] 20 23 build: [ 21 24 ["dune" "subst"] {dev} 22 25 [ ··· 31 34 "@doc" {with-doc} 32 35 ] 33 36 ] 34 34 - dev-repo: "git+https://github.com/avsm/ocaml-jmap.git" 35 37 x-maintenance-intent: ["(latest)"]

+851

lib/core/chain.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 Jmap_proto 7 7 + 8 8 + (* Phantom types for handle kinds *) 9 9 + type query 10 10 + type get 11 11 + type changes 12 12 + type set 13 13 + type query_changes 14 14 + type copy 15 15 + type import 16 16 + type parse 17 17 + 18 18 + (* Internal handle representation with GADT for response type *) 19 19 + type (_, _) handle = 20 20 + | Query_handle : { 21 21 + call_id : string; 22 22 + method_name : string; 23 23 + } -> (query, Method.query_response) handle 24 24 + | Query_changes_handle : { 25 25 + call_id : string; 26 26 + method_name : string; 27 27 + } -> (query_changes, Method.query_changes_response) handle 28 28 + | Email_get_handle : { 29 29 + call_id : string; 30 30 + method_name : string; 31 31 + } -> (get, Email.t Method.get_response) handle 32 32 + | Thread_get_handle : { 33 33 + call_id : string; 34 34 + method_name : string; 35 35 + } -> (get, Thread.t Method.get_response) handle 36 36 + | Mailbox_get_handle : { 37 37 + call_id : string; 38 38 + method_name : string; 39 39 + } -> (get, Mailbox.t Method.get_response) handle 40 40 + | Identity_get_handle : { 41 41 + call_id : string; 42 42 + method_name : string; 43 43 + } -> (get, Identity.t Method.get_response) handle 44 44 + | Submission_get_handle : { 45 45 + call_id : string; 46 46 + method_name : string; 47 47 + } -> (get, Submission.t Method.get_response) handle 48 48 + | Search_snippet_get_handle : { 49 49 + call_id : string; 50 50 + method_name : string; 51 51 + } -> (get, Search_snippet.t Method.get_response) handle 52 52 + | Vacation_get_handle : { 53 53 + call_id : string; 54 54 + method_name : string; 55 55 + } -> (get, Vacation.t Method.get_response) handle 56 56 + | Changes_handle : { 57 57 + call_id : string; 58 58 + method_name : string; 59 59 + } -> (changes, Method.changes_response) handle 60 60 + | Email_set_handle : { 61 61 + call_id : string; 62 62 + method_name : string; 63 63 + } -> (set, Email.t Method.set_response) handle 64 64 + | Mailbox_set_handle : { 65 65 + call_id : string; 66 66 + method_name : string; 67 67 + } -> (set, Mailbox.t Method.set_response) handle 68 68 + | Identity_set_handle : { 69 69 + call_id : string; 70 70 + method_name : string; 71 71 + } -> (set, Identity.t Method.set_response) handle 72 72 + | Submission_set_handle : { 73 73 + call_id : string; 74 74 + method_name : string; 75 75 + } -> (set, Submission.t Method.set_response) handle 76 76 + | Vacation_set_handle : { 77 77 + call_id : string; 78 78 + method_name : string; 79 79 + } -> (set, Vacation.t Method.set_response) handle 80 80 + | Email_copy_handle : { 81 81 + call_id : string; 82 82 + method_name : string; 83 83 + } -> (copy, Email.t Method.copy_response) handle 84 84 + | Raw_handle : { 85 85 + call_id : string; 86 86 + method_name : string; 87 87 + } -> (unit, Jsont.Json.t) handle 88 88 + 89 89 + let call_id : type k r. (k, r) handle -> string = function 90 90 + | Query_handle h -> h.call_id 91 91 + | Query_changes_handle h -> h.call_id 92 92 + | Email_get_handle h -> h.call_id 93 93 + | Thread_get_handle h -> h.call_id 94 94 + | Mailbox_get_handle h -> h.call_id 95 95 + | Identity_get_handle h -> h.call_id 96 96 + | Submission_get_handle h -> h.call_id 97 97 + | Search_snippet_get_handle h -> h.call_id 98 98 + | Vacation_get_handle h -> h.call_id 99 99 + | Changes_handle h -> h.call_id 100 100 + | Email_set_handle h -> h.call_id 101 101 + | Mailbox_set_handle h -> h.call_id 102 102 + | Identity_set_handle h -> h.call_id 103 103 + | Submission_set_handle h -> h.call_id 104 104 + | Vacation_set_handle h -> h.call_id 105 105 + | Email_copy_handle h -> h.call_id 106 106 + | Raw_handle h -> h.call_id 107 107 + 108 108 + let method_name : type k r. (k, r) handle -> string = function 109 109 + | Query_handle h -> h.method_name 110 110 + | Query_changes_handle h -> h.method_name 111 111 + | Email_get_handle h -> h.method_name 112 112 + | Thread_get_handle h -> h.method_name 113 113 + | Mailbox_get_handle h -> h.method_name 114 114 + | Identity_get_handle h -> h.method_name 115 115 + | Submission_get_handle h -> h.method_name 116 116 + | Search_snippet_get_handle h -> h.method_name 117 117 + | Vacation_get_handle h -> h.method_name 118 118 + | Changes_handle h -> h.method_name 119 119 + | Email_set_handle h -> h.method_name 120 120 + | Mailbox_set_handle h -> h.method_name 121 121 + | Identity_set_handle h -> h.method_name 122 122 + | Submission_set_handle h -> h.method_name 123 123 + | Vacation_set_handle h -> h.method_name 124 124 + | Email_copy_handle h -> h.method_name 125 125 + | Raw_handle h -> h.method_name 126 126 + 127 127 + (* Creation IDs *) 128 128 + type 'a create_id = string 129 129 + 130 130 + let created_id cid = Id.of_string_exn ("#" ^ cid) 131 131 + let created_id_of_string s = Id.of_string_exn ("#" ^ s) 132 132 + 133 133 + (* ID sources *) 134 134 + type id_source = 135 135 + | Ids of Id.t list 136 136 + | Ref of Invocation.result_reference 137 137 + 138 138 + let ids lst = Ids lst 139 139 + let id x = Ids [x] 140 140 + 141 141 + let make_ref ~call_id ~method_name ~path = 142 142 + Ref (Invocation.result_reference_of_strings 143 143 + ~result_of:call_id 144 144 + ~name:method_name 145 145 + ~path) 146 146 + 147 147 + let from_query : type r. (query, r) handle -> id_source = fun h -> 148 148 + make_ref ~call_id:(call_id h) ~method_name:(method_name h) ~path:"/ids" 149 149 + 150 150 + let from_get_ids : type r. (get, r) handle -> id_source = fun h -> 151 151 + make_ref ~call_id:(call_id h) ~method_name:(method_name h) ~path:"/list/*/id" 152 152 + 153 153 + let from_get_field : type r. (get, r) handle -> string -> id_source = fun h field -> 154 154 + make_ref ~call_id:(call_id h) ~method_name:(method_name h) 155 155 + ~path:(Printf.sprintf "/list/*/%s" field) 156 156 + 157 157 + let from_changes_created : type r. (changes, r) handle -> id_source = fun h -> 158 158 + make_ref ~call_id:(call_id h) ~method_name:(method_name h) ~path:"/created" 159 159 + 160 160 + let from_changes_updated : type r. (changes, r) handle -> id_source = fun h -> 161 161 + make_ref ~call_id:(call_id h) ~method_name:(method_name h) ~path:"/updated" 162 162 + 163 163 + let from_changes_destroyed : type r. (changes, r) handle -> id_source = fun h -> 164 164 + make_ref ~call_id:(call_id h) ~method_name:(method_name h) ~path:"/destroyed" 165 165 + 166 166 + let from_set_created : type r. (set, r) handle -> id_source = fun h -> 167 167 + make_ref ~call_id:(call_id h) ~method_name:(method_name h) ~path:"/created/*/id" 168 168 + 169 169 + let from_set_updated : type r. (set, r) handle -> id_source = fun h -> 170 170 + make_ref ~call_id:(call_id h) ~method_name:(method_name h) ~path:"/updated" 171 171 + 172 172 + let from_query_changes_removed : type r. (query_changes, r) handle -> id_source = fun h -> 173 173 + make_ref ~call_id:(call_id h) ~method_name:(method_name h) ~path:"/removed" 174 174 + 175 175 + let from_query_changes_added : type r. (query_changes, r) handle -> id_source = fun h -> 176 176 + make_ref ~call_id:(call_id h) ~method_name:(method_name h) ~path:"/added/*/id" 177 177 + 178 178 + let from_copy_created : type r. (copy, r) handle -> id_source = fun h -> 179 179 + make_ref ~call_id:(call_id h) ~method_name:(method_name h) ~path:"/created/*/id" 180 180 + 181 181 + let from_import_created : type r. (import, r) handle -> id_source = fun h -> 182 182 + make_ref ~call_id:(call_id h) ~method_name:(method_name h) ~path:"/created/*/id" 183 183 + 184 184 + (* Chain state *) 185 185 + type state = { 186 186 + mutable next_id : int; 187 187 + mutable next_create_id : int; 188 188 + mutable invocations : Invocation.t list; 189 189 + } 190 190 + 191 191 + (* Chain monad *) 192 192 + type 'a t = state -> 'a 193 193 + 194 194 + let return x _state = x 195 195 + 196 196 + let bind m f state = 197 197 + let a = m state in 198 198 + f a state 199 199 + 200 200 + let map f m state = 201 201 + f (m state) 202 202 + 203 203 + let both a b state = 204 204 + let x = a state in 205 205 + let y = b state in 206 206 + (x, y) 207 207 + 208 208 + let ( let* ) = bind 209 209 + let ( let+ ) m f = map f m 210 210 + let ( and* ) = both 211 211 + let ( and+ ) = both 212 212 + 213 213 + (* Building *) 214 214 + let fresh_call_id state = 215 215 + let id = Printf.sprintf "c%d" state.next_id in 216 216 + state.next_id <- state.next_id + 1; 217 217 + id 218 218 + 219 219 + let fresh_create_id () state = 220 220 + let id = Printf.sprintf "k%d" state.next_create_id in 221 221 + state.next_create_id <- state.next_create_id + 1; 222 222 + id 223 223 + 224 224 + let record_invocation inv state = 225 225 + state.invocations <- inv :: state.invocations 226 226 + 227 227 + let build ~capabilities chain = 228 228 + let state = { next_id = 0; next_create_id = 0; invocations = [] } in 229 229 + let result = chain state in 230 230 + let request = Request.create 231 231 + ~using:capabilities 232 232 + ~method_calls:(List.rev state.invocations) 233 233 + () 234 234 + in 235 235 + (request, result) 236 236 + 237 237 + let build_request ~capabilities chain = 238 238 + fst (build ~capabilities chain) 239 239 + 240 240 + (* JSON helpers - exported *) 241 241 + let json_null = Jsont.Null ((), Jsont.Meta.none) 242 242 + 243 243 + let json_bool b = Jsont.Bool (b, Jsont.Meta.none) 244 244 + 245 245 + let json_string s = Jsont.String (s, Jsont.Meta.none) 246 246 + 247 247 + let json_int n = Jsont.Number (Int64.to_float n, Jsont.Meta.none) 248 248 + 249 249 + let json_name s = (s, Jsont.Meta.none) 250 250 + 251 251 + let json_obj fields = 252 252 + let fields' = List.map (fun (k, v) -> (json_name k, v)) fields in 253 253 + Jsont.Object (fields', Jsont.Meta.none) 254 254 + 255 255 + let json_array items = Jsont.Array (items, Jsont.Meta.none) 256 256 + 257 257 + (* JSON helpers - internal *) 258 258 + let json_of_id id = 259 259 + Jsont.String (Id.to_string id, Jsont.Meta.none) 260 260 + 261 261 + let json_of_id_list ids = 262 262 + let items = List.map json_of_id ids in 263 263 + Jsont.Array (items, Jsont.Meta.none) 264 264 + 265 265 + let json_of_string_list strs = 266 266 + let items = List.map json_string strs in 267 267 + Jsont.Array (items, Jsont.Meta.none) 268 268 + 269 269 + let json_map pairs = 270 270 + let fields' = List.map (fun (k, v) -> (json_name k, v)) pairs in 271 271 + Jsont.Object (fields', Jsont.Meta.none) 272 272 + 273 273 + let encode_to_json jsont value = 274 274 + match Jsont.Json.encode' jsont value with 275 275 + | Ok j -> j 276 276 + | Error _ -> json_obj [] 277 277 + 278 278 + let encode_list_to_json jsont values = 279 279 + match Jsont.Json.encode' (Jsont.list jsont) values with 280 280 + | Ok j -> j 281 281 + | Error _ -> Jsont.Array ([], Jsont.Meta.none) 282 282 + 283 283 + (* Add id_source to args *) 284 284 + let add_ids_arg args = function 285 285 + | None -> args 286 286 + | Some (Ids ids) -> 287 287 + ("ids", json_of_id_list ids) :: args 288 288 + | Some (Ref ref_) -> 289 289 + let ref_json = encode_to_json Invocation.result_reference_jsont ref_ in 290 290 + ("#ids", ref_json) :: args 291 291 + 292 292 + let add_destroy_arg args = function 293 293 + | None -> args 294 294 + | Some (Ids ids) -> 295 295 + ("destroy", json_of_id_list ids) :: args 296 296 + | Some (Ref ref_) -> 297 297 + let ref_json = encode_to_json Invocation.result_reference_jsont ref_ in 298 298 + ("#destroy", ref_json) :: args 299 299 + 300 300 + (* Query builder helper *) 301 301 + let build_query_args ~account_id ?filter ?filter_jsont ?sort ?position ?anchor 302 302 + ?anchor_offset ?limit ?calculate_total () = 303 303 + let args = [ ("accountId", json_of_id account_id) ] in 304 304 + let args = match filter, filter_jsont with 305 305 + | Some f, Some jsont -> ("filter", encode_to_json jsont f) :: args 306 306 + | _ -> args 307 307 + in 308 308 + let args = match sort with 309 309 + | None -> args 310 310 + | Some comparators -> ("sort", encode_list_to_json Filter.comparator_jsont comparators) :: args 311 311 + in 312 312 + let args = match position with 313 313 + | None -> args 314 314 + | Some n -> ("position", json_int n) :: args 315 315 + in 316 316 + let args = match anchor with 317 317 + | None -> args 318 318 + | Some id -> ("anchor", json_of_id id) :: args 319 319 + in 320 320 + let args = match anchor_offset with 321 321 + | None -> args 322 322 + | Some n -> ("anchorOffset", json_int n) :: args 323 323 + in 324 324 + let args = match limit with 325 325 + | None -> args 326 326 + | Some n -> ("limit", json_int n) :: args 327 327 + in 328 328 + let args = match calculate_total with 329 329 + | None -> args 330 330 + | Some b -> ("calculateTotal", json_bool b) :: args 331 331 + in 332 332 + args 333 333 + 334 334 + (* Changes builder helper *) 335 335 + let build_changes_args ~account_id ~since_state ?max_changes () = 336 336 + let args = [ 337 337 + ("accountId", json_of_id account_id); 338 338 + ("sinceState", json_string since_state); 339 339 + ] in 340 340 + let args = match max_changes with 341 341 + | None -> args 342 342 + | Some n -> ("maxChanges", json_int n) :: args 343 343 + in 344 344 + args 345 345 + 346 346 + (* QueryChanges builder helper *) 347 347 + let build_query_changes_args ~account_id ~since_query_state ?filter ?filter_jsont 348 348 + ?sort ?max_changes ?up_to_id ?calculate_total () = 349 349 + let args = [ 350 350 + ("accountId", json_of_id account_id); 351 351 + ("sinceQueryState", json_string since_query_state); 352 352 + ] in 353 353 + let args = match filter, filter_jsont with 354 354 + | Some f, Some jsont -> ("filter", encode_to_json jsont f) :: args 355 355 + | _ -> args 356 356 + in 357 357 + let args = match sort with 358 358 + | None -> args 359 359 + | Some comparators -> ("sort", encode_list_to_json Filter.comparator_jsont comparators) :: args 360 360 + in 361 361 + let args = match max_changes with 362 362 + | None -> args 363 363 + | Some n -> ("maxChanges", json_int n) :: args 364 364 + in 365 365 + let args = match up_to_id with 366 366 + | None -> args 367 367 + | Some id -> ("upToId", json_of_id id) :: args 368 368 + in 369 369 + let args = match calculate_total with 370 370 + | None -> args 371 371 + | Some b -> ("calculateTotal", json_bool b) :: args 372 372 + in 373 373 + args 374 374 + 375 375 + (* Set builder helper *) 376 376 + let build_set_args ~account_id ?if_in_state ?create ?update ?destroy () = 377 377 + let args = [ ("accountId", json_of_id account_id) ] in 378 378 + let args = match if_in_state with 379 379 + | None -> args 380 380 + | Some s -> ("ifInState", json_string s) :: args 381 381 + in 382 382 + let args = match create with 383 383 + | None | Some [] -> args 384 384 + | Some items -> 385 385 + let create_map = json_map (List.map (fun (cid, obj) -> (cid, obj)) items) in 386 386 + ("create", create_map) :: args 387 387 + in 388 388 + let args = match update with 389 389 + | None | Some [] -> args 390 390 + | Some items -> 391 391 + let update_map = json_map (List.map (fun (id, patch) -> (Id.to_string id, patch)) items) in 392 392 + ("update", update_map) :: args 393 393 + in 394 394 + let args = add_destroy_arg args destroy in 395 395 + args 396 396 + 397 397 + (* Method builders *) 398 398 + 399 399 + let email_query ~account_id ?filter ?sort ?position ?anchor ?anchor_offset 400 400 + ?limit ?calculate_total ?collapse_threads () state = 401 401 + let call_id = fresh_call_id state in 402 402 + let args = build_query_args ~account_id ?filter 403 403 + ~filter_jsont:Mail_filter.email_filter_jsont 404 404 + ?sort ?position ?anchor ?anchor_offset ?limit ?calculate_total () in 405 405 + let args = match collapse_threads with 406 406 + | None -> args 407 407 + | Some b -> ("collapseThreads", json_bool b) :: args 408 408 + in 409 409 + let inv = Invocation.create 410 410 + ~name:"Email/query" 411 411 + ~arguments:(json_obj args) 412 412 + ~method_call_id:call_id 413 413 + in 414 414 + record_invocation inv state; 415 415 + Query_handle { call_id; method_name = "Email/query" } 416 416 + 417 417 + let email_get ~account_id ?ids ?properties ?body_properties 418 418 + ?fetch_text_body_values ?fetch_html_body_values ?fetch_all_body_values 419 419 + ?max_body_value_bytes () state = 420 420 + let call_id = fresh_call_id state in 421 421 + let args = [ ("accountId", json_of_id account_id) ] in 422 422 + let args = add_ids_arg args ids in 423 423 + let args = match properties with 424 424 + | None -> args 425 425 + | Some props -> ("properties", json_of_string_list props) :: args 426 426 + in 427 427 + let args = match body_properties with 428 428 + | None -> args 429 429 + | Some props -> ("bodyProperties", json_of_string_list props) :: args 430 430 + in 431 431 + let args = match fetch_text_body_values with 432 432 + | None -> args 433 433 + | Some b -> ("fetchTextBodyValues", json_bool b) :: args 434 434 + in 435 435 + let args = match fetch_html_body_values with 436 436 + | None -> args 437 437 + | Some b -> ("fetchHTMLBodyValues", json_bool b) :: args 438 438 + in 439 439 + let args = match fetch_all_body_values with 440 440 + | None -> args 441 441 + | Some b -> ("fetchAllBodyValues", json_bool b) :: args 442 442 + in 443 443 + let args = match max_body_value_bytes with 444 444 + | None -> args 445 445 + | Some n -> ("maxBodyValueBytes", json_int n) :: args 446 446 + in 447 447 + let inv = Invocation.create 448 448 + ~name:"Email/get" 449 449 + ~arguments:(json_obj args) 450 450 + ~method_call_id:call_id 451 451 + in 452 452 + record_invocation inv state; 453 453 + Email_get_handle { call_id; method_name = "Email/get" } 454 454 + 455 455 + let email_changes ~account_id ~since_state ?max_changes () state = 456 456 + let call_id = fresh_call_id state in 457 457 + let args = build_changes_args ~account_id ~since_state ?max_changes () in 458 458 + let inv = Invocation.create 459 459 + ~name:"Email/changes" 460 460 + ~arguments:(json_obj args) 461 461 + ~method_call_id:call_id 462 462 + in 463 463 + record_invocation inv state; 464 464 + Changes_handle { call_id; method_name = "Email/changes" } 465 465 + 466 466 + let email_query_changes ~account_id ~since_query_state ?filter ?sort 467 467 + ?max_changes ?up_to_id ?calculate_total () state = 468 468 + let call_id = fresh_call_id state in 469 469 + let args = build_query_changes_args ~account_id ~since_query_state 470 470 + ?filter ~filter_jsont:Mail_filter.email_filter_jsont 471 471 + ?sort ?max_changes ?up_to_id ?calculate_total () in 472 472 + let inv = Invocation.create 473 473 + ~name:"Email/queryChanges" 474 474 + ~arguments:(json_obj args) 475 475 + ~method_call_id:call_id 476 476 + in 477 477 + record_invocation inv state; 478 478 + Query_changes_handle { call_id; method_name = "Email/queryChanges" } 479 479 + 480 480 + let email_set ~account_id ?if_in_state ?create ?update ?destroy () state = 481 481 + let call_id = fresh_call_id state in 482 482 + let args = build_set_args ~account_id ?if_in_state ?create ?update ?destroy () in 483 483 + let inv = Invocation.create 484 484 + ~name:"Email/set" 485 485 + ~arguments:(json_obj args) 486 486 + ~method_call_id:call_id 487 487 + in 488 488 + record_invocation inv state; 489 489 + Email_set_handle { call_id; method_name = "Email/set" } 490 490 + 491 491 + let email_copy ~from_account_id ~account_id ?if_from_in_state ?if_in_state 492 492 + ?create ?on_success_destroy_original ?destroy_from_if_in_state () state = 493 493 + let call_id = fresh_call_id state in 494 494 + let args = [ 495 495 + ("fromAccountId", json_of_id from_account_id); 496 496 + ("accountId", json_of_id account_id); 497 497 + ] in 498 498 + let args = match if_from_in_state with 499 499 + | None -> args 500 500 + | Some s -> ("ifFromInState", json_string s) :: args 501 501 + in 502 502 + let args = match if_in_state with 503 503 + | None -> args 504 504 + | Some s -> ("ifInState", json_string s) :: args 505 505 + in 506 506 + let args = match create with 507 507 + | None | Some [] -> args 508 508 + | Some items -> 509 509 + let create_map = json_map (List.map (fun (id, obj) -> (Id.to_string id, obj)) items) in 510 510 + ("create", create_map) :: args 511 511 + in 512 512 + let args = match on_success_destroy_original with 513 513 + | None -> args 514 514 + | Some b -> ("onSuccessDestroyOriginal", json_bool b) :: args 515 515 + in 516 516 + let args = match destroy_from_if_in_state with 517 517 + | None -> args 518 518 + | Some s -> ("destroyFromIfInState", json_string s) :: args 519 519 + in 520 520 + let inv = Invocation.create 521 521 + ~name:"Email/copy" 522 522 + ~arguments:(json_obj args) 523 523 + ~method_call_id:call_id 524 524 + in 525 525 + record_invocation inv state; 526 526 + Email_copy_handle { call_id; method_name = "Email/copy" } 527 527 + 528 528 + let thread_get ~account_id ?ids () state = 529 529 + let call_id = fresh_call_id state in 530 530 + let args = [ ("accountId", json_of_id account_id) ] in 531 531 + let args = add_ids_arg args ids in 532 532 + let inv = Invocation.create 533 533 + ~name:"Thread/get" 534 534 + ~arguments:(json_obj args) 535 535 + ~method_call_id:call_id 536 536 + in 537 537 + record_invocation inv state; 538 538 + Thread_get_handle { call_id; method_name = "Thread/get" } 539 539 + 540 540 + let thread_changes ~account_id ~since_state ?max_changes () state = 541 541 + let call_id = fresh_call_id state in 542 542 + let args = build_changes_args ~account_id ~since_state ?max_changes () in 543 543 + let inv = Invocation.create 544 544 + ~name:"Thread/changes" 545 545 + ~arguments:(json_obj args) 546 546 + ~method_call_id:call_id 547 547 + in 548 548 + record_invocation inv state; 549 549 + Changes_handle { call_id; method_name = "Thread/changes" } 550 550 + 551 551 + let mailbox_query ~account_id ?filter ?sort ?position ?anchor ?anchor_offset 552 552 + ?limit ?calculate_total () state = 553 553 + let call_id = fresh_call_id state in 554 554 + let args = build_query_args ~account_id ?filter 555 555 + ~filter_jsont:Mail_filter.mailbox_filter_jsont 556 556 + ?sort ?position ?anchor ?anchor_offset ?limit ?calculate_total () in 557 557 + let inv = Invocation.create 558 558 + ~name:"Mailbox/query" 559 559 + ~arguments:(json_obj args) 560 560 + ~method_call_id:call_id 561 561 + in 562 562 + record_invocation inv state; 563 563 + Query_handle { call_id; method_name = "Mailbox/query" } 564 564 + 565 565 + let mailbox_get ~account_id ?ids ?properties () state = 566 566 + let call_id = fresh_call_id state in 567 567 + let args = [ ("accountId", json_of_id account_id) ] in 568 568 + let args = add_ids_arg args ids in 569 569 + let args = match properties with 570 570 + | None -> args 571 571 + | Some props -> ("properties", json_of_string_list props) :: args 572 572 + in 573 573 + let inv = Invocation.create 574 574 + ~name:"Mailbox/get" 575 575 + ~arguments:(json_obj args) 576 576 + ~method_call_id:call_id 577 577 + in 578 578 + record_invocation inv state; 579 579 + Mailbox_get_handle { call_id; method_name = "Mailbox/get" } 580 580 + 581 581 + let mailbox_changes ~account_id ~since_state ?max_changes () state = 582 582 + let call_id = fresh_call_id state in 583 583 + let args = build_changes_args ~account_id ~since_state ?max_changes () in 584 584 + let inv = Invocation.create 585 585 + ~name:"Mailbox/changes" 586 586 + ~arguments:(json_obj args) 587 587 + ~method_call_id:call_id 588 588 + in 589 589 + record_invocation inv state; 590 590 + Changes_handle { call_id; method_name = "Mailbox/changes" } 591 591 + 592 592 + let mailbox_query_changes ~account_id ~since_query_state ?filter ?sort 593 593 + ?max_changes ?up_to_id ?calculate_total () state = 594 594 + let call_id = fresh_call_id state in 595 595 + let args = build_query_changes_args ~account_id ~since_query_state 596 596 + ?filter ~filter_jsont:Mail_filter.mailbox_filter_jsont 597 597 + ?sort ?max_changes ?up_to_id ?calculate_total () in 598 598 + let inv = Invocation.create 599 599 + ~name:"Mailbox/queryChanges" 600 600 + ~arguments:(json_obj args) 601 601 + ~method_call_id:call_id 602 602 + in 603 603 + record_invocation inv state; 604 604 + Query_changes_handle { call_id; method_name = "Mailbox/queryChanges" } 605 605 + 606 606 + let mailbox_set ~account_id ?if_in_state ?create ?update ?destroy 607 607 + ?on_destroy_remove_emails () state = 608 608 + let call_id = fresh_call_id state in 609 609 + let args = build_set_args ~account_id ?if_in_state ?create ?update ?destroy () in 610 610 + let args = match on_destroy_remove_emails with 611 611 + | None -> args 612 612 + | Some b -> ("onDestroyRemoveEmails", json_bool b) :: args 613 613 + in 614 614 + let inv = Invocation.create 615 615 + ~name:"Mailbox/set" 616 616 + ~arguments:(json_obj args) 617 617 + ~method_call_id:call_id 618 618 + in 619 619 + record_invocation inv state; 620 620 + Mailbox_set_handle { call_id; method_name = "Mailbox/set" } 621 621 + 622 622 + let identity_get ~account_id ?ids ?properties () state = 623 623 + let call_id = fresh_call_id state in 624 624 + let args = [ ("accountId", json_of_id account_id) ] in 625 625 + let args = add_ids_arg args ids in 626 626 + let args = match properties with 627 627 + | None -> args 628 628 + | Some props -> ("properties", json_of_string_list props) :: args 629 629 + in 630 630 + let inv = Invocation.create 631 631 + ~name:"Identity/get" 632 632 + ~arguments:(json_obj args) 633 633 + ~method_call_id:call_id 634 634 + in 635 635 + record_invocation inv state; 636 636 + Identity_get_handle { call_id; method_name = "Identity/get" } 637 637 + 638 638 + let identity_changes ~account_id ~since_state ?max_changes () state = 639 639 + let call_id = fresh_call_id state in 640 640 + let args = build_changes_args ~account_id ~since_state ?max_changes () in 641 641 + let inv = Invocation.create 642 642 + ~name:"Identity/changes" 643 643 + ~arguments:(json_obj args) 644 644 + ~method_call_id:call_id 645 645 + in 646 646 + record_invocation inv state; 647 647 + Changes_handle { call_id; method_name = "Identity/changes" } 648 648 + 649 649 + let identity_set ~account_id ?if_in_state ?create ?update ?destroy () state = 650 650 + let call_id = fresh_call_id state in 651 651 + let args = build_set_args ~account_id ?if_in_state ?create ?update ?destroy () in 652 652 + let inv = Invocation.create 653 653 + ~name:"Identity/set" 654 654 + ~arguments:(json_obj args) 655 655 + ~method_call_id:call_id 656 656 + in 657 657 + record_invocation inv state; 658 658 + Identity_set_handle { call_id; method_name = "Identity/set" } 659 659 + 660 660 + let email_submission_query ~account_id ?filter ?sort ?position ?anchor 661 661 + ?anchor_offset ?limit ?calculate_total () state = 662 662 + let call_id = fresh_call_id state in 663 663 + let args = build_query_args ~account_id ?filter 664 664 + ~filter_jsont:Mail_filter.submission_filter_jsont 665 665 + ?sort ?position ?anchor ?anchor_offset ?limit ?calculate_total () in 666 666 + let inv = Invocation.create 667 667 + ~name:"EmailSubmission/query" 668 668 + ~arguments:(json_obj args) 669 669 + ~method_call_id:call_id 670 670 + in 671 671 + record_invocation inv state; 672 672 + Query_handle { call_id; method_name = "EmailSubmission/query" } 673 673 + 674 674 + let email_submission_get ~account_id ?ids ?properties () state = 675 675 + let call_id = fresh_call_id state in 676 676 + let args = [ ("accountId", json_of_id account_id) ] in 677 677 + let args = add_ids_arg args ids in 678 678 + let args = match properties with 679 679 + | None -> args 680 680 + | Some props -> ("properties", json_of_string_list props) :: args 681 681 + in 682 682 + let inv = Invocation.create 683 683 + ~name:"EmailSubmission/get" 684 684 + ~arguments:(json_obj args) 685 685 + ~method_call_id:call_id 686 686 + in 687 687 + record_invocation inv state; 688 688 + Submission_get_handle { call_id; method_name = "EmailSubmission/get" } 689 689 + 690 690 + let email_submission_changes ~account_id ~since_state ?max_changes () state = 691 691 + let call_id = fresh_call_id state in 692 692 + let args = build_changes_args ~account_id ~since_state ?max_changes () in 693 693 + let inv = Invocation.create 694 694 + ~name:"EmailSubmission/changes" 695 695 + ~arguments:(json_obj args) 696 696 + ~method_call_id:call_id 697 697 + in 698 698 + record_invocation inv state; 699 699 + Changes_handle { call_id; method_name = "EmailSubmission/changes" } 700 700 + 701 701 + let email_submission_query_changes ~account_id ~since_query_state ?filter ?sort 702 702 + ?max_changes ?up_to_id ?calculate_total () state = 703 703 + let call_id = fresh_call_id state in 704 704 + let args = build_query_changes_args ~account_id ~since_query_state 705 705 + ?filter ~filter_jsont:Mail_filter.submission_filter_jsont 706 706 + ?sort ?max_changes ?up_to_id ?calculate_total () in 707 707 + let inv = Invocation.create 708 708 + ~name:"EmailSubmission/queryChanges" 709 709 + ~arguments:(json_obj args) 710 710 + ~method_call_id:call_id 711 711 + in 712 712 + record_invocation inv state; 713 713 + Query_changes_handle { call_id; method_name = "EmailSubmission/queryChanges" } 714 714 + 715 715 + let email_submission_set ~account_id ?if_in_state ?create ?update ?destroy 716 716 + ?on_success_update_email ?on_success_destroy_email () state = 717 717 + let call_id = fresh_call_id state in 718 718 + let args = build_set_args ~account_id ?if_in_state ?create ?update ?destroy () in 719 719 + let args = match on_success_update_email with 720 720 + | None | Some [] -> args 721 721 + | Some items -> 722 722 + let update_map = json_map items in 723 723 + ("onSuccessUpdateEmail", update_map) :: args 724 724 + in 725 725 + let args = match on_success_destroy_email with 726 726 + | None | Some [] -> args 727 727 + | Some ids -> 728 728 + ("onSuccessDestroyEmail", json_of_string_list ids) :: args 729 729 + in 730 730 + let inv = Invocation.create 731 731 + ~name:"EmailSubmission/set" 732 732 + ~arguments:(json_obj args) 733 733 + ~method_call_id:call_id 734 734 + in 735 735 + record_invocation inv state; 736 736 + Submission_set_handle { call_id; method_name = "EmailSubmission/set" } 737 737 + 738 738 + let search_snippet_get ~account_id ~filter ~email_ids () state = 739 739 + let call_id = fresh_call_id state in 740 740 + let args = [ ("accountId", json_of_id account_id) ] in 741 741 + let args = ("filter", encode_to_json Mail_filter.email_filter_jsont filter) :: args in 742 742 + let args = match email_ids with 743 743 + | Ids ids -> ("emailIds", json_of_id_list ids) :: args 744 744 + | Ref ref_ -> 745 745 + let ref_json = encode_to_json Invocation.result_reference_jsont ref_ in 746 746 + ("#emailIds", ref_json) :: args 747 747 + in 748 748 + let inv = Invocation.create 749 749 + ~name:"SearchSnippet/get" 750 750 + ~arguments:(json_obj args) 751 751 + ~method_call_id:call_id 752 752 + in 753 753 + record_invocation inv state; 754 754 + Search_snippet_get_handle { call_id; method_name = "SearchSnippet/get" } 755 755 + 756 756 + let vacation_response_get ~account_id ?properties () state = 757 757 + let call_id = fresh_call_id state in 758 758 + let args = [ ("accountId", json_of_id account_id) ] in 759 759 + let args = match properties with 760 760 + | None -> args 761 761 + | Some props -> ("properties", json_of_string_list props) :: args 762 762 + in 763 763 + let inv = Invocation.create 764 764 + ~name:"VacationResponse/get" 765 765 + ~arguments:(json_obj args) 766 766 + ~method_call_id:call_id 767 767 + in 768 768 + record_invocation inv state; 769 769 + Vacation_get_handle { call_id; method_name = "VacationResponse/get" } 770 770 + 771 771 + let vacation_response_set ~account_id ?if_in_state ~update () state = 772 772 + let call_id = fresh_call_id state in 773 773 + let args = [ ("accountId", json_of_id account_id) ] in 774 774 + let args = match if_in_state with 775 775 + | None -> args 776 776 + | Some s -> ("ifInState", json_string s) :: args 777 777 + in 778 778 + let args = ("update", json_map [("singleton", update)]) :: args in 779 779 + let inv = Invocation.create 780 780 + ~name:"VacationResponse/set" 781 781 + ~arguments:(json_obj args) 782 782 + ~method_call_id:call_id 783 783 + in 784 784 + record_invocation inv state; 785 785 + Vacation_set_handle { call_id; method_name = "VacationResponse/set" } 786 786 + 787 787 + let raw_invocation ~name ~arguments state = 788 788 + let call_id = fresh_call_id state in 789 789 + let inv = Invocation.create 790 790 + ~name 791 791 + ~arguments 792 792 + ~method_call_id:call_id 793 793 + in 794 794 + record_invocation inv state; 795 795 + Raw_handle { call_id; method_name = name } 796 796 + 797 797 + (* Response parsing *) 798 798 + 799 799 + let find_invocation ~call_id response = 800 800 + List.find_opt 801 801 + (fun inv -> Invocation.method_call_id inv = call_id) 802 802 + (Response.method_responses response) 803 803 + 804 804 + let parse : type k r. (k, r) handle -> Response.t -> (r, Jsont.Error.t) result = 805 805 + fun handle response -> 806 806 + let cid = call_id handle in 807 807 + match find_invocation ~call_id:cid response with 808 808 + | None -> 809 809 + Error (Jsont.Error.msgf Jsont.Meta.none "No response found for call_id: %s" cid) 810 810 + | Some inv -> 811 811 + let args = Invocation.arguments inv in 812 812 + match handle with 813 813 + | Query_handle _ -> 814 814 + Jsont.Json.decode' Method.query_response_jsont args 815 815 + | Query_changes_handle _ -> 816 816 + Jsont.Json.decode' Method.query_changes_response_jsont args 817 817 + | Email_get_handle _ -> 818 818 + Jsont.Json.decode' (Method.get_response_jsont Email.jsont) args 819 819 + | Thread_get_handle _ -> 820 820 + Jsont.Json.decode' (Method.get_response_jsont Thread.jsont) args 821 821 + | Mailbox_get_handle _ -> 822 822 + Jsont.Json.decode' (Method.get_response_jsont Mailbox.jsont) args 823 823 + | Identity_get_handle _ -> 824 824 + Jsont.Json.decode' (Method.get_response_jsont Identity.jsont) args 825 825 + | Submission_get_handle _ -> 826 826 + Jsont.Json.decode' (Method.get_response_jsont Submission.jsont) args 827 827 + | Search_snippet_get_handle _ -> 828 828 + Jsont.Json.decode' (Method.get_response_jsont Search_snippet.jsont) args 829 829 + | Vacation_get_handle _ -> 830 830 + Jsont.Json.decode' (Method.get_response_jsont Vacation.jsont) args 831 831 + | Changes_handle _ -> 832 832 + Jsont.Json.decode' Method.changes_response_jsont args 833 833 + | Email_set_handle _ -> 834 834 + Jsont.Json.decode' (Method.set_response_jsont Email.jsont) args 835 835 + | Mailbox_set_handle _ -> 836 836 + Jsont.Json.decode' (Method.set_response_jsont Mailbox.jsont) args 837 837 + | Identity_set_handle _ -> 838 838 + Jsont.Json.decode' (Method.set_response_jsont Identity.jsont) args 839 839 + | Submission_set_handle _ -> 840 840 + Jsont.Json.decode' (Method.set_response_jsont Submission.jsont) args 841 841 + | Vacation_set_handle _ -> 842 842 + Jsont.Json.decode' (Method.set_response_jsont Vacation.jsont) args 843 843 + | Email_copy_handle _ -> 844 844 + Jsont.Json.decode' (Method.copy_response_jsont Email.jsont) args 845 845 + | Raw_handle _ -> 846 846 + Ok args 847 847 + 848 848 + let parse_exn handle response = 849 849 + match parse handle response with 850 850 + | Ok r -> r 851 851 + | Error e -> failwith (Jsont.Error.to_string e)

+556

lib/core/chain.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 method chaining with automatic result references. 7 7 + 8 8 + This module provides a monadic interface for building JMAP requests 9 9 + where method calls can reference results from previous calls in the 10 10 + same request. Call IDs are generated automatically. 11 11 + 12 12 + {2 Basic Example} 13 13 + 14 14 + Query for emails and fetch their details in a single request: 15 15 + {[ 16 16 + let open Jmap.Chain in 17 17 + let request, emails = build ~capabilities:[core; mail] begin 18 18 + let* query = email_query ~account_id 19 19 + ~filter:(Condition { in_mailbox = Some inbox_id; _ }) 20 20 + ~limit:50L () 21 21 + in 22 22 + let* emails = email_get ~account_id 23 23 + ~ids:(from_query query) 24 24 + ~properties:["subject"; "from"; "receivedAt"] 25 25 + () 26 26 + in 27 27 + return emails 28 28 + end in 29 29 + match Client.request client request with 30 30 + | Ok response -> 31 31 + let emails = parse emails response in 32 32 + ... 33 33 + ]} 34 34 + 35 35 + {2 Creation and Submission} 36 36 + 37 37 + Create a draft email and submit it in one request: 38 38 + {[ 39 39 + let* set_h, draft_cid = email_set ~account_id 40 40 + ~create:[email_create ~mailbox_ids:[drafts_id] ~subject:"Hello" ...] 41 41 + () 42 42 + in 43 43 + let* _ = email_submission_set ~account_id 44 44 + ~create:[submission_create 45 45 + ~email_id:(created_id draft_cid) 46 46 + ~identity_id] 47 47 + () 48 48 + in 49 49 + return set_h 50 50 + ]} 51 51 + 52 52 + {2 Multi-step Chains} 53 53 + 54 54 + The RFC 8620 example - fetch from/date/subject for all emails in 55 55 + the first 10 threads in the inbox: 56 56 + {[ 57 57 + let* q = email_query ~account_id 58 58 + ~filter:(Condition { in_mailbox = Some inbox_id; _ }) 59 59 + ~sort:[comparator ~is_ascending:false "receivedAt"] 60 60 + ~collapse_threads:true ~limit:10L () 61 61 + in 62 62 + let* e1 = email_get ~account_id 63 63 + ~ids:(from_query q) 64 64 + ~properties:["threadId"] 65 65 + () 66 66 + in 67 67 + let* threads = thread_get ~account_id 68 68 + ~ids:(from_get_field e1 "threadId") 69 69 + () 70 70 + in 71 71 + let* e2 = email_get ~account_id 72 72 + ~ids:(from_get_field threads "emailIds") 73 73 + ~properties:["from"; "receivedAt"; "subject"] 74 74 + () 75 75 + in 76 76 + return e2 77 77 + ]} *) 78 78 + 79 79 + (** {1 Handles} 80 80 + 81 81 + Method invocations return handles that encode both the method kind 82 82 + (for building result references) and the exact response type 83 83 + (for type-safe parsing). *) 84 84 + 85 85 + (** Phantom type for query method handles. *) 86 86 + type query 87 87 + 88 88 + (** Phantom type for get method handles. *) 89 89 + type get 90 90 + 91 91 + (** Phantom type for changes method handles. *) 92 92 + type changes 93 93 + 94 94 + (** Phantom type for set method handles. *) 95 95 + type set 96 96 + 97 97 + (** Phantom type for query_changes method handles. *) 98 98 + type query_changes 99 99 + 100 100 + (** Phantom type for copy method handles. *) 101 101 + type copy 102 102 + 103 103 + (** Phantom type for import method handles. *) 104 104 + type import 105 105 + 106 106 + (** Phantom type for parse method handles. *) 107 107 + type parse 108 108 + 109 109 + (** A handle to a method invocation. 110 110 + 111 111 + The first type parameter indicates the method kind (query/get/changes/set/...), 112 112 + used for building result references. The second type parameter is the 113 113 + parsed response type, enabling type-safe parsing via {!parse}. *) 114 114 + type (_, _) handle 115 115 + 116 116 + val call_id : (_, _) handle -> string 117 117 + (** [call_id h] returns the auto-generated call ID for this invocation. *) 118 118 + 119 119 + val method_name : (_, _) handle -> string 120 120 + (** [method_name h] returns the method name (e.g., "Email/query"). *) 121 121 + 122 122 + (** {1 Creation IDs} 123 123 + 124 124 + When creating objects via [/set] methods, you can reference the 125 125 + server-assigned ID before the request completes using creation IDs. *) 126 126 + 127 127 + type 'a create_id 128 128 + (** A creation ID for an object of type ['a]. Used to reference 129 129 + newly created objects within the same request. *) 130 130 + 131 131 + val created_id : _ create_id -> Jmap_proto.Id.t 132 132 + (** [created_id cid] returns a placeholder ID (["#cN"]) that the server 133 133 + will substitute with the real ID. Use this to reference a created 134 134 + object in subsequent method calls within the same request. *) 135 135 + 136 136 + val created_id_of_string : string -> Jmap_proto.Id.t 137 137 + (** [created_id_of_string s] returns a placeholder ID for a string creation ID. 138 138 + For example, [created_id_of_string "draft1"] returns ["#draft1"]. *) 139 139 + 140 140 + (** {1 ID Sources} 141 141 + 142 142 + Methods that accept IDs can take them either as concrete values 143 143 + or as references to results from previous method calls. *) 144 144 + 145 145 + type id_source = 146 146 + | Ids of Jmap_proto.Id.t list 147 147 + (** Concrete list of IDs. *) 148 148 + | Ref of Jmap_proto.Invocation.result_reference 149 149 + (** Back-reference to a previous method's result. *) 150 150 + 151 151 + val ids : Jmap_proto.Id.t list -> id_source 152 152 + (** [ids lst] provides concrete IDs. *) 153 153 + 154 154 + val id : Jmap_proto.Id.t -> id_source 155 155 + (** [id x] provides a single concrete ID. *) 156 156 + 157 157 + (** {2 References from Query} *) 158 158 + 159 159 + val from_query : (query, _) handle -> id_source 160 160 + (** [from_query h] references [/ids] from a query response. *) 161 161 + 162 162 + (** {2 References from Get} *) 163 163 + 164 164 + val from_get_ids : (get, _) handle -> id_source 165 165 + (** [from_get_ids h] references [/list/*/id] from a get response. *) 166 166 + 167 167 + val from_get_field : (get, _) handle -> string -> id_source 168 168 + (** [from_get_field h field] references [/list/*/field] from a get response. 169 169 + Common fields: ["threadId"], ["emailIds"], ["mailboxIds"]. *) 170 170 + 171 171 + (** {2 References from Changes} *) 172 172 + 173 173 + val from_changes_created : (changes, _) handle -> id_source 174 174 + (** [from_changes_created h] references [/created] from a changes response. *) 175 175 + 176 176 + val from_changes_updated : (changes, _) handle -> id_source 177 177 + (** [from_changes_updated h] references [/updated] from a changes response. *) 178 178 + 179 179 + val from_changes_destroyed : (changes, _) handle -> id_source 180 180 + (** [from_changes_destroyed h] references [/destroyed] from a changes response. *) 181 181 + 182 182 + (** {2 References from Set} *) 183 183 + 184 184 + val from_set_created : (set, _) handle -> id_source 185 185 + (** [from_set_created h] references [/created/*/id] - IDs of objects created 186 186 + by a set operation. *) 187 187 + 188 188 + val from_set_updated : (set, _) handle -> id_source 189 189 + (** [from_set_updated h] references [/updated] - IDs of objects updated. *) 190 190 + 191 191 + (** {2 References from QueryChanges} *) 192 192 + 193 193 + val from_query_changes_removed : (query_changes, _) handle -> id_source 194 194 + (** [from_query_changes_removed h] references [/removed] from queryChanges. *) 195 195 + 196 196 + val from_query_changes_added : (query_changes, _) handle -> id_source 197 197 + (** [from_query_changes_added h] references [/added/*/id] from queryChanges. *) 198 198 + 199 199 + (** {2 References from Copy} *) 200 200 + 201 201 + val from_copy_created : (copy, _) handle -> id_source 202 202 + (** [from_copy_created h] references [/created/*/id] from copy response. *) 203 203 + 204 204 + (** {2 References from Import} *) 205 205 + 206 206 + val from_import_created : (import, _) handle -> id_source 207 207 + (** [from_import_created h] references [/created/*/id] from import response. *) 208 208 + 209 209 + (** {1 Chain Monad} 210 210 + 211 211 + A monad for building JMAP requests with automatic call ID generation 212 212 + and invocation collection. *) 213 213 + 214 214 + type 'a t 215 215 + (** A chain computation that produces ['a] (typically a handle). *) 216 216 + 217 217 + val return : 'a -> 'a t 218 218 + (** [return x] is a computation that produces [x] without adding any 219 219 + method invocations. *) 220 220 + 221 221 + val bind : 'a t -> ('a -> 'b t) -> 'b t 222 222 + (** [bind m f] sequences computations, threading the chain state. *) 223 223 + 224 224 + val map : ('a -> 'b) -> 'a t -> 'b t 225 225 + (** [map f m] applies [f] to the result of [m]. *) 226 226 + 227 227 + val both : 'a t -> 'b t -> ('a * 'b) t 228 228 + (** [both a b] runs both computations, returning their results as a pair. *) 229 229 + 230 230 + (** {2 Syntax} *) 231 231 + 232 232 + val ( let* ) : 'a t -> ('a -> 'b t) -> 'b t 233 233 + val ( let+ ) : 'a t -> ('a -> 'b) -> 'b t 234 234 + val ( and* ) : 'a t -> 'b t -> ('a * 'b) t 235 235 + val ( and+ ) : 'a t -> 'b t -> ('a * 'b) t 236 236 + 237 237 + (** {1 Building Requests} *) 238 238 + 239 239 + val build : 240 240 + capabilities:string list -> 241 241 + 'a t -> 242 242 + Jmap_proto.Request.t * 'a 243 243 + (** [build ~capabilities chain] runs the chain computation, returning 244 244 + the JMAP request and the final value (typically a handle for parsing). *) 245 245 + 246 246 + val build_request : 247 247 + capabilities:string list -> 248 248 + 'a t -> 249 249 + Jmap_proto.Request.t 250 250 + (** [build_request ~capabilities chain] is like {!build} but discards 251 251 + the final value. *) 252 252 + 253 253 + (** {1 Method Builders} 254 254 + 255 255 + Each builder returns a handle wrapped in the chain monad. 256 256 + Call IDs are assigned automatically based on invocation order. *) 257 257 + 258 258 + (** {2 Email Methods} *) 259 259 + 260 260 + val email_query : 261 261 + account_id:Jmap_proto.Id.t -> 262 262 + ?filter:Jmap_proto.Mail_filter.email_filter -> 263 263 + ?sort:Jmap_proto.Filter.comparator list -> 264 264 + ?position:int64 -> 265 265 + ?anchor:Jmap_proto.Id.t -> 266 266 + ?anchor_offset:int64 -> 267 267 + ?limit:int64 -> 268 268 + ?calculate_total:bool -> 269 269 + ?collapse_threads:bool -> 270 270 + unit -> 271 271 + (query, Jmap_proto.Method.query_response) handle t 272 272 + 273 273 + val email_get : 274 274 + account_id:Jmap_proto.Id.t -> 275 275 + ?ids:id_source -> 276 276 + ?properties:string list -> 277 277 + ?body_properties:string list -> 278 278 + ?fetch_text_body_values:bool -> 279 279 + ?fetch_html_body_values:bool -> 280 280 + ?fetch_all_body_values:bool -> 281 281 + ?max_body_value_bytes:int64 -> 282 282 + unit -> 283 283 + (get, Jmap_proto.Email.t Jmap_proto.Method.get_response) handle t 284 284 + 285 285 + val email_changes : 286 286 + account_id:Jmap_proto.Id.t -> 287 287 + since_state:string -> 288 288 + ?max_changes:int64 -> 289 289 + unit -> 290 290 + (changes, Jmap_proto.Method.changes_response) handle t 291 291 + 292 292 + val email_query_changes : 293 293 + account_id:Jmap_proto.Id.t -> 294 294 + since_query_state:string -> 295 295 + ?filter:Jmap_proto.Mail_filter.email_filter -> 296 296 + ?sort:Jmap_proto.Filter.comparator list -> 297 297 + ?max_changes:int64 -> 298 298 + ?up_to_id:Jmap_proto.Id.t -> 299 299 + ?calculate_total:bool -> 300 300 + unit -> 301 301 + (query_changes, Jmap_proto.Method.query_changes_response) handle t 302 302 + 303 303 + val email_set : 304 304 + account_id:Jmap_proto.Id.t -> 305 305 + ?if_in_state:string -> 306 306 + ?create:(string * Jsont.Json.t) list -> 307 307 + ?update:(Jmap_proto.Id.t * Jsont.Json.t) list -> 308 308 + ?destroy:id_source -> 309 309 + unit -> 310 310 + (set, Jmap_proto.Email.t Jmap_proto.Method.set_response) handle t 311 311 + (** Build an Email/set invocation. 312 312 + 313 313 + [create] is a list of [(creation_id, email_object)] pairs where 314 314 + [creation_id] is a client-chosen string (e.g., "draft1") and 315 315 + [email_object] is the JSON representation of the email to create. 316 316 + 317 317 + Use {!created_id_of_string} to reference created objects in later calls. *) 318 318 + 319 319 + val email_copy : 320 320 + from_account_id:Jmap_proto.Id.t -> 321 321 + account_id:Jmap_proto.Id.t -> 322 322 + ?if_from_in_state:string -> 323 323 + ?if_in_state:string -> 324 324 + ?create:(Jmap_proto.Id.t * Jsont.Json.t) list -> 325 325 + ?on_success_destroy_original:bool -> 326 326 + ?destroy_from_if_in_state:string -> 327 327 + unit -> 328 328 + (copy, Jmap_proto.Email.t Jmap_proto.Method.copy_response) handle t 329 329 + (** Build an Email/copy invocation. 330 330 + 331 331 + [create] maps source email IDs to override objects. The source email 332 332 + is copied to the target account with any overridden properties. *) 333 333 + 334 334 + (** {2 Thread Methods} *) 335 335 + 336 336 + val thread_get : 337 337 + account_id:Jmap_proto.Id.t -> 338 338 + ?ids:id_source -> 339 339 + unit -> 340 340 + (get, Jmap_proto.Thread.t Jmap_proto.Method.get_response) handle t 341 341 + 342 342 + val thread_changes : 343 343 + account_id:Jmap_proto.Id.t -> 344 344 + since_state:string -> 345 345 + ?max_changes:int64 -> 346 346 + unit -> 347 347 + (changes, Jmap_proto.Method.changes_response) handle t 348 348 + 349 349 + (** {2 Mailbox Methods} *) 350 350 + 351 351 + val mailbox_query : 352 352 + account_id:Jmap_proto.Id.t -> 353 353 + ?filter:Jmap_proto.Mail_filter.mailbox_filter -> 354 354 + ?sort:Jmap_proto.Filter.comparator list -> 355 355 + ?position:int64 -> 356 356 + ?anchor:Jmap_proto.Id.t -> 357 357 + ?anchor_offset:int64 -> 358 358 + ?limit:int64 -> 359 359 + ?calculate_total:bool -> 360 360 + unit -> 361 361 + (query, Jmap_proto.Method.query_response) handle t 362 362 + 363 363 + val mailbox_get : 364 364 + account_id:Jmap_proto.Id.t -> 365 365 + ?ids:id_source -> 366 366 + ?properties:string list -> 367 367 + unit -> 368 368 + (get, Jmap_proto.Mailbox.t Jmap_proto.Method.get_response) handle t 369 369 + 370 370 + val mailbox_changes : 371 371 + account_id:Jmap_proto.Id.t -> 372 372 + since_state:string -> 373 373 + ?max_changes:int64 -> 374 374 + unit -> 375 375 + (changes, Jmap_proto.Method.changes_response) handle t 376 376 + 377 377 + val mailbox_query_changes : 378 378 + account_id:Jmap_proto.Id.t -> 379 379 + since_query_state:string -> 380 380 + ?filter:Jmap_proto.Mail_filter.mailbox_filter -> 381 381 + ?sort:Jmap_proto.Filter.comparator list -> 382 382 + ?max_changes:int64 -> 383 383 + ?up_to_id:Jmap_proto.Id.t -> 384 384 + ?calculate_total:bool -> 385 385 + unit -> 386 386 + (query_changes, Jmap_proto.Method.query_changes_response) handle t 387 387 + 388 388 + val mailbox_set : 389 389 + account_id:Jmap_proto.Id.t -> 390 390 + ?if_in_state:string -> 391 391 + ?create:(string * Jsont.Json.t) list -> 392 392 + ?update:(Jmap_proto.Id.t * Jsont.Json.t) list -> 393 393 + ?destroy:id_source -> 394 394 + ?on_destroy_remove_emails:bool -> 395 395 + unit -> 396 396 + (set, Jmap_proto.Mailbox.t Jmap_proto.Method.set_response) handle t 397 397 + 398 398 + (** {2 Identity Methods} *) 399 399 + 400 400 + val identity_get : 401 401 + account_id:Jmap_proto.Id.t -> 402 402 + ?ids:id_source -> 403 403 + ?properties:string list -> 404 404 + unit -> 405 405 + (get, Jmap_proto.Identity.t Jmap_proto.Method.get_response) handle t 406 406 + 407 407 + val identity_changes : 408 408 + account_id:Jmap_proto.Id.t -> 409 409 + since_state:string -> 410 410 + ?max_changes:int64 -> 411 411 + unit -> 412 412 + (changes, Jmap_proto.Method.changes_response) handle t 413 413 + 414 414 + val identity_set : 415 415 + account_id:Jmap_proto.Id.t -> 416 416 + ?if_in_state:string -> 417 417 + ?create:(string * Jsont.Json.t) list -> 418 418 + ?update:(Jmap_proto.Id.t * Jsont.Json.t) list -> 419 419 + ?destroy:id_source -> 420 420 + unit -> 421 421 + (set, Jmap_proto.Identity.t Jmap_proto.Method.set_response) handle t 422 422 + 423 423 + (** {2 EmailSubmission Methods} *) 424 424 + 425 425 + val email_submission_query : 426 426 + account_id:Jmap_proto.Id.t -> 427 427 + ?filter:Jmap_proto.Mail_filter.submission_filter -> 428 428 + ?sort:Jmap_proto.Filter.comparator list -> 429 429 + ?position:int64 -> 430 430 + ?anchor:Jmap_proto.Id.t -> 431 431 + ?anchor_offset:int64 -> 432 432 + ?limit:int64 -> 433 433 + ?calculate_total:bool -> 434 434 + unit -> 435 435 + (query, Jmap_proto.Method.query_response) handle t 436 436 + 437 437 + val email_submission_get : 438 438 + account_id:Jmap_proto.Id.t -> 439 439 + ?ids:id_source -> 440 440 + ?properties:string list -> 441 441 + unit -> 442 442 + (get, Jmap_proto.Submission.t Jmap_proto.Method.get_response) handle t 443 443 + 444 444 + val email_submission_changes : 445 445 + account_id:Jmap_proto.Id.t -> 446 446 + since_state:string -> 447 447 + ?max_changes:int64 -> 448 448 + unit -> 449 449 + (changes, Jmap_proto.Method.changes_response) handle t 450 450 + 451 451 + val email_submission_query_changes : 452 452 + account_id:Jmap_proto.Id.t -> 453 453 + since_query_state:string -> 454 454 + ?filter:Jmap_proto.Mail_filter.submission_filter -> 455 455 + ?sort:Jmap_proto.Filter.comparator list -> 456 456 + ?max_changes:int64 -> 457 457 + ?up_to_id:Jmap_proto.Id.t -> 458 458 + ?calculate_total:bool -> 459 459 + unit -> 460 460 + (query_changes, Jmap_proto.Method.query_changes_response) handle t 461 461 + 462 462 + val email_submission_set : 463 463 + account_id:Jmap_proto.Id.t -> 464 464 + ?if_in_state:string -> 465 465 + ?create:(string * Jsont.Json.t) list -> 466 466 + ?update:(Jmap_proto.Id.t * Jsont.Json.t) list -> 467 467 + ?destroy:id_source -> 468 468 + ?on_success_update_email:(string * Jsont.Json.t) list -> 469 469 + ?on_success_destroy_email:string list -> 470 470 + unit -> 471 471 + (set, Jmap_proto.Submission.t Jmap_proto.Method.set_response) handle t 472 472 + (** Build an EmailSubmission/set invocation. 473 473 + 474 474 + [on_success_update_email] and [on_success_destroy_email] take creation IDs 475 475 + (like ["#draft1"]) or real email IDs to update/destroy the email after 476 476 + successful submission. *) 477 477 + 478 478 + (** {2 SearchSnippet Methods} *) 479 479 + 480 480 + val search_snippet_get : 481 481 + account_id:Jmap_proto.Id.t -> 482 482 + filter:Jmap_proto.Mail_filter.email_filter -> 483 483 + email_ids:id_source -> 484 484 + unit -> 485 485 + (get, Jmap_proto.Search_snippet.t Jmap_proto.Method.get_response) handle t 486 486 + (** Build a SearchSnippet/get invocation. Note that the filter must match 487 487 + the filter used in the Email/query that produced the email IDs. *) 488 488 + 489 489 + (** {2 VacationResponse Methods} *) 490 490 + 491 491 + val vacation_response_get : 492 492 + account_id:Jmap_proto.Id.t -> 493 493 + ?properties:string list -> 494 494 + unit -> 495 495 + (get, Jmap_proto.Vacation.t Jmap_proto.Method.get_response) handle t 496 496 + 497 497 + val vacation_response_set : 498 498 + account_id:Jmap_proto.Id.t -> 499 499 + ?if_in_state:string -> 500 500 + update:Jsont.Json.t -> 501 501 + unit -> 502 502 + (set, Jmap_proto.Vacation.t Jmap_proto.Method.set_response) handle t 503 503 + (** VacationResponse is a singleton - you can only update "singleton". *) 504 504 + 505 505 + (** {1 Response Parsing} *) 506 506 + 507 507 + val parse : 508 508 + (_, 'resp) handle -> 509 509 + Jmap_proto.Response.t -> 510 510 + ('resp, Jsont.Error.t) result 511 511 + (** [parse handle response] extracts and parses the response for [handle]. 512 512 + 513 513 + The response type is determined by the handle's type parameter, 514 514 + providing compile-time type safety. *) 515 515 + 516 516 + val parse_exn : (_, 'resp) handle -> Jmap_proto.Response.t -> 'resp 517 517 + (** [parse_exn handle response] is like {!parse} but raises on error. *) 518 518 + 519 519 + (** {1 JSON Helpers} 520 520 + 521 521 + Convenience functions for building JSON patch objects for /set methods. *) 522 522 + 523 523 + val json_null : Jsont.Json.t 524 524 + (** A JSON null value. Use to unset a property. *) 525 525 + 526 526 + val json_bool : bool -> Jsont.Json.t 527 527 + (** [json_bool b] creates a JSON boolean. *) 528 528 + 529 529 + val json_string : string -> Jsont.Json.t 530 530 + (** [json_string s] creates a JSON string. *) 531 531 + 532 532 + val json_int : int64 -> Jsont.Json.t 533 533 + (** [json_int n] creates a JSON number from an int64. *) 534 534 + 535 535 + val json_obj : (string * Jsont.Json.t) list -> Jsont.Json.t 536 536 + (** [json_obj fields] creates a JSON object from key-value pairs. *) 537 537 + 538 538 + val json_array : Jsont.Json.t list -> Jsont.Json.t 539 539 + (** [json_array items] creates a JSON array. *) 540 540 + 541 541 + (** {1 Creation ID Helpers} *) 542 542 + 543 543 + val fresh_create_id : unit -> 'a create_id t 544 544 + (** [fresh_create_id ()] generates a fresh creation ID within the chain. 545 545 + The ID is unique within the request. *) 546 546 + 547 547 + (** {1 Low-Level Access} 548 548 + 549 549 + For users who need direct access to the underlying invocation. *) 550 550 + 551 551 + val raw_invocation : 552 552 + name:string -> 553 553 + arguments:Jsont.Json.t -> 554 554 + (unit, Jsont.Json.t) handle t 555 555 + (** [raw_invocation ~name ~arguments] adds a raw method invocation. 556 556 + Use this for methods not yet supported by the high-level API. *)

+44 -91

lib/core/jmap.ml

··· 130 130 let is_subscribed m = Proto.Mailbox.is_subscribed m 131 131 132 132 let role m = 133 133 - let convert_role = function 134 134 - | Proto.Mailbox.Inbox -> `Inbox 135 135 - | Proto.Mailbox.Sent -> `Sent 136 136 - | Proto.Mailbox.Drafts -> `Drafts 137 137 - | Proto.Mailbox.Trash -> `Trash 138 138 - | Proto.Mailbox.Junk -> `Junk 139 139 - | Proto.Mailbox.Archive -> `Archive 140 140 - | Proto.Mailbox.Flagged -> `Flagged 141 141 - | Proto.Mailbox.Important -> `Important 142 142 - | Proto.Mailbox.All -> `All 143 143 - | Proto.Mailbox.Subscribed -> `Subscribed 144 144 - | Proto.Mailbox.Other s -> `Custom s 133 133 + (* Proto.Mailbox.role now returns polymorphic variants directly *) 134 134 + let convert_role : Proto.Mailbox.role -> Role.t = function 135 135 + | `Inbox -> `Inbox 136 136 + | `Sent -> `Sent 137 137 + | `Drafts -> `Drafts 138 138 + | `Trash -> `Trash 139 139 + | `Junk -> `Junk 140 140 + | `Archive -> `Archive 141 141 + | `Flagged -> `Flagged 142 142 + | `Important -> `Important 143 143 + | `All -> `All 144 144 + | `Subscribed -> `Subscribed 145 145 + | `Snoozed -> `Snoozed 146 146 + | `Scheduled -> `Scheduled 147 147 + | `Memos -> `Memos 148 148 + | `Other s -> `Custom s 145 149 in 146 150 Option.map convert_role (Proto.Mailbox.role m) 147 151 ··· 212 216 213 217 (** Get active keywords as polymorphic variants. *) 214 218 let keywords e = 215 215 - let kw_map = Proto.Email.keywords e in 216 216 - List.filter_map (fun (k, v) -> 217 217 - if v then Some (Keyword.of_string k) else None 218 218 - ) 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 219 225 220 226 (** Check if email has a specific keyword. *) 221 227 let has_keyword kw e = 222 228 let kw_str = Keyword.to_string kw in 223 223 - let kw_map = Proto.Email.keywords e in 224 224 - 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 225 232 226 233 let from e = Proto.Email.from e 227 234 let to_ e = Proto.Email.to_ e ··· 347 354 module Mailbox_filter = struct 348 355 type condition = Proto.Mailbox.Filter_condition.t 349 356 350 350 - let convert_role = function 351 351 - | `Inbox -> Proto.Mailbox.Inbox 352 352 - | `Sent -> Proto.Mailbox.Sent 353 353 - | `Drafts -> Proto.Mailbox.Drafts 354 354 - | `Trash -> Proto.Mailbox.Trash 355 355 - | `Junk -> Proto.Mailbox.Junk 356 356 - | `Archive -> Proto.Mailbox.Archive 357 357 - | `Flagged -> Proto.Mailbox.Flagged 358 358 - | `Important -> Proto.Mailbox.Important 359 359 - | `All -> Proto.Mailbox.All 360 360 - | `Subscribed -> Proto.Mailbox.Subscribed 361 361 - | `Custom s -> Proto.Mailbox.Other s 357 357 + let convert_role : Role.t -> Proto.Mailbox.role = function 358 358 + | `Inbox -> `Inbox 359 359 + | `Sent -> `Sent 360 360 + | `Drafts -> `Drafts 361 361 + | `Trash -> `Trash 362 362 + | `Junk -> `Junk 363 363 + | `Archive -> `Archive 364 364 + | `Flagged -> `Flagged 365 365 + | `Important -> `Important 366 366 + | `All -> `All 367 367 + | `Subscribed -> `Subscribed 368 368 + | `Snoozed -> `Snoozed 369 369 + | `Scheduled -> `Scheduled 370 370 + | `Memos -> `Memos 371 371 + | `Custom s -> `Other s 362 372 363 373 (** Create a mailbox filter condition. 364 374 ··· 428 438 val to_string : t -> (string, Error.t) result 429 439 end 430 440 431 431 - (** {1 Private Interface} *) 441 441 + (** {1 Request Chaining} *) 432 442 433 433 - (** Private module for internal use by Jmap_eio. 443 443 + (** JMAP method chaining with automatic result references. 434 444 435 435 - This exposes the underlying Jsont codecs for serialization. *) 436 436 - module Private = struct 437 437 - module Session = struct 438 438 - let jsont = Proto.Session.jsont 439 439 - end 440 440 - 441 441 - module Request = struct 442 442 - let jsont = Proto.Request.jsont 443 443 - end 444 444 - 445 445 - module Response = struct 446 446 - let jsont = Proto.Response.jsont 447 447 - end 448 448 - 449 449 - module Mailbox = struct 450 450 - let jsont = Proto.Mailbox.jsont 451 451 - end 452 452 - 453 453 - module Email = struct 454 454 - let jsont = Proto.Email.jsont 455 455 - end 456 456 - 457 457 - module Thread = struct 458 458 - let jsont = Proto.Thread.jsont 459 459 - end 460 460 - 461 461 - module Identity = struct 462 462 - let jsont = Proto.Identity.jsont 463 463 - end 464 464 - 465 465 - module Submission = struct 466 466 - let jsont = Proto.Submission.jsont 467 467 - end 468 468 - 469 469 - module Vacation = struct 470 470 - let jsont = Proto.Vacation.jsont 471 471 - end 472 472 - 473 473 - module Blob = struct 474 474 - let upload_response_jsont = Proto.Blob.upload_response_jsont 475 475 - end 476 476 - 477 477 - module Method = struct 478 478 - let get_response_jsont = Proto.Method.get_response_jsont 479 479 - let query_response_jsont = Proto.Method.query_response_jsont 480 480 - let changes_response_jsont = Proto.Method.changes_response_jsont 481 481 - let set_response_jsont = Proto.Method.set_response_jsont 482 482 - end 483 483 - 484 484 - module Mail_filter = struct 485 485 - let email_filter_jsont = Proto.Mail_filter.email_filter_jsont 486 486 - let mailbox_filter_jsont = Proto.Mail_filter.mailbox_filter_jsont 487 487 - let submission_filter_jsont = Proto.Mail_filter.submission_filter_jsont 488 488 - end 489 489 - 490 490 - module Filter = struct 491 491 - let comparator_jsont = Proto.Filter.comparator_jsont 492 492 - end 493 493 - end 445 445 + See {!Chain} for the full interface. *) 446 446 + module Chain = Chain

+116 -102

lib/core/jmap.mli

··· 99 99 Standard keywords are represented as polymorphic variants. 100 100 Custom keywords use [`Custom of string]. *) 101 101 module Keyword : sig 102 102 - type t = [ 102 102 + (** RFC 8621 standard keywords *) 103 103 + type standard = [ 103 104 | `Seen 104 105 | `Flagged 105 106 | `Answered ··· 108 109 | `Phishing 109 110 | `Junk 110 111 | `NotJunk 112 112 + ] 113 113 + 114 114 + (** draft-ietf-mailmaint extended keywords *) 115 115 + type extended = [ 116 116 + | `Notify 117 117 + | `Muted 118 118 + | `Followed 119 119 + | `Memo 120 120 + | `HasMemo 121 121 + | `HasAttachment 122 122 + | `HasNoAttachment 123 123 + | `AutoSent 124 124 + | `Unsubscribed 125 125 + | `CanUnsubscribe 126 126 + | `Imported 127 127 + | `IsTrusted 128 128 + | `MaskedEmail 129 129 + | `New 130 130 + ] 131 131 + 132 132 + (** Apple Mail flag color keywords *) 133 133 + type flag_bits = [ 134 134 + | `MailFlagBit0 135 135 + | `MailFlagBit1 136 136 + | `MailFlagBit2 137 137 + ] 138 138 + 139 139 + type t = [ 140 140 + | standard 141 141 + | extended 142 142 + | flag_bits 111 143 | `Custom of string 112 144 ] 113 145 114 146 val of_string : string -> t 115 147 val to_string : t -> string 116 148 val pp : Format.formatter -> t -> unit 149 149 + 150 150 + (** Apple Mail flag colors *) 151 151 + type flag_color = [ 152 152 + | `Red 153 153 + | `Orange 154 154 + | `Yellow 155 155 + | `Green 156 156 + | `Blue 157 157 + | `Purple 158 158 + | `Gray 159 159 + ] 160 160 + 161 161 + val flag_color_of_keywords : t list -> flag_color option 162 162 + (** [flag_color_of_keywords keywords] extracts the flag color from a list 163 163 + of keywords. Returns [None] for invalid bit combinations. *) 164 164 + 165 165 + val flag_color_to_keywords : flag_color -> t list 166 166 + (** [flag_color_to_keywords color] returns the keywords to set for the color. *) 117 167 end 118 168 119 169 (** Mailbox role type. ··· 121 171 Standard roles are represented as polymorphic variants. 122 172 Custom roles use [`Custom of string]. *) 123 173 module Role : sig 124 124 - type t = [ 174 174 + (** RFC 8621 standard roles *) 175 175 + type standard = [ 125 176 | `Inbox 126 177 | `Sent 127 178 | `Drafts ··· 132 183 | `Important 133 184 | `All 134 185 | `Subscribed 186 186 + ] 187 187 + 188 188 + (** draft-ietf-mailmaint extended roles *) 189 189 + type extended = [ 190 190 + | `Snoozed 191 191 + | `Scheduled 192 192 + | `Memos 193 193 + ] 194 194 + 195 195 + type t = [ 196 196 + | standard 197 197 + | extended 135 198 | `Custom of string 136 199 ] 137 200 ··· 204 267 val create : ?name:string -> string -> t 205 268 end 206 269 207 207 - (** Email mailbox. *) 270 270 + (** Email mailbox. 271 271 + All accessors return option types since responses only include requested properties. *) 208 272 module Mailbox : sig 209 273 type t 210 274 211 211 - val id : t -> Id.t 212 212 - val name : t -> string 275 275 + val id : t -> Id.t option 276 276 + val name : t -> string option 213 277 val parent_id : t -> Id.t option 214 214 - val sort_order : t -> int64 215 215 - val total_emails : t -> int64 216 216 - val unread_emails : t -> int64 217 217 - val total_threads : t -> int64 218 218 - val unread_threads : t -> int64 219 219 - 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 220 284 val role : t -> Role.t option 221 285 222 286 (** Mailbox rights. *) ··· 234 298 val may_submit : t -> bool 235 299 end 236 300 237 237 - val my_rights : t -> Rights.t 301 301 + val my_rights : t -> Rights.t option 238 302 end 239 303 240 240 - (** Email thread. *) 304 304 + (** Email thread. 305 305 + All accessors return option types since responses only include requested properties. *) 241 306 module Thread : sig 242 307 type t 243 308 244 244 - val id : t -> Id.t 245 245 - 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 246 311 end 247 312 248 313 (** Email message. *) ··· 268 333 val value_is_encoding_problem : value -> bool 269 334 end 270 335 336 336 + (** All accessors return option types since responses only include requested properties. *) 271 337 type t 272 338 273 273 - val id : t -> Id.t 274 274 - val blob_id : t -> Id.t 275 275 - val thread_id : t -> Id.t 276 276 - val mailbox_ids : t -> (Id.t * bool) list 277 277 - val size : t -> int64 278 278 - 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 279 345 val message_id : t -> string list option 280 346 val in_reply_to : t -> string list option 281 347 val references : t -> string list option 282 348 val subject : t -> string option 283 349 val sent_at : t -> Ptime.t option 284 284 - val has_attachment : t -> bool 285 285 - val preview : t -> string 350 350 + val has_attachment : t -> bool option 351 351 + val preview : t -> string option 286 352 287 287 - (** 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. *) 288 355 val keywords : t -> Keyword.t list 289 356 290 290 - (** 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. *) 291 359 val has_keyword : Keyword.t -> t -> bool 292 360 293 361 val from : t -> Email_address.t list option ··· 303 371 val body_values : t -> (string * Body.value) list option 304 372 end 305 373 306 306 - (** Email identity for sending. *) 374 374 + (** Email identity for sending. 375 375 + All accessors return option types since responses only include requested properties. *) 307 376 module Identity : sig 308 377 type t 309 378 310 310 - val id : t -> Id.t 311 311 - val name : t -> string 312 312 - 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 313 382 val reply_to : t -> Email_address.t list option 314 383 val bcc : t -> Email_address.t list option 315 315 - val text_signature : t -> string 316 316 - val html_signature : t -> string 317 317 - 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 318 387 end 319 388 320 320 - (** 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. *) 321 391 module Submission : sig 322 392 type t 323 393 324 324 - val id : t -> Id.t 325 325 - val identity_id : t -> Id.t 326 326 - val email_id : t -> Id.t 327 327 - val thread_id : t -> Id.t 328 328 - val send_at : t -> Ptime.t 329 329 - 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 330 400 val delivery_status : t -> (string * Proto.Submission.Delivery_status.t) list option 331 331 - val dsn_blob_ids : t -> Id.t list 332 332 - 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 333 403 end 334 404 335 405 (** Vacation auto-response. *) ··· 453 523 val to_string : t -> (string, Error.t) result 454 524 end 455 525 456 456 - (** {1 Private Interface} *) 457 457 - 458 458 - (** Private module for internal use by Jmap_eio. 459 459 - 460 460 - This exposes the underlying Jsont codecs for serialization. *) 461 461 - module Private : sig 462 462 - module Session : sig 463 463 - val jsont : Proto.Session.t Jsont.t 464 464 - end 465 465 - 466 466 - module Request : sig 467 467 - val jsont : Proto.Request.t Jsont.t 468 468 - end 469 469 - 470 470 - module Response : sig 471 471 - val jsont : Proto.Response.t Jsont.t 472 472 - end 473 473 - 474 474 - module Mailbox : sig 475 475 - val jsont : Proto.Mailbox.t Jsont.t 476 476 - end 477 477 - 478 478 - module Email : sig 479 479 - val jsont : Proto.Email.t Jsont.t 480 480 - end 481 481 - 482 482 - module Thread : sig 483 483 - val jsont : Proto.Thread.t Jsont.t 484 484 - end 485 485 - 486 486 - module Identity : sig 487 487 - val jsont : Proto.Identity.t Jsont.t 488 488 - end 526 526 + (** {1 Request Chaining} *) 489 527 490 490 - module Submission : sig 491 491 - val jsont : Proto.Submission.t Jsont.t 492 492 - end 528 528 + (** JMAP method chaining with automatic result references. 493 529 494 494 - module Vacation : sig 495 495 - val jsont : Proto.Vacation.t Jsont.t 496 496 - end 497 497 - 498 498 - module Blob : sig 499 499 - val upload_response_jsont : Proto.Blob.upload_response Jsont.t 500 500 - end 501 501 - 502 502 - module Method : sig 503 503 - val get_response_jsont : 'a Jsont.t -> 'a Proto.Method.get_response Jsont.t 504 504 - val query_response_jsont : Proto.Method.query_response Jsont.t 505 505 - val changes_response_jsont : Proto.Method.changes_response Jsont.t 506 506 - val set_response_jsont : 'a Jsont.t -> 'a Proto.Method.set_response Jsont.t 507 507 - end 508 508 - 509 509 - module Mail_filter : sig 510 510 - val email_filter_jsont : Proto.Mail_filter.email_filter Jsont.t 511 511 - val mailbox_filter_jsont : Proto.Mail_filter.mailbox_filter Jsont.t 512 512 - val submission_filter_jsont : Proto.Mail_filter.submission_filter Jsont.t 513 513 - end 514 514 - 515 515 - module Filter : sig 516 516 - val comparator_jsont : Proto.Filter.comparator Jsont.t 517 517 - end 518 518 - end 530 530 + This module provides a monadic interface for building JMAP requests 531 531 + where method calls can reference results from previous calls. *) 532 532 + module Chain = Chain

+132 -2

lib/core/jmap_types.ml

··· 82 82 (** {1 Keyword Type} *) 83 83 84 84 module Keyword = struct 85 85 - type t = [ 85 85 + (** RFC 8621 standard keywords *) 86 86 + type standard = [ 86 87 | `Seen 87 88 | `Flagged 88 89 | `Answered ··· 91 92 | `Phishing 92 93 | `Junk 93 94 | `NotJunk 95 95 + ] 96 96 + 97 97 + (** draft-ietf-mailmaint extended keywords *) 98 98 + type extended = [ 99 99 + | `Notify 100 100 + | `Muted 101 101 + | `Followed 102 102 + | `Memo 103 103 + | `HasMemo 104 104 + | `HasAttachment 105 105 + | `HasNoAttachment 106 106 + | `AutoSent 107 107 + | `Unsubscribed 108 108 + | `CanUnsubscribe 109 109 + | `Imported 110 110 + | `IsTrusted 111 111 + | `MaskedEmail 112 112 + | `New 113 113 + ] 114 114 + 115 115 + (** Apple Mail flag color keywords *) 116 116 + type flag_bits = [ 117 117 + | `MailFlagBit0 118 118 + | `MailFlagBit1 119 119 + | `MailFlagBit2 120 120 + ] 121 121 + 122 122 + type t = [ 123 123 + | standard 124 124 + | extended 125 125 + | flag_bits 94 126 | `Custom of string 95 127 ] 96 128 97 129 let of_string = function 130 130 + (* RFC 8621 standard keywords *) 98 131 | "$seen" -> `Seen 99 132 | "$flagged" -> `Flagged 100 133 | "$answered" -> `Answered ··· 103 136 | "$phishing" -> `Phishing 104 137 | "$junk" -> `Junk 105 138 | "$notjunk" -> `NotJunk 139 139 + (* draft-ietf-mailmaint extended keywords *) 140 140 + | "$notify" -> `Notify 141 141 + | "$muted" -> `Muted 142 142 + | "$followed" -> `Followed 143 143 + | "$memo" -> `Memo 144 144 + | "$hasmemo" -> `HasMemo 145 145 + | "$hasattachment" -> `HasAttachment 146 146 + | "$hasnoattachment" -> `HasNoAttachment 147 147 + | "$autosent" -> `AutoSent 148 148 + | "$unsubscribed" -> `Unsubscribed 149 149 + | "$canunsubscribe" -> `CanUnsubscribe 150 150 + | "$imported" -> `Imported 151 151 + | "$istrusted" -> `IsTrusted 152 152 + | "$maskedemail" -> `MaskedEmail 153 153 + | "$new" -> `New 154 154 + (* Apple Mail flag color keywords *) 155 155 + | "$MailFlagBit0" -> `MailFlagBit0 156 156 + | "$MailFlagBit1" -> `MailFlagBit1 157 157 + | "$MailFlagBit2" -> `MailFlagBit2 106 158 | s -> `Custom s 107 159 108 160 let to_string = function 161 161 + (* RFC 8621 standard keywords *) 109 162 | `Seen -> "$seen" 110 163 | `Flagged -> "$flagged" 111 164 | `Answered -> "$answered" ··· 114 167 | `Phishing -> "$phishing" 115 168 | `Junk -> "$junk" 116 169 | `NotJunk -> "$notjunk" 170 170 + (* draft-ietf-mailmaint extended keywords *) 171 171 + | `Notify -> "$notify" 172 172 + | `Muted -> "$muted" 173 173 + | `Followed -> "$followed" 174 174 + | `Memo -> "$memo" 175 175 + | `HasMemo -> "$hasmemo" 176 176 + | `HasAttachment -> "$hasattachment" 177 177 + | `HasNoAttachment -> "$hasnoattachment" 178 178 + | `AutoSent -> "$autosent" 179 179 + | `Unsubscribed -> "$unsubscribed" 180 180 + | `CanUnsubscribe -> "$canunsubscribe" 181 181 + | `Imported -> "$imported" 182 182 + | `IsTrusted -> "$istrusted" 183 183 + | `MaskedEmail -> "$maskedemail" 184 184 + | `New -> "$new" 185 185 + (* Apple Mail flag color keywords *) 186 186 + | `MailFlagBit0 -> "$MailFlagBit0" 187 187 + | `MailFlagBit1 -> "$MailFlagBit1" 188 188 + | `MailFlagBit2 -> "$MailFlagBit2" 117 189 | `Custom s -> s 118 190 119 191 let pp ppf k = Format.pp_print_string ppf (to_string k) 192 192 + 193 193 + (** Apple Mail flag colors *) 194 194 + type flag_color = [ 195 195 + | `Red 196 196 + | `Orange 197 197 + | `Yellow 198 198 + | `Green 199 199 + | `Blue 200 200 + | `Purple 201 201 + | `Gray 202 202 + ] 203 203 + 204 204 + let flag_color_of_keywords (keywords : t list) : flag_color option = 205 205 + let has k = List.mem k keywords in 206 206 + let bit0 = has `MailFlagBit0 in 207 207 + let bit1 = has `MailFlagBit1 in 208 208 + let bit2 = has `MailFlagBit2 in 209 209 + match (bit0, bit1, bit2) with 210 210 + | (false, false, false) -> Some `Red 211 211 + | (true, false, false) -> Some `Orange 212 212 + | (false, true, false) -> Some `Yellow 213 213 + | (true, true, true) -> Some `Green 214 214 + | (false, false, true) -> Some `Blue 215 215 + | (true, false, true) -> Some `Purple 216 216 + | (false, true, true) -> Some `Gray 217 217 + | (true, true, false) -> None 218 218 + 219 219 + let flag_color_to_keywords : flag_color -> t list = function 220 220 + | `Red -> [] 221 221 + | `Orange -> [`MailFlagBit0] 222 222 + | `Yellow -> [`MailFlagBit1] 223 223 + | `Green -> [`MailFlagBit0; `MailFlagBit1; `MailFlagBit2] 224 224 + | `Blue -> [`MailFlagBit2] 225 225 + | `Purple -> [`MailFlagBit0; `MailFlagBit2] 226 226 + | `Gray -> [`MailFlagBit1; `MailFlagBit2] 120 227 end 121 228 122 229 (** {1 Mailbox Role Type} *) 123 230 124 231 module Role = struct 125 125 - type t = [ 232 232 + (** RFC 8621 standard roles *) 233 233 + type standard = [ 126 234 | `Inbox 127 235 | `Sent 128 236 | `Drafts ··· 133 241 | `Important 134 242 | `All 135 243 | `Subscribed 244 244 + ] 245 245 + 246 246 + (** draft-ietf-mailmaint extended roles *) 247 247 + type extended = [ 248 248 + | `Snoozed 249 249 + | `Scheduled 250 250 + | `Memos 251 251 + ] 252 252 + 253 253 + type t = [ 254 254 + | standard 255 255 + | extended 136 256 | `Custom of string 137 257 ] 138 258 139 259 let of_string = function 260 260 + (* RFC 8621 standard roles *) 140 261 | "inbox" -> `Inbox 141 262 | "sent" -> `Sent 142 263 | "drafts" -> `Drafts ··· 147 268 | "important" -> `Important 148 269 | "all" -> `All 149 270 | "subscribed" -> `Subscribed 271 271 + (* draft-ietf-mailmaint extended roles *) 272 272 + | "snoozed" -> `Snoozed 273 273 + | "scheduled" -> `Scheduled 274 274 + | "memos" -> `Memos 150 275 | s -> `Custom s 151 276 152 277 let to_string = function 278 278 + (* RFC 8621 standard roles *) 153 279 | `Inbox -> "inbox" 154 280 | `Sent -> "sent" 155 281 | `Drafts -> "drafts" ··· 160 286 | `Important -> "important" 161 287 | `All -> "all" 162 288 | `Subscribed -> "subscribed" 289 289 + (* draft-ietf-mailmaint extended roles *) 290 290 + | `Snoozed -> "snoozed" 291 291 + | `Scheduled -> "scheduled" 292 292 + | `Memos -> "memos" 163 293 | `Custom s -> s 164 294 165 295 let pp ppf r = Format.pp_print_string ppf (to_string r)

+1

lib/dune

··· 8 8 ; Core unified interface 9 9 jmap 10 10 jmap_types 11 11 + chain 11 12 ; Protocol layer wrapper (combines core + mail) 12 13 jmap_proto 13 14 ; Core protocol modules

+8

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 + (optional) 7 7 + (libraries jmap brr jsont.brr) 8 8 + (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. *)

+359 -55

lib/mail/mail_email.ml

··· 4 4 ---------------------------------------------------------------------------*) 5 5 6 6 module Keyword = struct 7 7 + (* RFC 8621 Standard Keywords *) 7 8 let draft = "$draft" 8 9 let seen = "$seen" 9 10 let flagged = "$flagged" ··· 12 13 let phishing = "$phishing" 13 14 let junk = "$junk" 14 15 let not_junk = "$notjunk" 16 16 + 17 17 + (* draft-ietf-mailmaint Extended Keywords *) 18 18 + let notify = "$notify" 19 19 + let muted = "$muted" 20 20 + let followed = "$followed" 21 21 + let memo = "$memo" 22 22 + let has_memo = "$hasmemo" 23 23 + let has_attachment = "$hasattachment" 24 24 + let has_no_attachment = "$hasnoattachment" 25 25 + let auto_sent = "$autosent" 26 26 + let unsubscribed = "$unsubscribed" 27 27 + let can_unsubscribe = "$canunsubscribe" 28 28 + let imported = "$imported" 29 29 + let is_trusted = "$istrusted" 30 30 + let masked_email = "$maskedemail" 31 31 + let new_ = "$new" 32 32 + 33 33 + (* Apple Mail Flag Color Keywords *) 34 34 + let mail_flag_bit0 = "$MailFlagBit0" 35 35 + let mail_flag_bit1 = "$MailFlagBit1" 36 36 + let mail_flag_bit2 = "$MailFlagBit2" 37 37 + 38 38 + type flag_color = [ 39 39 + | `Red 40 40 + | `Orange 41 41 + | `Yellow 42 42 + | `Green 43 43 + | `Blue 44 44 + | `Purple 45 45 + | `Gray 46 46 + ] 47 47 + 48 48 + let flag_color_to_keywords = function 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] 56 56 + 57 57 + let flag_color_of_keywords keywords = 58 58 + let has k = List.mem k keywords in 59 59 + let bit0 = has mail_flag_bit0 in 60 60 + let bit1 = has mail_flag_bit1 in 61 61 + let bit2 = has mail_flag_bit2 in 62 62 + match (bit0, bit1, bit2) with 63 63 + | (false, false, false) -> Some `Red 64 64 + | (true, false, false) -> Some `Orange 65 65 + | (false, true, false) -> Some `Yellow 66 66 + | (true, true, true) -> Some `Green 67 67 + | (false, false, true) -> Some `Blue 68 68 + | (true, false, true) -> Some `Purple 69 69 + | (false, true, true) -> Some `Gray 70 70 + | (true, true, false) -> None 15 71 end 16 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 + 17 239 type t = { 18 18 - id : Proto_id.t; 19 19 - blob_id : Proto_id.t; 20 20 - thread_id : Proto_id.t; 21 21 - size : int64; 22 22 - received_at : Ptime.t; 23 23 - mailbox_ids : (Proto_id.t * bool) list; 24 24 - 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; 25 247 message_id : string list option; 26 248 in_reply_to : string list option; 27 249 references : string list option; ··· 39 261 text_body : Mail_body.Part.t list option; 40 262 html_body : Mail_body.Part.t list option; 41 263 attachments : Mail_body.Part.t list option; 42 42 - has_attachment : bool; 43 43 - preview : string; 264 264 + has_attachment : bool option; 265 265 + preview : string option; 266 266 + dynamic_headers : (string * Jsont.json) list; 44 267 } 45 268 46 269 let id t = t.id ··· 69 292 let attachments t = t.attachments 70 293 let has_attachment t = t.has_attachment 71 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 72 344 73 345 let make id blob_id thread_id size received_at mailbox_ids keywords 74 346 message_id in_reply_to references sender from to_ cc bcc reply_to 75 347 subject sent_at headers body_structure body_values text_body html_body 76 76 - attachments has_attachment preview = 348 348 + attachments has_attachment preview dynamic_headers = 77 349 { id; blob_id; thread_id; size; received_at; mailbox_ids; keywords; 78 350 message_id; in_reply_to; references; sender; from; to_; cc; bcc; 79 351 reply_to; subject; sent_at; headers; body_structure; body_values; 80 80 - 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 81 369 82 370 let jsont = 83 371 let kind = "Email" in 84 372 let body_values_jsont = Proto_json_map.of_string Mail_body.Value.jsont in 85 85 - (* subject can be null per RFC 8621 Section 4.1.1 *) 86 86 - let nullable_string = Jsont.(option string) in 87 87 - Jsont.Object.map ~kind make 88 88 - |> Jsont.Object.mem "id" Proto_id.jsont ~enc:id 89 89 - |> Jsont.Object.mem "blobId" Proto_id.jsont ~enc:blob_id 90 90 - |> Jsont.Object.mem "threadId" Proto_id.jsont ~enc:thread_id 91 91 - |> Jsont.Object.mem "size" Proto_int53.Unsigned.jsont ~enc:size 92 92 - |> Jsont.Object.mem "receivedAt" Proto_date.Utc.jsont ~enc:received_at 93 93 - |> Jsont.Object.mem "mailboxIds" Proto_json_map.id_to_bool ~enc:mailbox_ids 94 94 - |> Jsont.Object.mem "keywords" Proto_json_map.string_to_bool ~dec_absent:[] ~enc:keywords 95 95 - (* Header fields can be absent or null per RFC 8621 *) 96 96 - |> Jsont.Object.mem "messageId" Jsont.(option (list string)) 97 97 - ~dec_absent:None ~enc_omit:Option.is_none ~enc:message_id 98 98 - |> Jsont.Object.mem "inReplyTo" Jsont.(option (list string)) 99 99 - ~dec_absent:None ~enc_omit:Option.is_none ~enc:in_reply_to 100 100 - |> Jsont.Object.mem "references" Jsont.(option (list string)) 101 101 - ~dec_absent:None ~enc_omit:Option.is_none ~enc:references 102 102 - |> Jsont.Object.mem "sender" Jsont.(option (list Mail_address.jsont)) 103 103 - ~dec_absent:None ~enc_omit:Option.is_none ~enc:sender 104 104 - |> Jsont.Object.mem "from" Jsont.(option (list Mail_address.jsont)) 105 105 - ~dec_absent:None ~enc_omit:Option.is_none ~enc:from 106 106 - |> Jsont.Object.mem "to" Jsont.(option (list Mail_address.jsont)) 107 107 - ~dec_absent:None ~enc_omit:Option.is_none ~enc:to_ 108 108 - |> Jsont.Object.mem "cc" Jsont.(option (list Mail_address.jsont)) 109 109 - ~dec_absent:None ~enc_omit:Option.is_none ~enc:cc 110 110 - |> Jsont.Object.mem "bcc" Jsont.(option (list Mail_address.jsont)) 111 111 - ~dec_absent:None ~enc_omit:Option.is_none ~enc:bcc 112 112 - |> Jsont.Object.mem "replyTo" Jsont.(option (list Mail_address.jsont)) 113 113 - ~dec_absent:None ~enc_omit:Option.is_none ~enc:reply_to 114 114 - |> Jsont.Object.mem "subject" nullable_string 115 115 - ~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 116 404 |> Jsont.Object.opt_mem "sentAt" Proto_date.Rfc3339.jsont ~enc:sent_at 117 117 - |> Jsont.Object.opt_mem "headers" (Jsont.list Mail_header.jsont) ~enc:headers 405 405 + |> Jsont.Object.opt_mem "headers" hdr_list ~enc:headers 118 406 |> Jsont.Object.opt_mem "bodyStructure" Mail_body.Part.jsont ~enc:body_structure 119 407 |> Jsont.Object.opt_mem "bodyValues" body_values_jsont ~enc:body_values 120 120 - |> Jsont.Object.opt_mem "textBody" (Jsont.list Mail_body.Part.jsont) ~enc:text_body 121 121 - |> Jsont.Object.opt_mem "htmlBody" (Jsont.list Mail_body.Part.jsont) ~enc:html_body 122 122 - |> Jsont.Object.opt_mem "attachments" (Jsont.list Mail_body.Part.jsont) ~enc:attachments 123 123 - |> Jsont.Object.mem "hasAttachment" Jsont.bool ~dec_absent:false ~enc:has_attachment 124 124 - |> 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) 125 416 |> Jsont.Object.finish 126 417 127 418 module Filter_condition = struct ··· 157 448 none_in_thread_have_keyword; has_keyword; not_keyword; has_attachment; 158 449 text; from; to_; cc; bcc; subject; body; header } 159 450 160 160 - (* Header filter is encoded as [name] or [name, value] array *) 161 451 let header_jsont = 162 452 let kind = "HeaderFilter" in 163 453 let dec json = ··· 203 493 end 204 494 205 495 type get_args_extra = { 206 206 - body_properties : string list option; 496 496 + body_properties : body_part_property list option; 207 497 fetch_text_body_values : bool; 208 498 fetch_html_body_values : bool; 209 499 fetch_all_body_values : bool; 210 500 max_body_value_bytes : int64 option; 211 501 } 212 502 213 213 - let get_args_extra_make body_properties fetch_text_body_values 214 214 - 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 () = 215 506 { body_properties; fetch_text_body_values; fetch_html_body_values; 216 507 fetch_all_body_values; max_body_value_bytes } 217 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) 516 516 + 218 517 let get_args_extra_jsont = 219 518 let kind = "Email/get extra args" in 220 220 - Jsont.Object.map ~kind get_args_extra_make 221 221 - |> 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) 222 525 |> Jsont.Object.mem "fetchTextBodyValues" Jsont.bool ~dec_absent:false 223 526 ~enc:(fun a -> a.fetch_text_body_values) ~enc_omit:(fun b -> not b) 224 527 |> Jsont.Object.mem "fetchHTMLBodyValues" Jsont.bool ~dec_absent:false 225 528 ~enc:(fun a -> a.fetch_html_body_values) ~enc_omit:(fun b -> not b) 226 529 |> Jsont.Object.mem "fetchAllBodyValues" Jsont.bool ~dec_absent:false 227 530 ~enc:(fun a -> a.fetch_all_body_values) ~enc_omit:(fun b -> not b) 228 228 - |> 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) 229 533 |> Jsont.Object.finish

+282 -29

lib/mail/mail_email.mli

··· 9 9 10 10 (** {1 Standard Keywords} *) 11 11 12 12 - (** Standard email keywords per RFC 8621. *) 12 12 + (** Standard email keywords per RFC 8621 and draft-ietf-mailmaint. 13 13 + 14 14 + Keywords are stored as strings in JMAP, but these constants provide 15 15 + type-safe access to standard keywords. *) 13 16 module Keyword : sig 17 17 + 18 18 + (** {2 RFC 8621 Standard Keywords} *) 19 19 + 14 20 val draft : string 15 15 - (** ["$draft"] *) 21 21 + (** ["$draft"] - The Email is a draft the user is composing. *) 16 22 17 23 val seen : string 18 18 - (** ["$seen"] *) 24 24 + (** ["$seen"] - The Email has been read. *) 19 25 20 26 val flagged : string 21 21 - (** ["$flagged"] *) 27 27 + (** ["$flagged"] - The Email has been flagged for urgent/special attention. *) 22 28 23 29 val answered : string 24 24 - (** ["$answered"] *) 30 30 + (** ["$answered"] - The Email has been replied to. *) 25 31 26 32 val forwarded : string 27 27 - (** ["$forwarded"] *) 33 33 + (** ["$forwarded"] - The Email has been forwarded. *) 28 34 29 35 val phishing : string 30 30 - (** ["$phishing"] *) 36 36 + (** ["$phishing"] - The Email is highly likely to be phishing. *) 31 37 32 38 val junk : string 33 33 - (** ["$junk"] *) 39 39 + (** ["$junk"] - The Email is definitely spam. *) 34 40 35 41 val not_junk : string 36 36 - (** ["$notjunk"] *) 42 42 + (** ["$notjunk"] - The Email is definitely not spam. *) 43 43 + 44 44 + (** {2 draft-ietf-mailmaint Extended Keywords} *) 45 45 + 46 46 + val notify : string 47 47 + (** ["$notify"] - A notification should be shown for this message. *) 48 48 + 49 49 + val muted : string 50 50 + (** ["$muted"] - The user is not interested in future replies to this thread. *) 51 51 + 52 52 + val followed : string 53 53 + (** ["$followed"] - The user is particularly interested in future replies 54 54 + to this thread. Mutually exclusive with muted. *) 55 55 + 56 56 + val memo : string 57 57 + (** ["$memo"] - The message is a note-to-self regarding another message 58 58 + in the same thread. *) 59 59 + 60 60 + val has_memo : string 61 61 + (** ["$hasmemo"] - The message has an associated memo with the $memo keyword. *) 62 62 + 63 63 + val has_attachment : string 64 64 + (** ["$hasattachment"] - The message has an attachment (server-set). *) 65 65 + 66 66 + val has_no_attachment : string 67 67 + (** ["$hasnoattachment"] - The message does not have an attachment (server-set). *) 68 68 + 69 69 + val auto_sent : string 70 70 + (** ["$autosent"] - The message was sent automatically as a response 71 71 + due to a user rule or setting (e.g., vacation response). *) 72 72 + 73 73 + val unsubscribed : string 74 74 + (** ["$unsubscribed"] - The client has unsubscribed from this mailing list. *) 75 75 + 76 76 + val can_unsubscribe : string 77 77 + (** ["$canunsubscribe"] - The message has an RFC8058-compliant 78 78 + List-Unsubscribe header. *) 79 79 + 80 80 + val imported : string 81 81 + (** ["$imported"] - The message was imported from another mailbox. *) 82 82 + 83 83 + val is_trusted : string 84 84 + (** ["$istrusted"] - The authenticity of the from name and email address 85 85 + have been verified with complete confidence by the server. *) 86 86 + 87 87 + val masked_email : string 88 88 + (** ["$maskedemail"] - The message was received via an alias created for 89 89 + an individual sender to hide the user's real email address. *) 90 90 + 91 91 + val new_ : string 92 92 + (** ["$new"] - The message should be made more prominent to the user 93 93 + due to a recent action (e.g., awakening from snooze). *) 94 94 + 95 95 + (** {2 Apple Mail Flag Color Keywords} 96 96 + 97 97 + These 3 keywords form a 3-bit bitmask defining the flag color: 98 98 + - 000 = red, 100 = orange, 010 = yellow, 111 = green 99 99 + - 001 = blue, 101 = purple, 011 = gray 100 100 + 101 101 + These are only meaningful when the message has the $flagged keyword set. *) 102 102 + 103 103 + val mail_flag_bit0 : string 104 104 + (** ["$MailFlagBit0"] - Bit 0 of the flag color bitmask. *) 105 105 + 106 106 + val mail_flag_bit1 : string 107 107 + (** ["$MailFlagBit1"] - Bit 1 of the flag color bitmask. *) 108 108 + 109 109 + val mail_flag_bit2 : string 110 110 + (** ["$MailFlagBit2"] - Bit 2 of the flag color bitmask. *) 111 111 + 112 112 + (** {2 Flag Color Type} 113 113 + 114 114 + High-level type for working with Apple Mail flag colors. *) 115 115 + 116 116 + type flag_color = [ 117 117 + | `Red (** Bits: 000 *) 118 118 + | `Orange (** Bits: 100 *) 119 119 + | `Yellow (** Bits: 010 *) 120 120 + | `Green (** Bits: 111 *) 121 121 + | `Blue (** Bits: 001 *) 122 122 + | `Purple (** Bits: 101 *) 123 123 + | `Gray (** Bits: 011 *) 124 124 + ] 125 125 + 126 126 + val flag_color_to_keywords : flag_color -> string list 127 127 + (** [flag_color_to_keywords color] returns the list of $MailFlagBit keywords 128 128 + that should be set for the given color. *) 129 129 + 130 130 + val flag_color_of_keywords : string list -> flag_color option 131 131 + (** [flag_color_of_keywords keywords] extracts the flag color from a list 132 132 + of keywords, if the $MailFlagBit keywords are present. Returns [None] 133 133 + if no color bits are set (defaults to red when $flagged is set). *) 37 134 end 38 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 + 39 232 (** {1 Email Object} *) 40 233 41 234 type t = { 42 235 (* Metadata - server-set, immutable *) 43 43 - id : Proto_id.t; 44 44 - blob_id : Proto_id.t; 45 45 - thread_id : Proto_id.t; 46 46 - size : int64; 47 47 - 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; 48 241 49 242 (* Metadata - mutable *) 50 50 - mailbox_ids : (Proto_id.t * bool) list; 51 51 - keywords : (string * bool) list; 243 243 + mailbox_ids : (Proto_id.t * bool) list option; 244 244 + keywords : (string * bool) list option; 52 245 53 246 (* Parsed headers *) 54 247 message_id : string list option; ··· 72 265 text_body : Mail_body.Part.t list option; 73 266 html_body : Mail_body.Part.t list option; 74 267 attachments : Mail_body.Part.t list option; 75 75 - has_attachment : bool; 76 76 - 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. *) 77 276 } 78 277 79 79 - val id : t -> Proto_id.t 80 80 - val blob_id : t -> Proto_id.t 81 81 - val thread_id : t -> Proto_id.t 82 82 - val size : t -> int64 83 83 - val received_at : t -> Ptime.t 84 84 - val mailbox_ids : t -> (Proto_id.t * bool) list 85 85 - 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 86 290 val message_id : t -> string list option 87 291 val in_reply_to : t -> string list option 88 292 val references : t -> string list option ··· 100 304 val text_body : t -> Mail_body.Part.t list option 101 305 val html_body : t -> Mail_body.Part.t list option 102 306 val attachments : t -> Mail_body.Part.t list option 103 103 - val has_attachment : t -> bool 104 104 - 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. *) 105 337 106 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}. *) 107 341 108 342 (** {1 Email Filter Conditions} *) 109 343 ··· 136 370 137 371 (** {1 Email/get Arguments} *) 138 372 139 139 - (** 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}. *) 140 377 type get_args_extra = { 141 141 - 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. *) 142 381 fetch_text_body_values : bool; 382 382 + (** If [true], fetch body values for text/* parts in textBody. *) 143 383 fetch_html_body_values : bool; 384 384 + (** If [true], fetch body values for text/* parts in htmlBody. *) 144 385 fetch_all_body_values : bool; 386 386 + (** If [true], fetch body values for all text/* parts. *) 145 387 max_body_value_bytes : int64 option; 388 388 + (** Maximum size of body values to return. Larger values are truncated. *) 146 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. *) 147 400 148 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

+110 -59

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; ··· 46 90 |> Jsont.Object.finish 47 91 end 48 92 49 49 - type role = 50 50 - | All 51 51 - | Archive 52 52 - | Drafts 53 53 - | Flagged 54 54 - | Important 55 55 - | Inbox 56 56 - | Junk 57 57 - | Sent 58 58 - | Subscribed 59 59 - | Trash 60 60 - | Other of string 93 93 + type role = [ 94 94 + | `All 95 95 + | `Archive 96 96 + | `Drafts 97 97 + | `Flagged 98 98 + | `Important 99 99 + | `Inbox 100 100 + | `Junk 101 101 + | `Sent 102 102 + | `Subscribed 103 103 + | `Trash 104 104 + | `Snoozed 105 105 + | `Scheduled 106 106 + | `Memos 107 107 + | `Other of string 108 108 + ] 61 109 62 110 let role_to_string = function 63 63 - | All -> "all" 64 64 - | Archive -> "archive" 65 65 - | Drafts -> "drafts" 66 66 - | Flagged -> "flagged" 67 67 - | Important -> "important" 68 68 - | Inbox -> "inbox" 69 69 - | Junk -> "junk" 70 70 - | Sent -> "sent" 71 71 - | Subscribed -> "subscribed" 72 72 - | Trash -> "trash" 73 73 - | Other s -> s 111 111 + | `All -> "all" 112 112 + | `Archive -> "archive" 113 113 + | `Drafts -> "drafts" 114 114 + | `Flagged -> "flagged" 115 115 + | `Important -> "important" 116 116 + | `Inbox -> "inbox" 117 117 + | `Junk -> "junk" 118 118 + | `Sent -> "sent" 119 119 + | `Subscribed -> "subscribed" 120 120 + | `Trash -> "trash" 121 121 + | `Snoozed -> "snoozed" 122 122 + | `Scheduled -> "scheduled" 123 123 + | `Memos -> "memos" 124 124 + | `Other s -> s 74 125 75 126 let role_of_string = function 76 76 - | "all" -> All 77 77 - | "archive" -> Archive 78 78 - | "drafts" -> Drafts 79 79 - | "flagged" -> Flagged 80 80 - | "important" -> Important 81 81 - | "inbox" -> Inbox 82 82 - | "junk" -> Junk 83 83 - | "sent" -> Sent 84 84 - | "subscribed" -> Subscribed 85 85 - | "trash" -> Trash 86 86 - | s -> Other s 127 127 + | "all" -> `All 128 128 + | "archive" -> `Archive 129 129 + | "drafts" -> `Drafts 130 130 + | "flagged" -> `Flagged 131 131 + | "important" -> `Important 132 132 + | "inbox" -> `Inbox 133 133 + | "junk" -> `Junk 134 134 + | "sent" -> `Sent 135 135 + | "subscribed" -> `Subscribed 136 136 + | "trash" -> `Trash 137 137 + | "snoozed" -> `Snoozed 138 138 + | "scheduled" -> `Scheduled 139 139 + | "memos" -> `Memos 140 140 + | s -> `Other s 87 141 88 142 let role_jsont = 89 143 Jsont.map ~kind:"MailboxRole" ··· 92 146 Jsont.string 93 147 94 148 type t = { 95 95 - id : Proto_id.t; 96 96 - name : string; 149 149 + id : Proto_id.t option; 150 150 + name : string option; 97 151 parent_id : Proto_id.t option; 98 152 role : role option; 99 99 - sort_order : int64; 100 100 - total_emails : int64; 101 101 - unread_emails : int64; 102 102 - total_threads : int64; 103 103 - unread_threads : int64; 104 104 - my_rights : Rights.t; 105 105 - 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; 106 160 } 107 161 108 162 let id t = t.id ··· 124 178 125 179 let jsont = 126 180 let kind = "Mailbox" in 127 127 - (* parentId and role can be null - RFC 8621 Section 2 *) 128 128 - let nullable_id = Jsont.(option Proto_id.jsont) in 129 129 - let nullable_role = Jsont.(option role_jsont) in 130 181 Jsont.Object.map ~kind make 131 131 - |> Jsont.Object.mem "id" Proto_id.jsont ~enc:id 132 132 - |> Jsont.Object.mem "name" Jsont.string ~enc:name 133 133 - |> Jsont.Object.mem "parentId" nullable_id 134 134 - ~dec_absent:None ~enc_omit:Option.is_none ~enc:parent_id 135 135 - |> Jsont.Object.mem "role" nullable_role 136 136 - ~dec_absent:None ~enc_omit:Option.is_none ~enc:role 137 137 - |> Jsont.Object.mem "sortOrder" Proto_int53.Unsigned.jsont ~dec_absent:0L ~enc:sort_order 138 138 - |> Jsont.Object.mem "totalEmails" Proto_int53.Unsigned.jsont ~enc:total_emails 139 139 - |> Jsont.Object.mem "unreadEmails" Proto_int53.Unsigned.jsont ~enc:unread_emails 140 140 - |> Jsont.Object.mem "totalThreads" Proto_int53.Unsigned.jsont ~enc:total_threads 141 141 - |> Jsont.Object.mem "unreadThreads" Proto_int53.Unsigned.jsont ~enc:unread_threads 142 142 - |> Jsont.Object.mem "myRights" Rights.jsont ~enc:my_rights 143 143 - |> 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 144 195 |> Jsont.Object.finish 145 196 146 197 module Filter_condition = struct

+66 -34

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. *) 35 35 + 10 36 (** {1 Mailbox Rights} *) 11 37 12 38 (** Rights the user has on a mailbox. *) ··· 38 64 39 65 (** {1 Standard Roles} *) 40 66 41 41 - (** Standard mailbox roles per RFC 8621 Section 2. *) 42 42 - type role = 43 43 - | All 44 44 - | Archive 45 45 - | Drafts 46 46 - | Flagged 47 47 - | Important 48 48 - | Inbox 49 49 - | Junk 50 50 - | Sent 51 51 - | Subscribed 52 52 - | Trash 53 53 - | Other of string 67 67 + (** Standard mailbox roles per RFC 8621 Section 2 and draft-ietf-mailmaint. *) 68 68 + type role = [ 69 69 + | `All 70 70 + | `Archive 71 71 + | `Drafts 72 72 + | `Flagged 73 73 + | `Important 74 74 + | `Inbox 75 75 + | `Junk 76 76 + | `Sent 77 77 + | `Subscribed 78 78 + | `Trash 79 79 + | `Snoozed (** draft-ietf-mailmaint: Messages snoozed until a later time. *) 80 80 + | `Scheduled (** draft-ietf-mailmaint: Messages scheduled to send. *) 81 81 + | `Memos (** draft-ietf-mailmaint: Messages with the $memo keyword. *) 82 82 + | `Other of string 83 83 + ] 54 84 55 85 val role_to_string : role -> string 56 86 val role_of_string : string -> role ··· 59 89 (** {1 Mailbox} *) 60 90 61 91 type t = { 62 62 - id : Proto_id.t; 92 92 + id : Proto_id.t option; 63 93 (** Server-assigned mailbox id. *) 64 64 - name : string; 94 94 + name : string option; 65 95 (** User-visible name (UTF-8). *) 66 96 parent_id : Proto_id.t option; 67 67 - (** 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". *) 68 99 role : role option; 69 69 - (** Standard role, if any. *) 70 70 - 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; 71 103 (** Sort order hint (lower = displayed first). *) 72 72 - total_emails : int64; 104 104 + total_emails : int64 option; 73 105 (** Total number of emails in mailbox. *) 74 74 - unread_emails : int64; 106 106 + unread_emails : int64 option; 75 107 (** Number of unread emails. *) 76 76 - total_threads : int64; 108 108 + total_threads : int64 option; 77 109 (** Total number of threads. *) 78 78 - unread_threads : int64; 110 110 + unread_threads : int64 option; 79 111 (** Number of threads with unread emails. *) 80 80 - my_rights : Rights.t; 112 112 + my_rights : Rights.t option; 81 113 (** User's rights on this mailbox. *) 82 82 - is_subscribed : bool; 114 114 + is_subscribed : bool option; 83 115 (** Whether user is subscribed to this mailbox. *) 84 116 } 85 117 86 86 - val id : t -> Proto_id.t 87 87 - val name : t -> string 118 118 + val id : t -> Proto_id.t option 119 119 + val name : t -> string option 88 120 val parent_id : t -> Proto_id.t option 89 121 val role : t -> role option 90 90 - val sort_order : t -> int64 91 91 - val total_emails : t -> int64 92 92 - val unread_emails : t -> int64 93 93 - val total_threads : t -> int64 94 94 - val unread_threads : t -> int64 95 95 - val my_rights : t -> Rights.t 96 96 - 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 97 129 98 130 val jsont : t Jsont.t 99 131

+78 -37

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; ··· 42 83 end 43 84 44 85 module Delivery_status = struct 45 45 - type delivered = Queued | Yes | No | Unknown 86 86 + type delivered = [ `Queued | `Yes | `No | `Unknown ] 46 87 47 88 let delivered_to_string = function 48 48 - | Queued -> "queued" 49 49 - | Yes -> "yes" 50 50 - | No -> "no" 51 51 - | Unknown -> "unknown" 89 89 + | `Queued -> "queued" 90 90 + | `Yes -> "yes" 91 91 + | `No -> "no" 92 92 + | `Unknown -> "unknown" 52 93 53 94 let delivered_of_string = function 54 54 - | "queued" -> Queued 55 55 - | "yes" -> Yes 56 56 - | "no" -> No 57 57 - | _ -> Unknown 95 95 + | "queued" -> `Queued 96 96 + | "yes" -> `Yes 97 97 + | "no" -> `No 98 98 + | _ -> `Unknown 58 99 59 100 let delivered_jsont = 60 101 Jsont.map ~kind:"DeliveryStatus.delivered" 61 102 ~dec:delivered_of_string ~enc:delivered_to_string Jsont.string 62 103 63 63 - type displayed = Unknown | Yes 104 104 + type displayed = [ `Unknown | `Yes ] 64 105 65 106 let displayed_to_string = function 66 66 - | Unknown -> "unknown" 67 67 - | Yes -> "yes" 107 107 + | `Unknown -> "unknown" 108 108 + | `Yes -> "yes" 68 109 69 110 let displayed_of_string = function 70 70 - | "yes" -> Yes 71 71 - | _ -> Unknown 111 111 + | "yes" -> `Yes 112 112 + | _ -> `Unknown 72 113 73 114 let displayed_jsont = 74 115 Jsont.map ~kind:"DeliveryStatus.displayed" ··· 96 137 |> Jsont.Object.finish 97 138 end 98 139 99 99 - type undo_status = Pending | Final | Canceled 140 140 + type undo_status = [ `Pending | `Final | `Canceled ] 100 141 101 142 let undo_status_to_string = function 102 102 - | Pending -> "pending" 103 103 - | Final -> "final" 104 104 - | Canceled -> "canceled" 143 143 + | `Pending -> "pending" 144 144 + | `Final -> "final" 145 145 + | `Canceled -> "canceled" 105 146 106 147 let undo_status_of_string = function 107 107 - | "pending" -> Pending 108 108 - | "final" -> Final 109 109 - | "canceled" -> Canceled 148 148 + | "pending" -> `Pending 149 149 + | "final" -> `Final 150 150 + | "canceled" -> `Canceled 110 151 | s -> Jsont.Error.msgf Jsont.Meta.none "Unknown undo status: %s" s 111 152 112 153 let undo_status_jsont = ··· 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

+57 -29

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 ··· 45 70 46 71 (** Status of delivery to a recipient. *) 47 72 module Delivery_status : sig 48 48 - type delivered = 49 49 - | Queued 50 50 - | Yes 51 51 - | No 52 52 - | Unknown 73 73 + type delivered = [ 74 74 + | `Queued 75 75 + | `Yes 76 76 + | `No 77 77 + | `Unknown 78 78 + ] 53 79 54 54 - type displayed = 55 55 - | Unknown 56 56 - | Yes 80 80 + type displayed = [ 81 81 + | `Unknown 82 82 + | `Yes 83 83 + ] 57 84 58 85 type t = { 59 86 smtp_reply : string; ··· 73 100 74 101 (** {1 Undo Status} *) 75 102 76 76 - type undo_status = 77 77 - | Pending 78 78 - | Final 79 79 - | Canceled 103 103 + type undo_status = [ 104 104 + | `Pending 105 105 + | `Final 106 106 + | `Canceled 107 107 + ] 80 108 81 109 val undo_status_jsont : undo_status Jsont.t 82 110 83 111 (** {1 EmailSubmission} *) 84 112 85 113 type t = { 86 86 - id : Proto_id.t; 114 114 + id : Proto_id.t option; 87 115 (** Server-assigned submission id. *) 88 88 - identity_id : Proto_id.t; 116 116 + identity_id : Proto_id.t option; 89 117 (** The identity used to send. *) 90 90 - email_id : Proto_id.t; 118 118 + email_id : Proto_id.t option; 91 119 (** The email that was submitted. *) 92 92 - thread_id : Proto_id.t; 120 120 + thread_id : Proto_id.t option; 93 121 (** The thread of the submitted email. *) 94 122 envelope : Envelope.t option; 95 123 (** The envelope used, if different from email headers. *) 96 96 - send_at : Ptime.t; 124 124 + send_at : Ptime.t option; 97 125 (** When the email was/will be sent. *) 98 98 - undo_status : undo_status; 126 126 + undo_status : undo_status option; 99 127 (** Whether sending can be undone. *) 100 128 delivery_status : (string * Delivery_status.t) list option; 101 129 (** Delivery status per recipient. *) 102 102 - dsn_blob_ids : Proto_id.t list; 130 130 + dsn_blob_ids : Proto_id.t list option; 103 131 (** Blob ids of received DSN messages. *) 104 104 - mdn_blob_ids : Proto_id.t list; 132 132 + mdn_blob_ids : Proto_id.t list option; 105 133 (** Blob ids of received MDN messages. *) 106 134 } 107 135 108 108 - val id : t -> Proto_id.t 109 109 - val identity_id : t -> Proto_id.t 110 110 - val email_id : t -> Proto_id.t 111 111 - 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 112 140 val envelope : t -> Envelope.t option 113 113 - val send_at : t -> Ptime.t 114 114 - val undo_status : t -> undo_status 141 141 + val send_at : t -> Ptime.t option 142 142 + val undo_status : t -> undo_status option 115 143 val delivery_status : t -> (string * Delivery_status.t) list option 116 116 - val dsn_blob_ids : t -> Proto_id.t list 117 117 - 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 118 146 119 147 val jsont : t Jsont.t 120 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

+93 -81

lib/proto/proto_error.ml

··· 4 4 ---------------------------------------------------------------------------*) 5 5 6 6 module Request_error = struct 7 7 - type urn = 8 8 - | Unknown_capability 9 9 - | Not_json 10 10 - | Not_request 11 11 - | Limit 12 12 - | Other of string 7 7 + type urn = [ 8 8 + | `Unknown_capability 9 9 + | `Not_json 10 10 + | `Not_request 11 11 + | `Limit 12 12 + | `Other of string 13 13 + ] 13 14 14 15 let urn_to_string = function 15 15 - | Unknown_capability -> "urn:ietf:params:jmap:error:unknownCapability" 16 16 - | Not_json -> "urn:ietf:params:jmap:error:notJSON" 17 17 - | Not_request -> "urn:ietf:params:jmap:error:notRequest" 18 18 - | Limit -> "urn:ietf:params:jmap:error:limit" 19 19 - | Other s -> s 16 16 + | `Unknown_capability -> "urn:ietf:params:jmap:error:unknownCapability" 17 17 + | `Not_json -> "urn:ietf:params:jmap:error:notJSON" 18 18 + | `Not_request -> "urn:ietf:params:jmap:error:notRequest" 19 19 + | `Limit -> "urn:ietf:params:jmap:error:limit" 20 20 + | `Other s -> s 20 21 21 22 let urn_of_string = function 22 22 - | "urn:ietf:params:jmap:error:unknownCapability" -> Unknown_capability 23 23 - | "urn:ietf:params:jmap:error:notJSON" -> Not_json 24 24 - | "urn:ietf:params:jmap:error:notRequest" -> Not_request 25 25 - | "urn:ietf:params:jmap:error:limit" -> Limit 26 26 - | s -> Other s 23 23 + | "urn:ietf:params:jmap:error:unknownCapability" -> `Unknown_capability 24 24 + | "urn:ietf:params:jmap:error:notJSON" -> `Not_json 25 25 + | "urn:ietf:params:jmap:error:notRequest" -> `Not_request 26 26 + | "urn:ietf:params:jmap:error:limit" -> `Limit 27 27 + | s -> `Other s 27 28 28 29 let urn_jsont = 29 30 let kind = "Request error URN" in ··· 60 61 |> Jsont.Object.finish 61 62 end 62 63 63 63 - type method_error_type = 64 64 - | Server_unavailable 65 65 - | Server_fail 66 66 - | Server_partial_fail 67 67 - | Unknown_method 68 68 - | Invalid_arguments 69 69 - | Invalid_result_reference 70 70 - | Forbidden 71 71 - | Account_not_found 72 72 - | Account_not_supported_by_method 73 73 - | Account_read_only 74 74 - | Other of string 64 64 + type method_error_type = [ 65 65 + | `Server_unavailable 66 66 + | `Server_fail 67 67 + | `Server_partial_fail 68 68 + | `Unknown_method 69 69 + | `Invalid_arguments 70 70 + | `Invalid_result_reference 71 71 + | `Forbidden 72 72 + | `Account_not_found 73 73 + | `Account_not_supported_by_method 74 74 + | `Account_read_only 75 75 + | `Other of string 76 76 + ] 75 77 76 78 let method_error_type_to_string = function 77 77 - | Server_unavailable -> "serverUnavailable" 78 78 - | Server_fail -> "serverFail" 79 79 - | Server_partial_fail -> "serverPartialFail" 80 80 - | Unknown_method -> "unknownMethod" 81 81 - | Invalid_arguments -> "invalidArguments" 82 82 - | Invalid_result_reference -> "invalidResultReference" 83 83 - | Forbidden -> "forbidden" 84 84 - | Account_not_found -> "accountNotFound" 85 85 - | Account_not_supported_by_method -> "accountNotSupportedByMethod" 86 86 - | Account_read_only -> "accountReadOnly" 87 87 - | Other s -> s 79 79 + | `Server_unavailable -> "serverUnavailable" 80 80 + | `Server_fail -> "serverFail" 81 81 + | `Server_partial_fail -> "serverPartialFail" 82 82 + | `Unknown_method -> "unknownMethod" 83 83 + | `Invalid_arguments -> "invalidArguments" 84 84 + | `Invalid_result_reference -> "invalidResultReference" 85 85 + | `Forbidden -> "forbidden" 86 86 + | `Account_not_found -> "accountNotFound" 87 87 + | `Account_not_supported_by_method -> "accountNotSupportedByMethod" 88 88 + | `Account_read_only -> "accountReadOnly" 89 89 + | `Other s -> s 88 90 89 91 let method_error_type_of_string = function 90 90 - | "serverUnavailable" -> Server_unavailable 91 91 - | "serverFail" -> Server_fail 92 92 - | "serverPartialFail" -> Server_partial_fail 93 93 - | "unknownMethod" -> Unknown_method 94 94 - | "invalidArguments" -> Invalid_arguments 95 95 - | "invalidResultReference" -> Invalid_result_reference 96 96 - | "forbidden" -> Forbidden 97 97 - | "accountNotFound" -> Account_not_found 98 98 - | "accountNotSupportedByMethod" -> Account_not_supported_by_method 99 99 - | "accountReadOnly" -> Account_read_only 100 100 - | s -> Other s 92 92 + | "serverUnavailable" -> `Server_unavailable 93 93 + | "serverFail" -> `Server_fail 94 94 + | "serverPartialFail" -> `Server_partial_fail 95 95 + | "unknownMethod" -> `Unknown_method 96 96 + | "invalidArguments" -> `Invalid_arguments 97 97 + | "invalidResultReference" -> `Invalid_result_reference 98 98 + | "forbidden" -> `Forbidden 99 99 + | "accountNotFound" -> `Account_not_found 100 100 + | "accountNotSupportedByMethod" -> `Account_not_supported_by_method 101 101 + | "accountReadOnly" -> `Account_read_only 102 102 + | s -> `Other s 101 103 102 104 let method_error_type_jsont = 103 105 let kind = "Method error type" in ··· 122 124 |> Jsont.Object.opt_mem "description" Jsont.string ~enc:method_error_description 123 125 |> Jsont.Object.finish 124 126 125 125 - type set_error_type = 126 126 - | Forbidden 127 127 - | Over_quota 128 128 - | Too_large 129 129 - | Rate_limit 130 130 - | Not_found 131 131 - | Invalid_patch 132 132 - | Will_destroy 133 133 - | Invalid_properties 134 134 - | Singleton 135 135 - | Other of string 127 127 + type set_error_type = [ 128 128 + | `Forbidden 129 129 + | `Over_quota 130 130 + | `Too_large 131 131 + | `Rate_limit 132 132 + | `Not_found 133 133 + | `Invalid_patch 134 134 + | `Will_destroy 135 135 + | `Invalid_properties 136 136 + | `Singleton 137 137 + | `Forbidden_mail_from 138 138 + | `Forbidden_from 139 139 + | `Forbidden_to_send 140 140 + | `Other of string 141 141 + ] 136 142 137 143 let set_error_type_to_string = function 138 138 - | Forbidden -> "forbidden" 139 139 - | Over_quota -> "overQuota" 140 140 - | Too_large -> "tooLarge" 141 141 - | Rate_limit -> "rateLimit" 142 142 - | Not_found -> "notFound" 143 143 - | Invalid_patch -> "invalidPatch" 144 144 - | Will_destroy -> "willDestroy" 145 145 - | Invalid_properties -> "invalidProperties" 146 146 - | Singleton -> "singleton" 147 147 - | Other s -> s 144 144 + | `Forbidden -> "forbidden" 145 145 + | `Over_quota -> "overQuota" 146 146 + | `Too_large -> "tooLarge" 147 147 + | `Rate_limit -> "rateLimit" 148 148 + | `Not_found -> "notFound" 149 149 + | `Invalid_patch -> "invalidPatch" 150 150 + | `Will_destroy -> "willDestroy" 151 151 + | `Invalid_properties -> "invalidProperties" 152 152 + | `Singleton -> "singleton" 153 153 + | `Forbidden_mail_from -> "forbiddenMailFrom" 154 154 + | `Forbidden_from -> "forbiddenFrom" 155 155 + | `Forbidden_to_send -> "forbiddenToSend" 156 156 + | `Other s -> s 148 157 149 158 let set_error_type_of_string = function 150 150 - | "forbidden" -> Forbidden 151 151 - | "overQuota" -> Over_quota 152 152 - | "tooLarge" -> Too_large 153 153 - | "rateLimit" -> Rate_limit 154 154 - | "notFound" -> Not_found 155 155 - | "invalidPatch" -> Invalid_patch 156 156 - | "willDestroy" -> Will_destroy 157 157 - | "invalidProperties" -> Invalid_properties 158 158 - | "singleton" -> Singleton 159 159 - | s -> Other s 159 159 + | "forbidden" -> `Forbidden 160 160 + | "overQuota" -> `Over_quota 161 161 + | "tooLarge" -> `Too_large 162 162 + | "rateLimit" -> `Rate_limit 163 163 + | "notFound" -> `Not_found 164 164 + | "invalidPatch" -> `Invalid_patch 165 165 + | "willDestroy" -> `Will_destroy 166 166 + | "invalidProperties" -> `Invalid_properties 167 167 + | "singleton" -> `Singleton 168 168 + | "forbiddenMailFrom" -> `Forbidden_mail_from 169 169 + | "forbiddenFrom" -> `Forbidden_from 170 170 + | "forbiddenToSend" -> `Forbidden_to_send 171 171 + | s -> `Other s 160 172 161 173 let set_error_type_jsont = 162 174 let kind = "SetError type" in

+40 -30

lib/proto/proto_error.mli

··· 14 14 15 15 (** Request-level error URNs *) 16 16 module Request_error : sig 17 17 - type urn = 18 18 - | Unknown_capability 17 17 + type urn = [ 18 18 + | `Unknown_capability 19 19 (** urn:ietf:params:jmap:error:unknownCapability 20 20 The client included a capability in "using" that the server does not support. *) 21 21 - | Not_json 21 21 + | `Not_json 22 22 (** urn:ietf:params:jmap:error:notJSON 23 23 The content type was not application/json or the request was not valid JSON. *) 24 24 - | Not_request 24 24 + | `Not_request 25 25 (** urn:ietf:params:jmap:error:notRequest 26 26 The request was valid JSON but not a valid JMAP Request object. *) 27 27 - | Limit 27 27 + | `Limit 28 28 (** urn:ietf:params:jmap:error:limit 29 29 A server-defined limit was reached. *) 30 30 - | Other of string 30 30 + | `Other of string 31 31 (** Other URN not in the standard set. *) 32 32 + ] 32 33 33 34 val urn_to_string : urn -> string 34 35 (** [urn_to_string urn] returns the URN string. *) ··· 60 61 when a method call fails. *) 61 62 62 63 (** Standard method error types per RFC 8620 Section 3.6.2 *) 63 63 - type method_error_type = 64 64 - | Server_unavailable 64 64 + type method_error_type = [ 65 65 + | `Server_unavailable 65 66 (** The server is temporarily unavailable. *) 66 66 - | Server_fail 67 67 + | `Server_fail 67 68 (** An unexpected error occurred. *) 68 68 - | Server_partial_fail 69 69 + | `Server_partial_fail 69 70 (** Some, but not all, changes were successfully made. *) 70 70 - | Unknown_method 71 71 + | `Unknown_method 71 72 (** The method name is not recognized. *) 72 72 - | Invalid_arguments 73 73 + | `Invalid_arguments 73 74 (** One or more arguments are invalid. *) 74 74 - | Invalid_result_reference 75 75 + | `Invalid_result_reference 75 76 (** A result reference could not be resolved. *) 76 76 - | Forbidden 77 77 + | `Forbidden 77 78 (** The method/arguments are valid but forbidden. *) 78 78 - | Account_not_found 79 79 + | `Account_not_found 79 80 (** The accountId does not correspond to a valid account. *) 80 80 - | Account_not_supported_by_method 81 81 + | `Account_not_supported_by_method 81 82 (** The account does not support this method. *) 82 82 - | Account_read_only 83 83 + | `Account_read_only 83 84 (** The account is read-only. *) 84 84 - | Other of string 85 85 + | `Other of string 85 86 (** Other error type not in the standard set. *) 87 87 + ] 86 88 87 89 val method_error_type_to_string : method_error_type -> string 88 90 (** [method_error_type_to_string t] returns the type string. *) ··· 105 107 106 108 Errors returned in notCreated/notUpdated/notDestroyed responses. *) 107 109 108 108 - (** Standard SetError types per RFC 8620 Section 5.3 *) 109 109 - type set_error_type = 110 110 - | Forbidden 110 110 + (** Standard SetError types per RFC 8620 Section 5.3 and RFC 8621 Section 7 *) 111 111 + type set_error_type = [ 112 112 + | `Forbidden 111 113 (** The operation is not permitted. *) 112 112 - | Over_quota 114 114 + | `Over_quota 113 115 (** The maximum server quota has been reached. *) 114 114 - | Too_large 116 116 + | `Too_large 115 117 (** The object is too large. *) 116 116 - | Rate_limit 118 118 + | `Rate_limit 117 119 (** Too many objects of this type have been created recently. *) 118 118 - | Not_found 120 120 + | `Not_found 119 121 (** The id does not exist (for update/destroy). *) 120 120 - | Invalid_patch 122 122 + | `Invalid_patch 121 123 (** The PatchObject is invalid. *) 122 122 - | Will_destroy 124 124 + | `Will_destroy 123 125 (** The object will be destroyed by another operation in the request. *) 124 124 - | Invalid_properties 126 126 + | `Invalid_properties 125 127 (** Some properties were invalid. *) 126 126 - | Singleton 128 128 + | `Singleton 127 129 (** Only one object of this type can exist (for create). *) 128 128 - | Other of string 130 130 + | `Forbidden_mail_from 131 131 + (** RFC 8621: The server does not permit the user to send from the address. *) 132 132 + | `Forbidden_from 133 133 + (** RFC 8621: The server does not permit the user to send a message with 134 134 + the From header of the message to be sent. *) 135 135 + | `Forbidden_to_send 136 136 + (** RFC 8621: The user does not have permission to send at all. *) 137 137 + | `Other of string 129 138 (** Other error type. *) 139 139 + ] 130 140 131 141 val set_error_type_to_string : set_error_type -> string 132 142 val set_error_type_of_string : string -> set_error_type

+7 -7

lib/proto/proto_filter.ml

··· 3 3 SPDX-License-Identifier: ISC 4 4 ---------------------------------------------------------------------------*) 5 5 6 6 - type operator = And | Or | Not 6 6 + type operator = [ `And | `Or | `Not ] 7 7 8 8 let operator_to_string = function 9 9 - | And -> "AND" 10 10 - | Or -> "OR" 11 11 - | Not -> "NOT" 9 9 + | `And -> "AND" 10 10 + | `Or -> "OR" 11 11 + | `Not -> "NOT" 12 12 13 13 let operator_of_string = function 14 14 - | "AND" -> And 15 15 - | "OR" -> Or 16 16 - | "NOT" -> Not 14 14 + | "AND" -> `And 15 15 + | "OR" -> `Or 16 16 + | "NOT" -> `Not 17 17 | s -> Jsont.Error.msgf Jsont.Meta.none "Unknown filter operator: %s" s 18 18 19 19 let operator_jsont =

+5 -4

lib/proto/proto_filter.mli

··· 10 10 (** {1 Filter Operators} *) 11 11 12 12 (** Filter operator types. *) 13 13 - type operator = 14 14 - | And (** All conditions must match *) 15 15 - | Or (** At least one condition must match *) 16 16 - | Not (** Inverts a single condition *) 13 13 + type operator = [ 14 14 + | `And (** All conditions must match *) 15 15 + | `Or (** At least one condition must match *) 16 16 + | `Not (** Inverts a single condition *) 17 17 + ] 17 18 18 19 val operator_jsont : operator Jsont.t 19 20 (** JSON codec for filter operators. *)

+18 -8

lib/proto/proto_method.ml

··· 132 132 133 133 let set_response_jsont (type a) (obj_jsont : a Jsont.t) : a set_response Jsont.t = 134 134 let kind = "SetResponse" in 135 135 + (* All map/list fields in SetResponse can be null per RFC 8620 Section 5.3 *) 136 136 + (* opt_mem handles missing keys, Jsont.option handles explicit null values *) 137 137 + (* Option.join flattens option option -> option *) 138 138 + let join = Option.join in 135 139 let make account_id old_state new_state created updated destroyed 136 140 not_created not_updated not_destroyed = 137 137 - { account_id; old_state; new_state; created; updated; destroyed; 138 138 - not_created; not_updated; not_destroyed } 141 141 + { account_id; old_state; new_state; 142 142 + created = join created; 143 143 + updated = join updated; 144 144 + destroyed = join destroyed; 145 145 + not_created = join not_created; 146 146 + not_updated = join not_updated; 147 147 + not_destroyed = join not_destroyed } 139 148 in 140 149 (* For updated values, the server may return null or an object - RFC 8620 Section 5.3 *) 141 150 (* "Id[Foo|null]" means map values can be null, use Jsont.option to handle this *) 142 151 let nullable_obj = Jsont.(option obj_jsont) in 152 152 + let opt enc = Option.map Option.some enc in 143 153 Jsont.Object.map ~kind make 144 154 |> Jsont.Object.mem "accountId" Proto_id.jsont ~enc:(fun r -> r.account_id) 145 155 |> Jsont.Object.opt_mem "oldState" Jsont.string ~enc:(fun r -> r.old_state) 146 156 |> Jsont.Object.mem "newState" Jsont.string ~enc:(fun r -> r.new_state) 147 147 - |> Jsont.Object.opt_mem "created" (Proto_json_map.of_id obj_jsont) ~enc:(fun r -> r.created) 148 148 - |> Jsont.Object.opt_mem "updated" (Proto_json_map.of_id nullable_obj) ~enc:(fun r -> r.updated) 149 149 - |> Jsont.Object.opt_mem "destroyed" (Jsont.list Proto_id.jsont) ~enc:(fun r -> r.destroyed) 150 150 - |> Jsont.Object.opt_mem "notCreated" (Proto_json_map.of_id Proto_error.set_error_jsont) ~enc:(fun r -> r.not_created) 151 151 - |> Jsont.Object.opt_mem "notUpdated" (Proto_json_map.of_id Proto_error.set_error_jsont) ~enc:(fun r -> r.not_updated) 152 152 - |> Jsont.Object.opt_mem "notDestroyed" (Proto_json_map.of_id Proto_error.set_error_jsont) ~enc:(fun r -> r.not_destroyed) 157 157 + |> Jsont.Object.opt_mem "created" Jsont.(option (Proto_json_map.of_id obj_jsont)) ~enc:(fun r -> opt r.created) 158 158 + |> Jsont.Object.opt_mem "updated" Jsont.(option (Proto_json_map.of_id nullable_obj)) ~enc:(fun r -> opt r.updated) 159 159 + |> Jsont.Object.opt_mem "destroyed" Jsont.(option (list Proto_id.jsont)) ~enc:(fun r -> opt r.destroyed) 160 160 + |> Jsont.Object.opt_mem "notCreated" Jsont.(option (Proto_json_map.of_id Proto_error.set_error_jsont)) ~enc:(fun r -> opt r.not_created) 161 161 + |> Jsont.Object.opt_mem "notUpdated" Jsont.(option (Proto_json_map.of_id Proto_error.set_error_jsont)) ~enc:(fun r -> opt r.not_updated) 162 162 + |> Jsont.Object.opt_mem "notDestroyed" Jsont.(option (Proto_json_map.of_id Proto_error.set_error_jsont)) ~enc:(fun r -> opt r.not_destroyed) 153 163 |> Jsont.Object.finish 154 164 155 165 (* Foo/copy *)

+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. *)

+28 -22

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 ··· 512 518 match decode Error.method_error_jsont json with 513 519 | Error e -> Alcotest.failf "decode failed: %s" (Jsont.Error.to_string e) 514 520 | Ok err -> 515 515 - Alcotest.(check method_error_type_testable) "type" Error.Unknown_method err.type_ 521 521 + Alcotest.(check method_error_type_testable) "type" `Unknown_method err.type_ 516 522 517 523 (* Additional error type tests *) 518 524 let test_set_error_forbidden () = ··· 561 567 match decode Error.set_error_jsont json with 562 568 | Error e -> Alcotest.failf "decode failed: %s" (Jsont.Error.to_string e) 563 569 | Ok err -> 564 564 - Alcotest.(check set_error_type_testable) "type" Error.Invalid_properties err.Error.type_; 570 570 + Alcotest.(check set_error_type_testable) "type" `Invalid_properties err.Error.type_; 565 571 match err.Error.properties with 566 572 | None -> Alcotest.fail "expected properties" 567 573 | Some props -> Alcotest.(check int) "properties count" 2 (List.length props) ··· 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); 612 612 - Alcotest.(check (option role_testable)) "role" (Some Mailbox.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) 616 616 + Alcotest.(check string) "id" "mb1" (get_id (Mailbox.id mb)); 617 617 + Alcotest.(check string) "name" "Inbox" (get_string (Mailbox.name mb)); 618 618 + Alcotest.(check (option role_testable)) "role" (Some `Inbox) (Mailbox.role 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" () ··· 627 633 match decode Mailbox.jsont json with 628 634 | Error e -> Alcotest.failf "decode failed: %s" (Jsont.Error.to_string e) 629 635 | Ok mb -> 630 630 - Alcotest.(check (option role_testable)) "role" (Some Mailbox.Archive) (Mailbox.role mb); 631 631 - Alcotest.(check int64) "totalEmails" 1000L (Mailbox.total_emails mb) 636 636 + Alcotest.(check (option role_testable)) "role" (Some `Archive) (Mailbox.role 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 - | Submission.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))